Implement multiple return values.

5 files changed, 120 insertions, 82 deletions

diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc
index 8bef0aa..256e9e3 100644
--- a/lib/csc/cps-test.csc
+++ b/lib/csc/cps-test.csc
@@ -74,10 +74,13 @@
       (make-lexical-ref name (gensym)))
 
 
-    (define (tail x)
+    (define (tail x multi)
       (make-apply (test-ref 'tail) (list x)))
 
 
+    (define generated-symbol (test-ref 'generated-symbol))
+
+
     (test atom-const
       (assert-equal
         (make-apply (test-ref 'tail) (list (make-constant 5)))
@@ -94,8 +97,8 @@
 
     (test atom-library-ref
       (assert-equal
-        (make-primitive 'peek (list *globals* (make-library-ref 'var '(csc builtins))) (list (test-ref 'generated-symbol))
-          (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
+        (make-primitive 'peek (list *globals* (make-library-ref 'var '(csc builtins))) (list generated-symbol)
+          (make-apply (test-ref 'tail) (list generated-symbol)))
         (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)
         transform-ir2))
 
@@ -121,11 +124,13 @@
       (assert-equal
         (make-fix
           (list
-            (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
-              (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
+            (make-closure generated-symbol (list generated-symbol)
+              (make-apply (test-ref 'tail) (list generated-symbol))))
           (make-branch (make-constant #t)
-            (make-apply (test-ref 'generated-symbol) (list (make-constant 1)))
-            (make-apply (test-ref 'generated-symbol) (list (make-constant 2)))))
+            (make-primitive 'cons (list (make-constant 1) (make-constant '())) (list generated-symbol)
+              (make-apply generated-symbol (list generated-symbol)))
+            (make-primitive 'cons (list (make-constant 2) (make-constant '())) (list generated-symbol)
+              (make-apply generated-symbol (list generated-symbol)))))
         (ir1->ir2 (make-if (make-constant #t)
                     (make-constant 1)
                     (make-constant 2))
@@ -137,11 +142,11 @@
       (assert-equal
         (make-fix
           (list
-            (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
-              (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
-          (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list (test-ref 'generated-symbol))
-            (make-primitive 'cons (list (make-constant 10) (test-ref 'generated-symbol)) (list (test-ref 'generated-symbol))
-              (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
+            (make-closure generated-symbol (list generated-symbol)
+              (make-apply (test-ref 'tail) (list generated-symbol))))
+          (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list generated-symbol)
+            (make-primitive 'cons (list (make-constant 10) generated-symbol) (list generated-symbol)
+              (make-apply (test-ref 'f) (list generated-symbol generated-symbol)))))
         (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20)))
                   tail)
         transform-ir2))
@@ -149,17 +154,17 @@
 
     (test call-builtin-alloc
       (assert-equal
-        (make-primitive 'alloc (list (make-constant 10)) (list (test-ref 'generated-symbol))
-          (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
+        (make-primitive 'alloc (list (make-constant 10)) (list generated-symbol)
+          (make-apply (test-ref 'tail) (list generated-symbol)))
         (ir1->ir2 (make-call-builtin 'alloc (list (make-constant 10))) tail)
         transform-ir2))
 
 
     (test call-builtin-peek
       (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol))
-          (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
-            (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
+        (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol)
+          (make-primitive 'peek (list generated-symbol (make-constant 0)) (list generated-symbol)
+            (make-apply (test-ref 'tail) (list generated-symbol))))
         (ir1->ir2
           (make-call-builtin 'peek (list (make-call-builtin 'alloc (list (make-constant 1))) (make-constant 0)))
           tail)
@@ -168,8 +173,8 @@
 
     (test call-builtin-poke
       (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol))
-          (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 0)) '()
+        (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol)
+          (make-primitive 'poke (list (make-constant 10) generated-symbol (make-constant 0)) '()
             (make-apply (test-ref 'tail) (list (make-constant #f)))))
         (ir1->ir2
           (make-call-builtin 'poke (list (make-constant 10)
@@ -193,9 +198,10 @@
     (test closure
       (assert-equal
         (make-fix
-          (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c))
-                  (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
-          (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
+          (list (make-closure generated-symbol (list generated-symbol (test-ref 'c))
+                  (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol)
+                    (make-apply generated-symbol (list generated-symbol)))))
+          (make-apply (test-ref 'tail) (list generated-symbol)))
         (ir1->ir2 (make-lambda
                     (test-ref 'c)
                     (make-constant 5))
@@ -209,14 +215,15 @@
       (assert-equal
         (make-fix
           (list
-            (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x))
-              (make-apply (test-ref 'generated-symbol) (list (test-ref 'x)))))
+            (make-closure (test-ref 'f) (list generated-symbol (test-ref 'x))
+              (make-primitive 'cons (list (test-ref 'x) (make-constant '())) (list generated-symbol)
+                (make-apply generated-symbol (list generated-symbol)))))
           (make-fix
             (list
-              (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
-                (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
-            (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list (test-ref 'generated-symbol))
-              (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
+              (make-closure generated-symbol (list generated-symbol)
+                (make-apply (test-ref 'tail) (list generated-symbol))))
+            (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol)
+              (make-apply (test-ref 'f) (list generated-symbol generated-symbol)))))
         (ir1->ir2
           (make-letrec #f '(f) (list f)
                        (list (make-lambda x x))
@@ -249,8 +256,9 @@
       (assert-equal
         (make-fix
           (list
-            (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args))
-              (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
+            (make-closure (test-ref 'f) (list generated-symbol (test-ref 'args))
+              (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol)
+                (make-apply generated-symbol (list generated-symbol)))))
           (make-apply (test-ref 'tail) (list (make-constant 10))))
         (ir1->ir2
           (make-letrec #t
@@ -273,16 +281,18 @@
         (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
           (make-fix
             (list
-              (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args))
-                (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
-                  (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))))
+              (make-closure (test-ref 'f) (list generated-symbol (test-ref 'args))
+                (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol)
+                  (make-primitive 'cons (list generated-symbol (make-constant '())) (list generated-symbol)
+                    (make-apply generated-symbol (list generated-symbol))))))
             (make-fix
               (list
-                (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
-                  (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '()
-                    (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
-                      (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))))
-              (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant '()))))))
+                (make-closure generated-symbol (list generated-symbol)
+                  (make-primitive 'assert-singleton (list generated-symbol) (list generated-symbol)
+                    (make-primitive 'poke (list generated-symbol (test-ref 'x) (make-constant 0)) '()
+                      (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol)
+                        (make-apply (test-ref 'tail) (list generated-symbol)))))))
+              (make-apply (test-ref 'f) (list generated-symbol (make-constant '()))))))
         (ir1->ir2
           (make-letrec #t
             '(f x)
@@ -299,11 +309,12 @@
       (assert-equal
         (make-fix
           (list
-            (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
+            (make-closure (test-ref 'f) (list generated-symbol generated-symbol)
               (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'args))
-                (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'args) (make-constant 0)) '()
+                (make-primitive 'poke (list generated-symbol (test-ref 'args) (make-constant 0)) '()
                   (make-primitive 'poke (list (make-constant 10) (test-ref 'args) (make-constant 0)) '()
-                    (make-apply (test-ref 'generated-symbol) (list (make-constant #f))))))))
+                    (make-primitive 'cons (list (make-constant #f) (make-constant '())) (list generated-symbol)
+                      (make-apply generated-symbol (list generated-symbol))))))))
           (make-apply (test-ref 'tail) (list (make-constant 5))))
         (ir1->ir2 (make-letrec
                     #f
@@ -320,9 +331,10 @@
       (assert-equal
         (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
           (make-fix
-            (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'args))
-                    (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))))
-            (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '()
+            (list (make-closure generated-symbol (list generated-symbol (test-ref 'args))
+                    (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol)
+                      (make-apply generated-symbol (list generated-symbol)))))
+            (make-primitive 'poke (list generated-symbol (test-ref 'f) (make-constant 0)) '()
               (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '()
                 (make-apply (test-ref 'tail) (list (make-constant #f)))))))
         (ir1->ir2 (make-letrec
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))))
diff --git a/lib/csc/encoding.csc b/lib/csc/encoding.csc
index 099beaf..11c0f5f 100644
--- a/lib/csc/encoding.csc
+++ b/lib/csc/encoding.csc
@@ -195,6 +195,10 @@
           (make-opcode w 19 (is-const? l) #f)
           (arg->le-bytes w dest)
           (arg->le-bytes w l))
+        (('assert-singleton dest l)
+          (make-opcode w 20 (is-const? l) #f)
+          (arg->le-bytes w dest)
+          (arg->le-bytes w l))
         (_ (error "invalid opcode" opcode))))
 
 
diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc
index ee4e295..def474f 100644
--- a/lib/csc/macros-test.csc
+++ b/lib/csc/macros-test.csc
@@ -248,7 +248,7 @@
               (define
                 (syntax-rules ()
                   ((define (f) body ...)
-                    (builtin-define f (lambda args body ...)))))
+                    (builtin-define f (builtin-lambda args body ...)))))
               (define (exit)
                 (call-builtin exit code))))
           builtins-environment)
@@ -264,7 +264,7 @@
         (make-lambda (test-ref 'args)
           (make-sequence (make-constant #f) (test-ref 'args)))
         (expand-body 'main
-          '((lambda args args))
+          '((builtin-lambda args args))
           builtins-environment)
         transform-ir1))
 
@@ -277,7 +277,7 @@
                   (test-ref 'a))
             (make-sequence (make-constant #f) (make-constant 7))))
         (expand-body 'main
-          '((lambda args
+          '((builtin-lambda args
               (builtin-define a (quote 6))
               (builtin-define b a)
               (quote 7)))
@@ -315,7 +315,7 @@
             (make-constant #f)
             (make-lexical-set (test-ref 'args) (make-constant 5))))
         (expand-body 'main
-          '((lambda args
+          '((builtin-lambda args
               (set! args 5)))
           builtins-environment)
         transform-ir1))
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
index cf4549f..e78fc72 100644
--- a/lib/csc/macros.csc
+++ b/lib/csc/macros.csc
@@ -813,7 +813,7 @@
               (cons '... (make-library-ref '... '(scheme base)))
               (cons 'let-syntax builtin-let-syntax)
               (cons 'quote builtin-quote)
-              (cons 'lambda builtin-lambda)
+              (cons 'builtin-lambda builtin-lambda)
               (cons 'builtin-define builtin-define)
               (cons 'define-syntax builtin-define-syntax)
               (cons 'call-builtin builtin-call-builtin)