[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-180-g9582b26

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9582b26c62b7c64f08cfda9362d6e3a970936d2c

The branch, master has been updated
       via  9582b26c62b7c64f08cfda9362d6e3a970936d2c (commit)
       via  ed3fd27adb35f80da9ac37076d16848c4cebdbd1 (commit)
       via  84b67e1971c3d2dc7e7626f556f6c5e548e948fd (commit)
       via  3b24aee6e3997c144ec2d1d763c9805a2261768f (commit)
      from  3df539b1a5535009d8522b997e2542496cfb06fb (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/compile-glil.scm |   69 ++++++++++++++++--------------
 module/rnrs/control.scm                  |    3 +-
 test-suite/tests/optargs.test            |   19 ++++++++-
 3 files changed, 56 insertions(+), 35 deletions(-)

diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index b588802..23648cd 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -126,6 +126,8 @@
 
    ;; hack for javascript
    ((return . 1) . return)
+   ;; hack for lua
+   (return/values . return/values)
 
    ((bytevector-u8-ref . 2) . bv-u8-ref)
    ((bytevector-u8-set! . 3) . bv-u8-set)
@@ -178,7 +180,7 @@
          (pmatch (hashq-ref (hashq-ref allocation v) proc)
            ((#t ,boxed? . ,n)
             (list id boxed? n))
-           (,x (error "badness" id v x))))
+           (,x (error "bad var list element" id v x))))
        ids
        vars))
 
@@ -204,10 +206,6 @@
        (lambda (emit-code)
          ;; write source info for proc
          (if src (emit-code #f (make-glil-source src)))
-         ;; emit pre-prelude label for self tail calls in which the
-         ;; number of arguments doesn't check out at compile time
-         (if self-label
-             (emit-code #f (make-glil-label self-label)))
          ;; compile the body, yo
          (flatten body allocation x self-label (car (hashq-ref allocation x))
                   emit-code)))))))
@@ -415,6 +413,11 @@
                  (case context
                    ((drop) (emit-code #f (make-glil-call 'drop 1))))
                  (maybe-emit-return))
+                ((-1)
+                 ;; A control instruction, like return/values.  Here we
+                 ;; just have to hope that the author of the tree-il
+                 ;; knew what they were doing.
+                 *unspecified*)
                 (else
                  (error "bad primitive op: too many pushes"
                         op (instruction-pushes op))))))
