more work towards compiling and interpreting keyword args

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bumparoo
* libguile/vm-i-system.c (push-rest, bind-rest): Logically there are
  actually two rest binders -- one that pops, conses, and pushes, and
  one that pops, conses, and local-sets. The latter is used on keyword
  arguments, because the keyword arguments themselves have been shuffled
  up on the stack. Renumber ops again.

* module/language/tree-il/compile-glil.scm (flatten): Attempt to handle
  compilation of lambda-case with keyword arguments. Might need some
  help.

* module/ice-9/psyntax.scm (build-lambda-case): An attempt to handle the
  interpreted case correctly. This might need a couple iterations, but
  at least it looks like the compile-glil code.

* module/ice-9/psyntax-pp.scm: Regenerated.

* module/language/glil.scm (<glil>): Rename "rest?" to "rest" in
  <glil-opt-prelude> and <glil-kw-prelude>, as it is no longer a simple
  boolean, but if true is an integer: the index of the local variable to
  which the rest should be bound.

* module/language/glil/compile-assembly.scm (glil->assembly): Adapt to
  "rest" vs "rest?". In the keyword case, use "bind-rest" instead of
  "push-rest".

* test-suite/tests/tree-il.test: Update for opt-prelude change.

module/ice-9/psyntax.scm

@@ -482,26 +482,64 @@
              src)))))
 
 (define build-lambda-case
-  ;; kw: ((keyword var init) ...)
+  ;; req := (name ...)
+  ;; opt := ((name init) ...) | #f
+  ;; rest := name | #f
+  ;; kw: (allow-other-keys? (keyword name var [init]) ...) | #f
+  ;; vars: (sym ...)
+  ;; vars map to named arguments in the following order:
+  ;;  required, optional (positional), rest, keyword.
+  ;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded
+  ;; the body of a lambda: anything, already expanded
+  ;; else: lambda-case | #f
   (lambda (src req opt rest kw vars predicate body else-case)
     (case (fluid-ref *mode*)
       ((c)
        ((@ (language tree-il) make-lambda-case)
         src req opt rest kw vars predicate body else-case))
       (else
-       (let ((nkw (map (lambda (x)
-                         `(list ,(car x)
-                                ;; grr
-                                ,(let lp ((vars vars) (i 0))
-                                   (cond ((null? vars) (error "bad kwarg" x))
-                                         ((eq? (cadr x) (car vars)) i)
-                                         (else (lp (cdr vars) (1+ i)))))
-                                (lambda () ,(caddr x))))
-                       kw)))
+       ;; Very much like the logic of (language tree-il compile-glil).
+       (let* ((nreq (length req))
+              (nopt (if opt (length opt) 0))
+              (rest-idx (and rest (+ nreq nopt)))
+              (opt-inits (map (lambda (x) `(lambda ,vars ,(cdr x)))
+                              (or opt '())))
+              (allow-other-keys? (if kw (car kw) #f))
+              (kw-indices (map (lambda (x)
+                                 ;; (,key ,name ,var . _)
+                                 (cons (car x) (list-index vars (caddr x))))
+                               (if kw (cdr kw) '())))
+              (kw-inits (sort
+                         (filter
+                          identity
+                          (map (lambda (x)
+                                 (if (pair? (cdddr x))
+                                     ;; (,key ,name ,var ,init)
+                                     (let ((i (list-index vars (caddr x))))
+                                       (if (> (+ nreq nopt) i)
+                                           (error "kw init for rest arg" x)
+                                           (if (and rest (= (+ nreq nopt) i))
+                                               (error "kw init for positional arg" x)
+                                               `(lambda ,vars ,(cadddr x)))))
+                                     ;; (,key ,name ,var)
+                                     (let ((i (list-index vars (caddr x))))
+                                       (if (< (+ nreq nopt) i)
+                                           #f
+                                           (error "missing init for kw arg" x)))))
+                               (if kw (cdr kw) '())))
+                         (lambda (x y) (< (cdr x) (cdr y)))))
+              (nargs (apply max (pk (+ nreq nopt (if rest 1 0)))
+                            (map cdr kw-indices))))
+         (or (= nargs
+                (length vars)
+                (+ nreq (length opt-inits) (if rest 1 0) (length kw-inits)))
+             (error "something went wrong"
+                    req opt rest kw vars nreq nopt kw-indices kw-inits nargs))
          (decorate-source
           `((((@@ (ice-9 optargs) parse-lambda-case)
-              (list ,(length req) ,(length opt) ,(and rest #t) ,nkw
-                    ,(if predicate (error "not yet implemented") #f))
+              '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+              (list ,@opt-inits ,@kw-inits)
+              ,(if predicate `(lambda ,vars ,predicate) #f)
               %%args)
              => (lambda ,vars ,body))
             ,@(or else-case

module/language/glil.scm

@@ -30,12 +30,12 @@
    glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
 
    <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
-   glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest?
+   glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
    glil-opt-prelude-nlocs glil-opt-prelude-else-label
 
    <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
    glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
-   glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest?
+   glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
    glil-kw-prelude-nlocs glil-kw-prelude-else-label
 
    <glil-bind> make-glil-bind glil-bind?
@@ -84,8 +84,8 @@
   ;; Meta operations
   (<glil-program> meta body)
   (<glil-std-prelude> nreq nlocs else-label)
-  (<glil-opt-prelude> nreq nopt rest? nlocs else-label)
-  (<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
+  (<glil-opt-prelude> nreq nopt rest nlocs else-label)
+  (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)
@@ -111,10 +111,10 @@
      (make-glil-program meta (map parse-glil body)))
     ((std-prelude ,nreq ,nlocs ,else-label)
      (make-glil-std-prelude nreq nlocs else-label))
-    ((opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label)
-     (make-glil-opt-prelude nreq nopt rest? nlocs else-label))
-    ((kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label)
-     (make-glil-kw-prelude nreq nopt rest? kw allow-other-keys? nlocs else-label))
+    ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
+     (make-glil-opt-prelude nreq nopt rest nlocs else-label))
+    ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
+     (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
     ((bind . ,vars) (make-glil-bind vars))
     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
     ((unbind) (make-glil-unbind))
@@ -138,10 +138,10 @@
      `(program ,meta ,@(map unparse-glil body)))
     ((<glil-std-prelude> nreq nlocs else-label)
      `(std-prelude ,nreq ,nlocs ,else-label))
-    ((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
-     `(opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label))
-    ((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
-     `(kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label))
+    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+     `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
+    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+     `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
     ((<glil-bind> vars) `(bind ,@vars))
     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
     ((<glil-unbind>) `(unbind))

module/language/glil/compile-assembly.scm

@@ -134,12 +134,12 @@
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
-;; arities := ((ip nreq [[nopt] [[rest?] [kw]]]]) ...)
-(define (begin-arity addr nreq nopt rest? kw arities)
+;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
+(define (begin-arity addr nreq nopt rest kw arities)
   (cons
    (cond
-    (kw (list addr nreq nopt rest? kw))
-    (rest? (list addr nreq nopt rest?))
+    (kw (list addr nreq nopt rest kw))
+    (rest (list addr nreq nopt rest))
     (nopt (list addr nreq nopt))
     (nreq (list addr nreq))
     (else (list addr)))
@@ -151,9 +151,9 @@
     (values x bindings source-alist label-alist object-alist arities))
   (define (emit-code/object x object-alist)
     (values x bindings source-alist label-alist object-alist arities))
-  (define (emit-code/arity x nreq nopt rest? kw)
+  (define (emit-code/arity x nreq nopt rest kw)
     (values x bindings source-alist label-alist object-alist
-            (begin-arity (addr+ addr x) nreq nopt rest? kw arities)))
+            (begin-arity (addr+ addr x) nreq nopt rest kw arities)))
   
   (record-case glil
     ((<glil-program> meta body)
@@ -230,7 +230,7 @@
                         ,(modulo nlocs 256)))
       nreq #f #f #f))
 
-    ((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
+    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
      (let ((bind-required
             (if else-label
                 `((br-if-nargs-lt ,(quotient nreq 256)
@@ -245,8 +245,8 @@
                                   ,(modulo (+ nreq nopt) 256)))))
            (bind-rest
             (cond
-             (rest?
-              `((bind-rest ,(quotient (+ nreq nopt) 256)
+             (rest
+              `((push-rest ,(quotient (+ nreq nopt) 256)
                            ,(modulo (+ nreq nopt) 256))))
              (else
               (if else-label
@@ -261,9 +261,9 @@
           ,@bind-rest
           (reserve-locals ,(quotient nlocs 256)
                           ,(modulo nlocs 256)))
-        nreq nopt rest? #f)))
+        nreq nopt rest #f)))
     
-    ((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
+    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
      (receive (kw-idx object-alist)
          (object-index-and-alist object-alist kw)
        (let ((bind-required
@@ -293,9 +293,11 @@
                  ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
                  ,(if allow-other-keys? 1 0))))
              (bind-rest
-              (if rest?
+              (if rest
                   `((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
-                               ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)))
+                               ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
+                               ,(quotient rest 256)
+                               ,(modulo rest 256)))
                   '())))
          
          (let ((code `(,@bind-required
@@ -305,7 +307,7 @@
                        (reserve-locals ,(quotient nlocs 256)
                                        ,(modulo nlocs 256)))))
            (values code bindings source-alist label-alist object-alist
-                   (begin-arity (addr+ addr code) nreq nopt rest? kw arities))))))
+                   (begin-arity (addr+ addr code) nreq nopt rest kw arities))))))
     
     ((<glil-bind> vars)
      (values '()

module/language/tree-il/compile-glil.scm

@@ -600,32 +600,65 @@
        (maybe-emit-return))
       
       ((<lambda-case> src req opt rest kw vars predicate else body)
-       (let ((nlocs (cdr (hashq-ref allocation x)))
-             (else-label (and else (make-label))))
+       ;; o/~ feature on top of feature o/~
+       ;; req := (name ...)
+       ;; opt := ((name init) ...) | #f
+       ;; rest := name | #f
+       ;; kw: (allow-other-keys? (keyword name var [init]) ...) | #f
+       ;; vars: (sym ...)
+       ;; predicate: tree-il in context of vars
+       ;; init: tree-il in context of vars
+       ;; vars map to named arguments in the following order:
+       ;;  required, optional (positional), rest, keyword.
+       (let* ((nreq (length req))
+              (nopt (if opt (length opt) 0))
+              (rest-idx (and rest (+ nreq nopt)))
+              (opt-inits (map cdr (or opt '())))
+              (allow-other-keys? (if kw (car kw) #f))
+              (kw-indices (map (lambda (x)
+                                 (pmatch x
+                                   ((,key ,name ,var . _)
+                                    (cons key (list-index vars var)))
+                                   (else (error "bad kwarg" x))))
+                               (if kw (cdr kw) '())))
+              (kw-inits (filter
+                         identity
+                         (map (lambda (x)
+                                (pmatch x
+                                  ((,key ,name ,var ,init)
+                                   (let ((i (list-index vars var)))
+                                     (if (> (+ nreq nopt) i)
+                                         (error "kw init for rest arg" x)
+                                         (if (and rest (= rest-idx i))
+                                             (error "kw init for positional arg" x)
+                                             (cons i init)))))
+                                  ((,key ,name ,var)
+                                   (let ((i (list-index vars var)))
+                                     (if (< (+ nreq nopt) i)
+                                         #f
+                                         (error "missing init for kw arg" x))))
+                                  (else (error "bad kwarg" x))))
+                              (if kw (cdr kw) '()))))
+              (nargs (apply max (+ nreq nopt (if rest 1 0)) (map cdr kw-indices)))
+              (nlocs (cdr (hashq-ref allocation x)))
+              (else-label (and else (make-label))))
+         (or (= nargs
+                (length vars)
+                (+ nreq (length opt-inits) (if rest 1 0) (length kw-inits)))
+             (error "something went wrong"
+                    req opt rest kw vars nreq nopt kw-indices kw-inits nargs))
          ;; the prelude, to check args & reset the stack pointer,
          ;; allowing room for locals
          (emit-code
           src
           (cond
-           ;; kw := (allow-other-keys? (#:key name var) ...)
            (kw
-            (make-glil-kw-prelude
-             (length req) (length (or opt '())) (and rest #t)
-             (map (lambda (x)
-                    (pmatch x
-                      ((,key ,name ,var)
-                       (cons key
-                             (pmatch (hashq-ref (hashq-ref allocation var) self)
-                               ((#t ,boxed . ,n) n)
-                               (,a (error "bad keyword allocation" x a)))))
-                      (,x (error "bad keyword" x))))
-                  (cdr kw))
-             (car kw) nlocs else-label))
+            (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+                                  allow-other-keys? nlocs else-label))
            ((or rest opt)
-            (make-glil-opt-prelude
-             (length req) (length (or opt '())) (and rest #t) nlocs else-label))
+            (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
            (#t
-            (make-glil-std-prelude (length req) nlocs else-label))))
+            (make-glil-std-prelude nreq nlocs else-label))))
          ;; box args if necessary
          (for-each
           (lambda (v)
@@ -641,11 +674,12 @@
               (let lp ((kw (if kw (cdr kw) '()))
                        (names (append (if opt (reverse opt) '())
                                       (reverse req)))
-                       (vars (list-tail vars (+ (length req)
-                                                (if opt (length opt) 0)
+                       (vars (list-tail vars (+ nreq nopt
                                                 (if rest 1 0)))))
                 (pmatch kw
-                  (() (reverse (if rest (cons rest names) names)))
+                  (()
+                   ;; fixme: check that vars is empty
+                   (reverse (if rest (cons rest names) names)))
                   (((,key ,name ,var) . ,kw)
                    (if (memq var vars)
                        (lp kw (cons name names) (delq var vars))