diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 8383a12af..205771924 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -537,9 +537,10 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) { scm_t_ptrdiff n; + scm_t_int32 offset; + n = FETCH () << 8; n += FETCH (); - scm_t_int32 offset; FETCH_OFFSET (offset); if (sp - (fp - 1) > n) ip += offset; @@ -613,54 +614,65 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, NEXT; } +/* Flags that determine whether other keywords are allowed, and whether a + rest argument is expected. These values must match those used by the + glil->assembly compiler. */ +#define F_ALLOW_OTHER_KEYS 1 +#define F_REST 2 + VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) { scm_t_uint16 idx; scm_t_ptrdiff nkw; - int allow_other_keys_and_rest; + int kw_and_rest_flags; SCM kw; idx = FETCH () << 8; idx += FETCH (); + /* XXX: We don't actually use NKW. */ nkw = FETCH () << 8; nkw += FETCH (); - allow_other_keys_and_rest = FETCH (); + kw_and_rest_flags = FETCH (); - if (!(allow_other_keys_and_rest & 2) - &&(sp - (fp - 1) - nkw) % 2) + if (!(kw_and_rest_flags & F_REST) + && ((sp - (fp - 1) - nkw) % 2)) goto vm_error_kwargs_length_not_even; CHECK_OBJECT (idx); kw = OBJECT_REF (idx); - /* switch nkw to be a negative index below sp */ - for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw += 2) + + /* Switch NKW to be a negative index below SP. */ + for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) { SCM walk; - if (!scm_is_keyword (sp[nkw])) - { - if (allow_other_keys_and_rest & 2) - /* reached the end of keywords, but we have a rest arg; just cut - out */ - break; - else - goto vm_error_kwargs_invalid_keyword; - } - for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) - { - if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) - { - SCM si = SCM_CDAR (walk); - LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), - sp[nkw + 1]); - break; - } - } - if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk)) - goto vm_error_kwargs_unrecognized_keyword; + + if (scm_is_keyword (sp[nkw])) + { + for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) + { + if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) + { + SCM si = SCM_CDAR (walk); + LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), + sp[nkw + 1]); + break; + } + } + if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk)) + goto vm_error_kwargs_unrecognized_keyword; + + nkw++; + } + else if (!(kw_and_rest_flags & F_REST)) + goto vm_error_kwargs_invalid_keyword; } NEXT; } +#undef F_ALLOW_OTHER_KEYS +#undef F_REST + + VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) { scm_t_ptrdiff n; diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm index 22dfa9fa2..5ad9e8121 100644 --- a/module/ice-9/optargs.scm +++ b/module/ice-9/optargs.scm @@ -311,7 +311,7 @@ ;; it has to be this way, vars are allocated in this order (set-car! slots-tail args-tail) (if (pair? kw-indices) - (key slots (cdr slots-tail) args-tail inits) + (permissive-keys slots (cdr slots-tail) args-tail inits) (rest-or-key slots (cdr slots-tail) '() inits #f))) ((pair? kw-indices) ;; fail early here, because once we're in keyword land we throw @@ -322,6 +322,28 @@ #f) ;; fail (else slots))) + (define (permissive-keys slots slots-tail args-tail inits) + (cond + ((null? args-tail) + (if (null? inits) + slots + (begin + (if (eq? (car slots-tail) *uninitialized*) + (set-car! slots-tail (apply (car inits) slots))) + (permissive-keys slots (cdr slots-tail) '() (cdr inits))))) + ((not (keyword? (car args-tail))) + (permissive-keys slots slots-tail (cdr args-tail) inits)) + ((and (keyword? (car args-tail)) + (pair? (cdr args-tail)) + (assq-ref kw-indices (car args-tail))) + => (lambda (i) + (list-set! slots i (cadr args-tail)) + (permissive-keys slots slots-tail (cddr args-tail) inits))) + ((and (keyword? (car args-tail)) + (pair? (cdr args-tail)) + allow-other-keys?) + (permissive-keys slots slots-tail (cddr args-tail) inits)) + (else (error "unrecognized keyword" args-tail)))) (define (key slots slots-tail args-tail inits) (cond ((null? args-tail)