Implement multiple return values.

1 files changed, 55 insertions, 33 deletions

diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc
index 1b8df9d..4242681 100644
--- a/lib/csc/cps.csc
+++ b/lib/csc/cps.csc
@@ -98,6 +98,30 @@
       (continuation update-continuation))
 
 
+    (define-syntax singleton-continuation
+      (syntax-rules ()
+        ((singleton-continuation (val) body ...)
+          (lambda (x multi)
+            (define (b val) body ...)
+            (if multi
+              (let ((v (new-ref)))
+                (make-primitive 'assert-singleton (list x) (list v)
+                  (b v)))
+              (b x))))))
+
+
+    (define-syntax varargs-continuation
+      (syntax-rules ()
+        ((varargs-continuation (vals) body ...)
+          (lambda (x multi)
+            (define (b vals) body ...)
+            (if multi
+              (b x)
+              (let ((l (new-ref)))
+                (make-primitive 'cons (list x (make-constant '())) (list l)
+                  (b l))))))))
+
+
     (define (collect-functions-and-variables expr)
       (let ((names (letrec-names expr))
             (gensyms (letrec-gensyms expr))
@@ -114,7 +138,7 @@
                               (list continuation args)
                               (to-cps
                                 body
-                                (lambda (z)
+                                (varargs-continuation (z)
                                   (make-apply continuation (list z)))))))
                         into functions
               else
@@ -130,58 +154,56 @@
       (match expr
         (_ when (or (constant? expr)
                     (lexical-ref? expr))
-          (continuation expr))
+          (continuation expr #f))
         ((% %library-ref . _)
-          (unless (library-ref? expr)
-            (error "wtf"))
           (define temp (new-ref))
           (make-primitive 'peek (list *globals* expr) (list temp)
-            (continuation temp)))
+            (continuation temp #f)))
         ((% %lexical-set ref arg)
           (to-cps
             arg
-            (lambda (val)
-              (make-update ref val (continuation (make-constant #f))))))
+            (singleton-continuation (val)
+              (make-update ref val (continuation (make-constant #f) #f)))))
         ((% %library-define ref arg)
           (to-cps
             arg
-            (lambda (val)
-              (make-update ref val (continuation (make-constant #f))))))
+            (singleton-continuation (val)
+              (make-update ref val (continuation (make-constant #f) #f)))))
         ((% %define-syntax _ _)
           ; no-op
-          (continuation (make-constant #f)))
+          (continuation (make-constant #f) #f))
         ((% %if test consequent alternate)
           (to-cps
             test
-            (lambda (val)
+            (singleton-continuation (val)
               (define continuation-ref (new-ref))
               (define result-ref (new-ref))
               (make-fix
                 (list (make-closure continuation-ref (list result-ref)
-                        (continuation result-ref)))
+                        (continuation result-ref #t)))
                 (make-branch val
                   (to-cps
                     consequent
-                    (lambda (result)
+                    (varargs-continuation (result)
                       (make-apply continuation-ref (list result))))
                   (to-cps
                     alternate
-                    (lambda (result)
+                    (varargs-continuation (result)
                       (make-apply continuation-ref (list result)))))))))
         ((% %call proc args)
           (define return-address (new-ref))
           (define result (new-ref))
           (make-fix
-            (list (make-closure return-address (list result) (continuation result)))
+            (list (make-closure return-address (list result) (continuation result #t)))
             (to-cps
               proc
-              (lambda (f)
+              (singleton-continuation (f)
                 (to-cps
                   (loop for arg in (reverse args)
                         with arglist = (make-constant '())
                         do (set! arglist (make-call-builtin 'cons (list arg arglist)))
                         finally (return arglist))
-                  (lambda (v)
+                  (singleton-continuation (v)
                     (make-apply f (list return-address v))))))))
         ((% %call-builtin 'call-with-current-continuation (proc))
           (define return-address (new-ref))
@@ -191,12 +213,12 @@
           (define arglist (new-ref))
           (make-fix
             (list (make-closure return-address (list result1)
-                    (continuation result1))
-                  (make-closure current-continuation (list k-unused result2)
+                    (continuation result1 #t))
+                  (make-closure current-continuation (list (new-ref) result2)
                     (make-apply return-address (list result2))))
             (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist)
               (to-cps proc
-                (lambda (f)
+                (singleton-continuation (f)
                   (make-apply f (list return-address arglist)))))))
         ((% %call-builtin 'call-with-values (producer consumer))
           (define return-address (new-ref))
@@ -205,25 +227,25 @@
           (define results (new-ref))
           (make-fix
             (list (make-closure return-address (list result)
-                    (continuation result))
+                    (continuation result #t))
                   (make-closure consumer-func (list results)
                     (to-cps consumer
-                      (lambda (c)
+                      (singleton-continuation (c)
                         (make-apply c (list return-address results))))))
             (to-cps producer
-              (lambda (p)
+              (singleton-continuation (p)
                 (make-apply p (list consumer-func (make-constant '())))))))
         ((% %call-builtin 'apply (proc args))
           (define return-address (new-ref))
           (define result (new-ref))
           (make-fix
-            (list (make-closure return-address (list result) (continuation result)))
+            (list (make-closure return-address (list result) (continuation result #t)))
             (to-cps
               proc
-              (lambda (f)
+              (singleton-continuation (f)
                 (to-cps
                   args
-                  (lambda (l)
+                  (singleton-continuation (l)
                     (make-apply f (list return-address l))))))))
         ((% %call-builtin op args)
           (define returns-value? (not (memq op '(poke exit))))
@@ -232,20 +254,20 @@
                               (if returns-value?
                                 (let ((result (new-ref)))
                                   (make-primitive op (reverse vals) (list result)
-                                    (continuation result)))
+                                    (continuation result #f)))
                                 (make-primitive op (reverse vals) '()
-                                  (continuation (make-constant #f)))))
+                                  (continuation (make-constant #f) #f))))
                 do (set! expr (let ((e* expr)  ; make copies to avoid modifying the expr in the closure.
                                     (arg* arg))
                                 (lambda (vals)
                                   (to-cps arg*
-                                    (lambda (val)
+                                    (singleton-continuation (val)
                                       (e* (cons val vals)))))))
                 finally (return (expr '()))))
         ((% %sequence head tail)
           (to-cps
             head
-            (lambda (x)
+            (lambda (x multi)
               (to-cps
                 tail
                 continuation))))
@@ -257,9 +279,9 @@
               (make-closure f (list k args)
                 (to-cps
                   body
-                  (lambda (ret)
+                  (varargs-continuation (ret)
                     (make-apply k (list ret))))))
-            (continuation f)))
+            (continuation f #f)))
         ((% %letrec _ _ _ _ body)
           (define-values (functions variable-names variable-values) (collect-functions-and-variables expr))
           (if (null? variable-names)
@@ -268,7 +290,7 @@
             (let ((new-expr (loop for var in (reverse variable-names)
                                   for val in (reverse variable-values)
                                   with new-body = (to-cps body continuation)
-                                  do (set! new-body (to-cps val (lambda (x)
+                                  do (set! new-body (to-cps val (singleton-continuation (x)
                                                                   (make-update var x
                                                                     new-body))))
                                   finally (return new-body))))