From: Tim Vaughan <tgvaughan@gmail.com>
Date: Mon, 9 Oct 2017 21:55:07 +0000 (+0200)
Subject: Sketching out call-cc implementation.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=899e3f7a10cbb8ecd03aa2dfe3ad08bf4638a324

Sketching out call-cc implementation.
---

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index bce895d..f94701f 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -607,6 +607,16 @@ defer display
     2swap apply
 ; make-primitive apply 
 
+: make-continuation
+  \ TODO: Capture parameter and return stacks in continuation
+;
+
+:noname ( args -- result )
+  make-continuation nil cons
+  2swap apply
+
+; 1 make-fa-primitive call-with-current-continuation
+
 \ }}}
 
 \ ==== Miscellaneous  ==== {{{
diff --git a/src/scheme.4th b/src/scheme.4th
index 9f744c0..48c363a 100644
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -39,6 +39,7 @@ make-type pair-type
 make-type symbol-type
 make-type primitive-proc-type
 make-type compound-proc-type
+make-type continuation-type
 make-type port-type
 : istype? ( obj type -- obj bool )
     over = ;
@@ -1669,6 +1670,10 @@ parse-idx-stack parse-idx-sp !
                ['] evaluate-eproc goto
         endof
 
+        continuation-type of
+          \ TODO: Apply continuation
+        endof
+
         except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
     endcase
 ;
@@ -1917,6 +1922,9 @@ parse-idx-stack parse-idx-sp !
 : printcomp ( primobj -- )
     2drop ." <compound procedure>" ;
 
+: printcont ( primobj --)
+    2drop ." <continuation>" ;
+
 : printnone ( noneobj -- )
     2drop ." Unspecified return value" ;
 
@@ -1935,6 +1943,7 @@ parse-idx-stack parse-idx-sp !
     pair-type istype? if ." (" printpair ." )" exit then
     primitive-proc-type istype? if printprim exit then
     compound-proc-type istype? if printcomp exit then
+    continuation-type istype? if printcont exit then
     none-type istype? if printnone exit then
     port-type istype? if printport exit then