turn pure operations on metacontinuations into called procedures

2 files changed, 44 insertions, 11 deletions

diff --git a/cps.scm b/cps.scm
index 63b92ba..1b09c53 100644
--- a/cps.scm
+++ b/cps.scm
@@ -139,12 +139,12 @@
 (define cps:with-sub-kont
   (cps-closure '(prompt proc) 'γ 'κ
                (cps-apply '__split-γ
-                          '(γ prompt)
+                          '(kont γ prompt)
                           'γ
                           (cps-kappa 'discarded
-                                     '(γ↑ γ↓)
+                                     '(kont+γ↑ γ↓)
                                      (cps-apply 'proc
-                                                `(cons* kont γ↑)
+                                                'kont+γ↑
                                                 '__κ0
                                                 'γ↓)))))
 
@@ -167,14 +167,22 @@
               (let (length=> tail 2) => (prompt-part expr-part)))
         (let* ((new-prompt (gensym "p"))
                (new-metakont (gensym "γ"))
+               (cons*-metakont (gensym "γ"))
                (cps-expr (core->cps
                           expr-part
-                          `(cons* ,new-prompt ,kont ,new-metakont)
-                          '__κ0)))
+                          cons*-metakont
+                          '__κ0))
+               (cons*-expr (cps-apply
+                            'cons*
+                            (list new-prompt kont new-metakont)
+                            new-metakont
+                            (cps-kappa 'ignored
+                                       (list cons*-metakont)
+                                       cps-expr))))
           (core->cps prompt-part metakont
                      (cps-kappa new-metakont
                                 (list new-prompt)
-                                cps-expr))))
+                                cons*-expr))))
       ;; (push-sub-cont e e)
       (after ((let (pair=> form) => (head tail))
               (when (eq? head 'push-sub-continuation))
@@ -182,17 +190,26 @@
               (let (length=> tail 2) => (sub-cont-part expr-part)))
         (let* ((sub-cont-reified (gensym "γ"))
                (sub-cont-from-eval (gensym "γ"))
+               (in-middle-sub-cont (gensym "γ"))
                (cps-expr (core->cps
                           expr-part
-                          `(in-middle ,sub-cont-reified
-                                      ,kont
-                                      ,sub-cont-from-eval)
-                          '__κ0)))
+                          in-middle-sub-cont
+                          '__κ0))
+               (in-middle-expr (cps-apply
+                                'in-middle
+                                (list sub-cont-reified
+                                      kont
+                                      sub-cont-from-eval)
+                                sub-cont-from-eval
+                                (cps-kappa 'ignored
+                                           (list in-middle-sub-cont)
+                                           cps-expr)))
+               )
           (core->cps sub-cont-part
                      metakont
                      (cps-kappa sub-cont-from-eval
                                 sub-cont-reified
-                                cps-expr))))
+                                in-middle-expr))))
       ;; (lambda formal expr)
       (after ((let (pair=> form) => (head tail))
               (when (eq? head 'lambda))
diff --git a/test.scm b/test.scm
index 9f409f0..7f7547f 100644
--- a/test.scm
+++ b/test.scm
@@ -98,3 +98,19 @@
         '(pass (y) () __toplevel)
         (cps->sexpr (core->cps '(if 'x y z)))))
 
+(test-group "delimited continuation syntax"
+  (test "push-prompt"
+        '(pass (x) ()
+               (kappa (__p1) __γ2
+                      (apply cons* (__p1 __toplevel __γ2) __γ2
+                             (kappa (__γ3) ignored
+                                    (pass (y) __γ3 __κ0)))))
+        (cps->sexpr (core->cps '(push-prompt x y))))
+  (test "push-sub-continuation"
+        '(pass (x) ()
+               (kappa __γ1 __γ2
+                      (apply in-middle (__γ1 __toplevel __γ2) __γ2
+                             (kappa (__γ3) ignored
+                                    (pass (y) __γ3 __κ0)))))
+        (cps->sexpr (core->cps '(push-sub-continuation x y)))))
+