@@ -423,17 +426,17 @@
         ((and (lexical-ref? proc)
               self-label (eq? (lexical-ref-gensym proc) self-label)
               (eq? context 'tail))
-         ;; first, evaluate new values, pushing them on the stack
-         (for-each comp-push args)
          (let lp ((lcase (lambda-body self)))
            (cond
             ((and (lambda-case? lcase)
                   (not (lambda-case-kw lcase))
-                  (not (lambda-case-opt lcase))
                   (not (lambda-case-rest lcase))
-                  (= (length args) (length (lambda-case-req lcase))))
-             ;; we have a case that matches the args; rename variables
-             ;; and goto the case label
+                  (= (length args)
+                     (+ (length (lambda-case-req lcase))
+                        (or (and=> (lambda-case-opt lcase) length) 0))))
+             ;; we have a case that matches the args; evaluate new
+             ;; values, rename variables and goto the case label
+             (for-each comp-push args)
              (for-each (lambda (sym)
                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
                            ((#t #f . ,index) ; unboxed
@@ -441,18 +444,19 @@
                            ((#t #t . ,index) ; boxed
                             ;; new box
                             (emit-code #f (make-glil-lexical #t #t 'box 
index)))
-                           (,x (error "what" x))))
+                           (,x (error "bad lambda-case arg allocation" x))))
                        (reverse (lambda-case-gensyms lcase)))
              (emit-branch src 'br (car (hashq-ref allocation lcase))))
             ((lambda-case? lcase)
              ;; no match, try next case
              (lp (lambda-case-alternate lcase)))
             (else
-             ;; no cases left; shuffle args down and jump before the prelude.
-             (for-each (lambda (i)
-                         (emit-code #f (make-glil-lexical #t #f 'set i)))
-                       (reverse (iota (length args))))
-             (emit-branch src 'br self-label)))))
+             ;; no cases left -- use the normal tail call mechanism. we
+             ;; can't just shuffle the args down and jump back to the
+             ;; self label, because we don't have space.
+             (comp-push proc)
+             (for-each comp-push args)
+             (emit-code src (make-glil-call 'tail-call (length args)))))))
         
         ;; lambda, the ultimate goto
         ((and (lexical-ref? proc)
@@ -478,7 +482,7 @@
                             (emit-code #f (make-glil-lexical #t #f 'set 
index)))
                            ((#t #t . ,index) ; boxed
                             (emit-code #f (make-glil-lexical #t #t 'box 
index)))
-                           (,x (error "what" x))))
+                           (,x (error "bad lambda-case arg allocation" x))))
                        (reverse (lambda-case-gensyms lcase)))
              (emit-branch src 'br (car (hashq-ref allocation lcase))))
             ((lambda-case? lcase)
@@ -614,7 +618,7 @@
             ((,local? ,boxed? . ,index)
              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
             (,loc
-             (error "badness" x loc)))))
+             (error "bad lexical allocation" x loc)))))
        (maybe-emit-return))
       
       ((<lexical-set> src gensym exp)
@@ -623,7 +627,7 @@
          ((,local? ,boxed? . ,index)
           (emit-code src (make-glil-lexical local? boxed? 'set index)))
          (,loc
-          (error "badness" x loc)))
+          (error "bad lexical allocation" x loc)))
        (case context
          ((tail push vals)
           (emit-code #f (make-glil-void))))
@@ -677,7 +681,7 @@
                      (pmatch loc
                        ((,local? ,boxed? . ,n)
                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
-                       (else (error "what" x loc))))
+                       (else (error "bad lambda free var allocation" x loc))))
                    free-locs)
                   (emit-code #f (make-glil-call 'make-closure
                                                 (length free-locs))))))))
@@ -711,7 +715,7 @@
          (or (= nargs
                 (length gensyms)
                 (+ nreq (length inits) (if rest 1 0)))
-             (error "something went wrong"
+             (error "lambda-case gensyms don't correspond to args"
                     req opt rest kw inits gensyms nreq nopt kw-indices nargs))
          ;; the prelude, to check args & reset the stack pointer,
          ;; allowing room for locals
@@ -767,7 +771,7 @@
                   (emit-code #f (make-glil-lexical #t boxed? 'set n))
                   (emit-label L)
                   (lp (cdr inits) (1+ n) (cdr gensyms))))
-               (#t (error "what" inits))))))
+               (#t (error "bad arg allocation" (car gensyms) inits))))))
          ;; post-prelude case label for label calls
          (emit-label (car (hashq-ref allocation x)))
          (comp-tail body)
@@ -787,7 +791,7 @@
                       (emit-code src (make-glil-lexical #t #f 'set n)))
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'box n)))
-                     (,loc (error "badness" x loc))))
+                     (,loc (error "bad let var allocation" x loc))))
                  (reverse gensyms))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
@@ -798,7 +802,7 @@
                    (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
-                     (,loc (error "badness" x loc))))
+                     (,loc (error "bad letrec var allocation" x loc))))
                  gensyms)
        ;; Even though the slots are empty, the bindings are valid.
        (emit-bindings src names gensyms allocation self emit-code)
