procedures in "drop" contexts can return unspecified values

* module/language/tree-il/compile-glil.scm (flatten): For applications in
  "drop" context, allow the procedure to return unspecified values
  (including 0 values).

* test-suite/tests/tree-il.test ("application"): Adapt test.

* module/srfi/srfi-18.scm (wrap): Clarify.

* test-suite/tests/srfi-18.test: Fix so that the expression importing
  srfi-18 is expanded before the tests. However the tests are still
  failing, something about 0-valued returns...

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 226b7d4..d5073ed 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -272,8 +272,13 @@
            (case context
              ((tail) (emit-code src (make-glil-call 'goto/args len)))
              ((push) (emit-code src (make-glil-call 'call len)))
-             ((drop) (emit-code src (make-glil-call 'call len))
-                     (emit-code src (make-glil-call 'drop 1))))))))
+             ((drop)
+              (let ((MV (make-label)))
+                (emit-code src (make-glil-mv-call len MV))
+                (emit-code #f (make-glil-const 1))
+                (emit-label MV)
+                (emit-code #f (make-glil-mv-bind '() #f))
+                (emit-code #f (make-glil-unbind)))))))))
 
       ((<conditional> src test then else)
        ;;     TEST

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 925ecb3..75f1088 100644 (file)
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -249,8 +249,8 @@
 (define (wrap thunk)
   (lambda (continuation)
     (with-exception-handler (lambda (obj)
-                             (apply (current-exception-handler) (list obj))
-                             (apply continuation (list)))
+                             ((current-exception-handler) obj)
+                             (continuation))
                            thunk)))
 
 ;; A pass-thru to cancel-thread that first installs a handler that throws

diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index fa309e6..3c70906 100644 (file)
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -21,8 +21,13 @@
 (define-module (test-suite test-srfi-18)
   #:use-module (test-suite lib))
 
-(and (provided? 'threads)
-     (use-modules (srfi srfi-18))
+;; two expressions so that the srfi-18 import is in effect for expansion
+;; of the rest
+(if (provided? 'threads)
+    (use-modules (srfi srfi-18)))
+
+(and
+ (provided? 'threads)
 
 (with-test-prefix "current-thread"
 

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 873051f..724ea79 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -68,10 +68,12 @@
   (assert-tree-il->glil
    (apply (toplevel foo) (const 1))
    (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
-  (assert-tree-il->glil
+  (assert-tree-il->glil/pmatch
    (begin (apply (toplevel foo) (const 1)) (void))
-   (program 0 0 0 0 () (toplevel ref foo) (const 1) (call call 1)
-            (call drop 1) (void) (call return 1)))
+   (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+            (const 1) (label ,l2) (mv-bind () #f) (unbind)
+            (void) (call return 1))
+   (eq? l1 l2))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel bar)))
    (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)