From 9c28e5cf585653c57ce80f3a70a79e35a4fa7fa0 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 5 Aug 2022 16:58:12 -0700
Subject: Add call-with-current-continuation.

---
 lib/csc/cps.csc | 14 ++++++++++++++
 lib/csc/ir1.csc |  1 +
 2 files changed, 15 insertions(+)

(limited to 'lib/csc')

diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc
index f2a9c90..3c1e820 100644
--- a/lib/csc/cps.csc
+++ b/lib/csc/cps.csc
@@ -261,6 +261,20 @@
                   arg
                   (lambda (v)
                     (make-apply f (list return-address v))))))))
+        ((% %call-builtin 'call-with-current-continuation (proc))
+          (define return-address (new-ref))
+          (define result (new-ref))
+          (define argvec (new-ref))
+          (make-fix
+            (list (make-closure return-address (list result)
+                    (continuation result)))
+            (make-primitive 'alloc (list (make-constant 3)) (list argvec)
+              (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '()
+                (make-primitive 'poke (list (make-constant 1) argvec (make-constant 1)) '()
+                  (make-primitive 'poke (list return-address argvec (make-constant 2)) '()
+                    (to-cps proc
+                      (lambda (f)
+                        (make-apply f (list 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 b91e8ab..7674d49 100644
--- a/lib/csc/ir1.csc
+++ b/lib/csc/ir1.csc
@@ -169,6 +169,7 @@
     ;   - peek: pointer * offset -> result
     ;   - poke: word * pointer * offset -> ()
     ;   - int<?: int * int -> bool
+    ;   - call-with-current-continuation: proc -> result
     (define-match-record-type <call-builtin>
       (make-call-builtin operation arguments)
       call-builtin?
-- 
cgit v1.3.1