fix apply and call/cc in drop contexts

* module/language/tree-il/compile-glil.scm (flatten): Actually apply only
  needs one arg after the proc. And shit, call/cc and apply in drop
  contexts also need to be able to return arbitrary numbers of values;
  work it by trampolining through their applicative (non-@) definitions.
  Also, simplify the single-valued drop case to avoid the
  truncate-values.

* module/language/tree-il/inline.scm (call/cc):
* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
  Define call/cc as "interesting". Perhaps we should be hashing on value
  and not on variable.

* test-suite/tests/tree-il.test ("application"): Fix up test for new,
  sleeker output. (Actually the GLIL is more verbose, but the assembly is
  better.)
  ("apply", "call/cc"): Add some more tests.

1 files changed, 44 insertions, 2 deletions

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 724ea7960..eb33ae77f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -71,9 +71,11 @@
   (assert-tree-il->glil/pmatch
    (begin (apply (toplevel foo) (const 1)) (void))
    (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
-            (const 1) (label ,l2) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2)
+            (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l4)
             (void) (call return 1))
-   (eq? l1 l2))
+   (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel bar)))
    (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
@@ -415,3 +417,43 @@
             (unbind)
             (unbind))
    (eq? l1 l2)))
+
+(with-test-prefix "apply"
+  (assert-tree-il->glil
+   (apply (primitive @apply) (toplevel foo) (toplevel bar))
+   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+  (assert-tree-il->glil/pmatch
+   (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+   (program 0 0 0 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)
+            (label ,l4)
+            (void) (call return 1))
+   (and (eq? l1 l3) (eq? l2 l4)))
+  (assert-tree-il->glil
+   (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
+   (program 0 0 0 0 ()
+            (toplevel ref foo)
+            (toplevel ref bar) (toplevel ref baz) (call apply 2)
+            (call goto/args 1))))
+
+(with-test-prefix "call/cc"
+  (assert-tree-il->glil
+   (apply (primitive @call-with-current-continuation) (toplevel foo))
+   (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+  (assert-tree-il->glil/pmatch
+   (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
+   (program 0 0 0 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)
+            (label ,l4)
+            (void) (call return 1))
+   (and (eq? l1 l3) (eq? l2 l4)))
+  (assert-tree-il->glil
+   (apply (toplevel foo)
+          (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+   (program 0 0 0 0 ()
+            (toplevel ref foo)
+            (toplevel ref bar) (call call/cc 1)
+            (call goto/args 1))))
+