with a rest arg, allow for keywords anywhere

* 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.

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8383a12..2057719 100644 (file)
--- 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 22dfa9f..5ad9e81 100644 (file)
--- 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)