@@ -810,7 +814,7 @@
                        ((#t #t . ,n)
                         (comp-push val)
                         (emit-code src (make-glil-lexical #t #t 'set n)))
-                       (,loc (error "badness" x loc))))
+                       (,loc (error "bad letrec var allocation" x loc))))
                    names gensyms vals))
         (else
          ;; But for letrec, eval all values, then bind.
@@ -819,7 +823,7 @@
                      (pmatch (hashq-ref (hashq-ref allocation v) self)
                        ((#t #t . ,n)
                         (emit-code src (make-glil-lexical #t #t 'set n)))
-                       (,loc (error "badness" x loc))))
+                       (,loc (error "bad letrec var allocation" x loc))))
                    (reverse gensyms))))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
@@ -855,7 +859,7 @@
               (pmatch (hashq-ref (hashq-ref allocation v) self)
                 ((#t #f . ,n)
                  (emit-code src (make-glil-lexical #t #f 'set n)))
-                (,loc (error "badness" x loc))))
+                (,loc (error "bad fix var allocation" x loc))))
              (else
               ;; labels allocation: emit label & body, but jump over it
               (let ((POST (make-label)))
@@ -899,12 +903,12 @@
                        (pmatch loc
                          ((,local? ,boxed? . ,n)
                           (emit-code #f (make-glil-lexical local? #f 'ref n)))
-                         (else (error "what" x loc))))
+                         (else (error "bad free var allocation" x loc))))
                      free-locs)
                     (pmatch (hashq-ref (hashq-ref allocation v) self)
                       ((#t #f . ,n)
                        (emit-code #f (make-glil-lexical #t #f 'fix n)))
-                      (,loc (error "badness" x loc)))))))
+                      (,loc (error "bad fix var allocation" x loc)))))))
           vals
           gensyms)
          (comp-tail body)
@@ -932,7 +936,7 @@
                            (emit-code src (make-glil-lexical #t #f 'set n)))
                           ((#t #t . ,n)
                            (emit-code src (make-glil-lexical #t #t 'box n)))
-                          (,loc (error "badness" x loc))))
+                          (,loc (error "bad let-values var allocation" x 
loc))))
                       (reverse gensyms))
             (comp-tail body)
             (emit-code #f (make-glil-unbind))))))
@@ -1128,7 +1132,8 @@
                            (emit-code src (make-glil-lexical #t #f 'set n)))
                           ((#t #t . ,n)
                            (emit-code src (make-glil-lexical #t #t 'box n)))
-                          (,loc (error "badness" x loc))))
+                          (,loc
+                           (error "bad prompt handler arg allocation" x loc))))
                       (reverse gensyms))
             (comp-tail body)
             (emit-code #f (make-glil-unbind))))
diff --git a/module/rnrs/control.scm b/module/rnrs/control.scm
index 69351c6..b81c133 100644
--- a/module/rnrs/control.scm
+++ b/module/rnrs/control.scm
@@ -19,8 +19,7 @@
 
 (library (rnrs control (6))
   (export when unless do case-lambda)
-  (import (rnrs base (6))
-          (only (guile) do case-lambda))
+  (import (only (guile) if not begin define-syntax syntax-rules do 
case-lambda))
 
   (define-syntax when
     (syntax-rules ()
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 4a0e93a..a1e62bd 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -184,7 +184,24 @@
   (pass-if "testing qux"
     (and (equal? (qux) 13)
          (equal? (qux 1) 1)
-         (equal? (qux #:a 2) 2))))
+         (equal? (qux #:a 2) 2)))
+  (pass-if "nested lambda* with optional"
+    (begin
+      (define (foo x)
+        (define baz x)
+        (define* (bar #:optional (y baz))
+          (or (zero? y) (bar (1- y))))
+        (bar))
+      (foo 10)))
+  (pass-if "nested lambda* with key"
+    (begin
+      (define (foo x)
+        (define baz x)
+        (define* (bar #:key (y baz))
+          (or (zero? y) (bar #:y (1- y))))
+        (bar))
+      (foo 10))))
+
 
 (with-test-prefix/c&e "defmacro*"
   (pass-if "definition"


hooks/post-receive
-- 
GNU Guile