From 49292d5d019f7a87e217908ea7345fb02d05f1ab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= <msyds@deertopia.net>
Date: Thu, 27 Aug 2026 03:37:58 -0600
Subject: [PATCH] wip: call/cc primitives

---
 src/Gyehoek/CPS/Convert.hs   | 24 ++++++++++++------------
 src/Gyehoek/CPS/Stackify.hs  |  2 +-
 src/Gyehoek/Scheme/Syntax.hs |  6 ++++--
 src/Gyehoek/Stack/Syntax.hs  |  3 +++
 4 files changed, 20 insertions(+), 15 deletions(-)

diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs
index 349cf3b..fa93e68 100644
--- a/src/Gyehoek/CPS/Convert.hs
+++ b/src/Gyehoek/CPS/Convert.hs
@@ -47,18 +47,18 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert1 withcc \withcc' -> do
-    cc <- gensym' @Name "cc"
-    r <- gensym' "r"
-    m <- k . one $ ValVar r
-    ccish <- gensym' @Name "cc-ish"
-    x <- gensym' @Name "x"
-    pure [cps|
-      (letrec ((#{cc} (κ (#{r}) #{m})))
-        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-          (#{withcc'} #{ccish} #{cc})))
-    |]
+-- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+--   convert1 withcc \withcc' -> do
+--     cc <- gensym' @Name "cc"
+--     r <- gensym' "r"
+--     m <- k . one $ ValVar r
+--     ccish <- gensym' @Name "cc-ish"
+--     x <- gensym' @Name "x"
+--     pure [cps|
+--       (letrec ((#{cc} (κ (#{r}) #{m})))
+--         (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+--           (#{withcc'} #{ccish} #{cc})))
+--     |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..
diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs
index ac3abcf..f72a755 100644
--- a/src/Gyehoek/CPS/Stackify.hs
+++ b/src/Gyehoek/CPS/Stackify.hs
@@ -86,7 +86,7 @@ stackify g e@(ExpContinue k xs) = do
 --   stackifyKappa g cc_l cc \g' rt -> do
 --     emitRoutine rt
 --     pure $
---       Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $
+--       Code [ Stk.Prim rcc_l PrimCaptureCC ] $
 --       Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do
diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs
index 90f4d37..ea65be3 100644
--- a/src/Gyehoek/Scheme/Syntax.hs
+++ b/src/Gyehoek/Scheme/Syntax.hs
@@ -84,6 +84,7 @@ data Prim e
   | PrimEnvRef e Int
   | PrimEnvCode e
   | PrimCallCC e
+  | PrimCaptureCC
   | PrimValues (List e)
   | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
@@ -164,17 +165,18 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "integer?")
     $ S.With (. ht1 "write")
     $ S.With (. ht1 "zero?")
-    $ S.With (. nullop "newline")
+    $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
     $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
     $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
+    $ S.With (. ht0 "capture/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
     $ S.End
     where
       idn = S.el . S.sym . namefn
-      nullop s = S.list $ idn s
+      ht0 s = S.list $ idn s
       ht1 s = S.headTagged1 (namefn s) a
       ht2 s = S.headTagged2 (namefn s) a a
       ht1' s = S.headTagged1' (namefn s) a a
diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs
index b42fa00..808dcf4 100644
--- a/src/Gyehoek/Stack/Syntax.hs
+++ b/src/Gyehoek/Stack/Syntax.hs
@@ -61,6 +61,8 @@ data Block = MkBlock
 data Tail
   = TailCall Val (List Val)
   | If Val Block Block
+  -- | Invoke a reified continuation.
+  | InvokeC Val
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -105,6 +107,7 @@ instance S.DatumIso Tail where
   datumIso = S.match
     $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
+    $ S.With (S.headTagged1 "invoke/c" S.datumIso >>>)
     $ S.End
     where
       if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")