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

4 files changed, 21 insertions, 9 deletions

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 226b7d402..d5073ed0f 100644
--- 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 925ecb304..75f1088ab 100644
--- 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 fa309e6ce..3c7090643 100644
--- 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 873051f03..724ea7960 100644
--- 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)