[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-60-g05c51bc

[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=05c51bcff5604d520c9335cfbf91eb4bf84003ed

The branch, master has been updated
       via  05c51bcff5604d520c9335cfbf91eb4bf84003ed (commit)
       via  a5c96cb99dc060a254887e2182f01911a4a19d77 (commit)
       via  da7497e0fd5d8a95f3918ec820eab3feeb75237d (commit)
      from  dc327575a8564257d8b84d835d72bc4fe098ba46 (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 -----------------------------------------------------------------
commit 05c51bcff5604d520c9335cfbf91eb4bf84003ed
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 3 20:57:18 2010 +0100

    use anonymous mv-bind in compile-glil.scm; fix abort compilation bug
    
    * module/language/tree-il/compile-glil.scm (flatten): Change to use the
      anonymous <glil-mv-bind> form when truncating to 0 or 1 values. In
      those cases, remove the <glil-unbind> statements. As a side effect,
      fixes compilation of abort in a "values" context.
    
      Thanks to Tristan Colgate for the bug report.
    
    * test-suite/tests/tree-il.test: Update to expect anonymous mv-bind.

commit a5c96cb99dc060a254887e2182f01911a4a19d77
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 3 20:55:42 2010 +0100

    <glil-mv-bind> can truncate values anonymously
    
    * module/language/glil/compile-assembly.scm (glil->assembly): Allow an
      integer for `vars', which means simply to truncate the values, and not
      pass binding metadata to the compiler.

commit da7497e0fd5d8a95f3918ec820eab3feeb75237d
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 3 20:54:05 2010 +0100

    add more tests to control.test
    
    * test-suite/tests/control.test ("restarting partial continuations"):
      Add more tests, for `abort' in different positions. All succeed in the
      evaluator but fail with the compiler.

-----------------------------------------------------------------------

Summary of changes:
 module/language/glil/compile-assembly.scm |   21 +++++++++++-----
 module/language/tree-il/compile-glil.scm  |    8 ++----
 test-suite/tests/control.test             |   36 ++++++++++++++++++++++++++--
 test-suite/tests/tree-il.test             |    6 ++--
 4 files changed, 53 insertions(+), 18 deletions(-)

diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index 47002a8..bfc0a36 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -333,13 +333,20 @@
              arities))
 
     ((<glil-mv-bind> vars rest)
-     (values `((truncate-values ,(length vars) ,(if rest 1 0)))
-             (open-binding bindings vars addr)
-             source-alist
-             label-alist
-             object-alist
-             arities))
-
+     (if (integer? vars)
+         (values `((truncate-values ,vars ,(if rest 1 0)))
+                 bindings
+                 source-alist
+                 label-alist
+                 object-alist
+                 arities)
+         (values `((truncate-values ,(length vars) ,(if rest 1 0)))
+                 (open-binding bindings vars addr)
+                 source-alist
+                 label-alist
+                 object-alist
+                 arities)))
+    
     ((<glil-unbind>)
      (values '()
              (close-binding bindings addr)
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 7030430..197daf2 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -496,8 +496,7 @@
                        (emit-code #f (make-glil-call 'drop 1))
                        (emit-branch #f 'br (or RA POST))
                        (emit-label MV)
-                       (emit-code #f (make-glil-mv-bind '() #f))
-                       (emit-code #f (make-glil-unbind))
+                       (emit-code #f (make-glil-mv-bind 0 #f))
                        (if RA
                            (emit-branch #f 'br RA)
                            (emit-label POST)))))))))
@@ -1124,12 +1123,11 @@
           (emit-code #f (make-glil-call 'return/nvalues 1)))
          ((drop)
           ;; Drop all values and goto RA, or otherwise fall through.
-          (emit-code #f (make-glil-mv-bind '() #f))
-          (emit-code #f (make-glil-unbind))
+          (emit-code #f (make-glil-mv-bind 0 #f))
           (if RA (emit-branch #f 'br RA)))
          ((push)
           ;; Truncate to one value.
-          (emit-code #f (make-glil-mv-bind '(val) #f)))
+          (emit-code #f (make-glil-mv-bind 1 #f)))
          ((vals)
           ;; Go to MVRA.
           (emit-branch #f 'br MVRA)))))))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index d3fd1b3..e17b584 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -19,6 +19,7 @@
 
 (define-module (test-suite test-control)
   #:use-module (ice-9 control)
+  #:use-module (srfi srfi-11)
   #:use-module (test-suite lib))
 
 
@@ -148,14 +149,43 @@
                 (lambda args
                   args))))))
 
-;;; Here we test that instantiation works
+;; The variants check different cases in the compiler.
 (with-test-prefix "restarting partial continuations"
-  (pass-if "simple"
+  (pass-if "in side-effect position"
     (let ((k (% default-tag
                 (begin (abort default-tag) 'foo)
                 (lambda (k) k))))
       (eq? (k)
-           'foo))))
+           'foo)))
+
+  (pass-if "passing values to side-effect abort"
+    (let ((k (% default-tag
+                (begin (abort default-tag) 'foo)
+                (lambda (k) k))))
+      (eq? (k 'qux 'baz 'hello)
+           'foo)))
+
+  (pass-if "called for one value"
+    (let ((k (% default-tag
+                (+ (abort default-tag) 3)
+                (lambda (k) k))))
+      (eqv? (k 39)
+            42)))
+
+  (pass-if "called for multiple values"
+    (let ((k (% default-tag
+                (let-values (((a b . c) (abort default-tag)))
+                  (list a b c))
+                (lambda (k) k))))
+      (equal? (k 1 2 3 4)
+              '(1 2 (3 4)))))
+
+  (pass-if "in tail position"
+    (let ((k (% default-tag
+                (abort default-tag)
+                (lambda (k) k))))
+      (eq? (k 'xyzzy)
+           'xyzzy))))
 
 (define fl (make-fluid))
 (fluid-set! fl 0)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 539540c..a3023f3 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -74,7 +74,7 @@
    (begin (apply (toplevel foo) (const 1)) (void))
    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref 
foo) (const 1) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2)
-            (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
@@ -461,7 +461,7 @@
    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) 
(toplevel ref bar) (mv-call 2 ,l1)
-            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
@@ -480,7 +480,7 @@
    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) 
(void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref call-with-current-continuation) 
(toplevel ref foo) (mv-call 1 ,l1)
-            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))


hooks/post-receive
-- 
GNU Guile