mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

with a rest arg, allow for keywords anywhere

Browse source 
* libguile/vm-i-system.c (br-if-nargs-gt): Fix variable declaration
  placement.
  (bind-kwargs): Patch mostly by Ludovic: it seems that in the mode in
  which we have rest args, the keywords can appear anywhere. Bummer.
  Change to allow for this.

* module/ice-9/optargs.scm (parse-lambda-case): Same, add a
  permissive-keys clause that handles the case in which there's a rest
  argument.
This commit is contained in:
Andy Wingo 2009-11-16 22:32:54 +01:00
parent 222831b443
commit ff74e44ecb
2 changed files with 63 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

68
libguile/vm-i-system.c
View file

@ -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) VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
{ {
scm_t_ptrdiff n; scm_t_ptrdiff n;
scm_t_int32 offset;
n = FETCH () << 8; n = FETCH () << 8;
n += FETCH (); n += FETCH ();
scm_t_int32 offset;
FETCH_OFFSET (offset); FETCH_OFFSET (offset);
if (sp - (fp - 1) > n) if (sp - (fp - 1) > n)
ip += offset; ip += offset;
@ -613,54 +614,65 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6,
NEXT; 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) VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
{ {
scm_t_uint16 idx; scm_t_uint16 idx;
scm_t_ptrdiff nkw; scm_t_ptrdiff nkw;
int allow_other_keys_and_rest; int kw_and_rest_flags;
SCM kw; SCM kw;
idx = FETCH () << 8; idx = FETCH () << 8;
idx += FETCH (); idx += FETCH ();
/* XXX: We don't actually use NKW. */
nkw = FETCH () << 8; nkw = FETCH () << 8;
nkw += FETCH (); nkw += FETCH ();
allow_other_keys_and_rest = FETCH (); kw_and_rest_flags = FETCH ();
if (!(allow_other_keys_and_rest & 2) if (!(kw_and_rest_flags & F_REST)
&&(sp - (fp - 1) - nkw) % 2) && ((sp - (fp - 1) - nkw) % 2))
goto vm_error_kwargs_length_not_even; goto vm_error_kwargs_length_not_even;
CHECK_OBJECT (idx); CHECK_OBJECT (idx);
kw = OBJECT_REF (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; SCM walk;
if (!scm_is_keyword (sp[nkw]))
{ 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 for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
out */ {
break; if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
else {
goto vm_error_kwargs_invalid_keyword; SCM si = SCM_CDAR (walk);
} LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) sp[nkw + 1]);
{ break;
if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) }
{ }
SCM si = SCM_CDAR (walk); if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), goto vm_error_kwargs_unrecognized_keyword;
sp[nkw + 1]);
break; nkw++;
} }
} else if (!(kw_and_rest_flags & F_REST))
if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk)) goto vm_error_kwargs_invalid_keyword;
goto vm_error_kwargs_unrecognized_keyword;
} }
NEXT; NEXT;
} }
#undef F_ALLOW_OTHER_KEYS
#undef F_REST
VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
{ {
scm_t_ptrdiff n; scm_t_ptrdiff n;

24
module/ice-9/optargs.scm
View file

@ -311,7 +311,7 @@
;; it has to be this way, vars are allocated in this order ;; it has to be this way, vars are allocated in this order
(set-car! slots-tail args-tail) (set-car! slots-tail args-tail)
(if (pair? kw-indices) (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))) (rest-or-key slots (cdr slots-tail) '() inits #f)))
((pair? kw-indices) ((pair? kw-indices)
;; fail early here, because once we're in keyword land we throw ;; fail early here, because once we're in keyword land we throw
@ -322,6 +322,28 @@
#f) ;; fail #f) ;; fail
(else (else
slots))) 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) (define (key slots slots-tail args-tail inits)
(cond (cond
((null? args-tail) ((null? args-tail)