Add call-with-values.

2 files changed, 21 insertions, 1 deletions

diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc
index 3c1e820..a3e829b 100644
--- a/lib/csc/cps.csc
+++ b/lib/csc/cps.csc
@@ -274,7 +274,26 @@
                   (make-primitive 'poke (list return-address argvec (make-constant 2)) '()
                     (to-cps proc
                       (lambda (f)
-                        (make-apply f (list argvec))))))))))
+                        (make-apply f (list return-address argvec))))))))))
+        ((% %call-builtin 'call-with-values (producer consumer))
+          (define return-address (new-ref))
+          (define consumer-func (new-ref))
+          (define result (new-ref))
+          (define results (new-ref))
+          (define argvec (new-ref))
+          (make-fix
+            (list (make-closure return-address (list result)
+                    (continuation result))
+                  (make-closure consumer-func (list results)
+                    (to-cps consumer
+                      (lambda (c)
+                        (make-apply c (list return-address results))))))
+            (make-primitive 'alloc (list (make-constant 2)) (list argvec)
+              (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '()
+                (make-primitive 'poke (list (make-constant 0) argvec (make-constant 1)) '()
+                  (to-cps producer
+                    (lambda (p)
+                      (make-apply p (list consumer-func argvec)))))))))
         ((% %call-builtin op args)
           (define returns-value? (not (memq op '(poke exit))))
           (loop for arg in (reverse args)
diff --git a/lib/csc/ir1.csc b/lib/csc/ir1.csc
index 7674d49..efcd22f 100644
--- a/lib/csc/ir1.csc
+++ b/lib/csc/ir1.csc
@@ -170,6 +170,7 @@
     ;   - poke: word * pointer * offset -> ()
     ;   - int<?: int * int -> bool
     ;   - call-with-current-continuation: proc -> result
+    ;   - call-with-values: producer * consumer -> result
     (define-match-record-type <call-builtin>
       (make-call-builtin operation arguments)
       call-builtin?