turn pure operations on metacontinuations into called procedures

1 files changed, 28 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))