old continuation code removed

i.c

@@ -6,7 +6,6 @@
 /* imports */
 extern obj cx__2Aglobals_2A;
 extern obj cx__2Atransformers_2A;
-extern obj cx_continuation_2Dclosure_2Dcode;
 extern obj cx_continuation_2Dadapter_2Dcode;
 extern obj cx_callmv_2Dadapter_2Dclosure;
 
@@ -391,28 +390,6 @@ define_instruction(gset) {
   gonexti();
 }
 
-define_instruction(conti) {
-  int n; ckx(sref(0));
-  n = (int)(sp - (r + VM_REGC));
-  hp_reserve(vmclobsz(2)+hbsz(n+1));
-  hp -= n; memcpy(hp, sp-n, n*sizeof(obj));
-  *--hp = obj_from_size(VECTOR_BTAG);
-  ac = hendblk(n+1); /* stack copy */   
-  *--hp = ac;
-  *--hp = cx_continuation_2Dclosure_2Dcode;
-  ac = hpushvmclo(2); /* closure */   
-  gonexti();
-}
-
-define_instruction(nuate) {
-  obj v = dref(0); int n = vectorlen(v);
-  assert((cxg_rend - cxg_regs - VM_REGC) > n);
-  sp = r + VM_REGC; /* stack is empty */
-  memcpy(sp, &vectorref(v, 0), n*sizeof(obj));
-  sp += n; /* contains n elements now */
-  gonexti();
-}
-
 define_instruction(appl) {
   int n, i; obj l = spop(), t = l;
   for (n = 0; ispair(t); t = cdr(t)) ++n; sgrow(n);

i.h

@@ -54,8 +54,6 @@ declare_instruction(brt,      "~?",  'b', NULL, 0, NULL)
 declare_instruction(sseti,    ".!",    1, NULL, 0, NULL) 
 declare_instruction(dseti,    ":!",    1, NULL, 0, NULL)
 declare_instruction(gset,     "@!",  'g', NULL, 0, NULL)
-declare_instruction(conti,    "K1",    0, NULL, 0, NULL) 
-declare_instruction(nuate,    "K2",    0, NULL, 0, NULL) 
 declare_instruction(appl,     "K3",    0, NULL, 0, NULL)
 declare_instruction(cwmv,     "K4",    0, NULL, 0, NULL)
 declare_instruction(rcmv,     "K5",    0, NULL, 0, NULL)

src/k.sf

@@ -1237,8 +1237,7 @@
 ; Initial environment
 ;---------------------------------------------------------------------------------------------
 
-; NB: 'nuate' restores stack with fn arg on top of return triple
+; adapter code for continuation closures produced by letcc 
-(define continuation-closure-code (decode "%1.0K2]1"))
 (define continuation-adapter-code (decode "k!"))
 
 ; adapter closure for values/call-with-values pair

src/t.scm

@@ -116,9 +116,9 @@
         (cons x (loop (car rest) (cdr rest))))))
 
 (define (list1? x) (and (pair? x) (null? (cdr x))))
+(define (list1+? x) (and (pair? x) (list? (cdr x))))
 (define (list2? x) (and (pair? x) (list1? (cdr x))))
-(define (list3? x) (and (pair? x) (list2? (cdr x))))
+(define (list2+? x) (and (pair? x) (list1+? (cdr x))))
-(define (list4? x) (and (pair? x) (list3? (cdr x))))
 
 
 ;---------------------------------------------------------------------------------------------
@@ -130,6 +130,8 @@
 ;  <core> -> (set! <id> <core>)
 ;  <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
 ;  <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>) 
+;  <core> -> (letcc <id> <core>) 
+;  <core> -> (withcc <core> <core>) 
 ;  <core> -> (begin <core> ...)
 ;  <core> -> (if <core> <core> <core>)
 ;  <core> -> (call <core> <core> ...) 
@@ -163,7 +165,6 @@
         (fx+ 1 (idslist-req-count (cdr ilist)))
         0)))
 
-
 ;---------------------------------------------------------------------------------------------
 ; Macro transformer (from Scheme to Scheme Core) derived from Al Petrofsky's EIOD 1.17
 ;---------------------------------------------------------------------------------------------
@@ -232,6 +233,8 @@
                   [(if)            (xform-if tail env)]
                   [(lambda)        (xform-lambda tail env)]
                   [(lambda*)       (xform-lambda* tail env)]
+                  [(letcc)         (xform-letcc tail env)]
+                  [(withcc)        (xform-withcc tail env)]
                   [(body)          (xform-body tail env)]
                   [(define)        (xform-define (car tail) (cadr tail) env)]
                   [(define-syntax) (xform-define-syntax (car tail) (cadr tail) env)]
@@ -312,6 +315,19 @@
               tail))
       (error 'transform "improper lambda* form")))
 
+(define (xform-letcc tail env)
+  (if (and (list2+? tail) (id? (car tail)))
+      (let* ([var (car tail)] [nvar (gensym (id->sym var))])
+        (list 'letcc nvar 
+          (xform-body (cdr tail) (add-var var nvar env))))
+      (error 'transform "improper letcc form")))
+
+(define (xform-withcc tail env)
+  (if (list2+? tail)
+      (list 'withcc (xform #f (car tail) env)
+        (xform-body (cdr tail) env))
+      (error 'transform "improper withcc form")))
+
 (define (xform-body tail env)
   (if (null? tail)
       (list 'begin)
@@ -379,10 +395,12 @@
     (make-binding 'define-syntax 'define-syntax)
     (make-binding 'quote 'quote)
     (make-binding 'set! 'set!)
-    (make-binding 'begin 'begin)
-    (make-binding 'if 'if)
     (make-binding 'lambda 'lambda)
     (make-binding 'lambda* 'lambda*)
+    (make-binding 'letcc 'letcc)
+    (make-binding 'withcc 'withcc)
+    (make-binding 'begin 'begin)
+    (make-binding 'if 'if)
     (make-binding 'body 'body)
     denotation-of-default-ellipsis))
 
@@ -408,7 +426,7 @@
     (syntax-rules* top-transformer-env ell lits rules)))
 
 (define (transform appos? sexp . optenv)
-  (gensym #f) ; reset gs counter to make results reproducible
+  ; (gensym #f) ; reset gs counter to make results reproducible
   (xform appos? sexp (if (null? optenv) top-transformer-env (car optenv))))
 
 

t.c

@@ -58,14 +58,14 @@ char *t_code[] = {
   0,
   "&0{%1.0p?{.0du]1}f]1}@!(y6:list1?)",
 
+  0,
+  "&0{%1.0p?{.0dL0]1}f]1}@!(y7:list1+?)",
+
   0,
   "&0{%1.0p?{.0d,@(y6:list1?)[11}f]1}@!(y6:list2?)",
 
   0,
-  "&0{%1.0p?{.0d,@(y6:list2?)[11}f]1}@!(y6:list3?)",
+  "&0{%1.0p?{.0d,@(y7:list1+?)[11}f]1}@!(y7:list2+?)",
-
-  0,
-  "&0{%1.0p?{.0d,@(y6:list3?)[11}f]1}@!(y6:list4?)",
 
   0,
   "&0{%1${.2,@(y6:list2?)[01}?{.0aI0?{.0daY1}{f}}{f}?{.0]1}.0,'0,,#0.0,&1"
@@ -145,11 +145,12 @@ char *t_code[] = {
   ",.1A1?{.6,.3da,.4a,@(y10:xform-set!)[73}'(l1:y5:begin;)%l,.1A1?{.6,.3,"
   "@(y11:xform-begin)[72}'(l1:y2:if;)%l,.1A1?{.6,.3,@(y8:xform-if)[72}'(l"
   "1:y6:lambda;)%l,.1A1?{.6,.3,@(y12:xform-lambda)[72}'(l1:y7:lambda*;)%l"
-  ",.1A1?{.6,.3,@(y13:xform-lambda*)[72}'(l1:y4:body;)%l,.1A1?{.6,.3,@(y1"
+  ",.1A1?{.6,.3,@(y13:xform-lambda*)[72}'(l1:y5:letcc;)%l,.1A1?{.6,.3,@(y"
-  "0:xform-body)[72}'(l1:y6:define;)%l,.1A1?{.6,.3da,.4a,@(y12:xform-defi"
+  "11:xform-letcc)[72}'(l1:y6:withcc;)%l,.1A1?{.6,.3,@(y12:xform-withcc)["
-  "ne)[73}'(l1:y13:define-syntax;)%l,.1A1?{.6,.3da,.4a,@(y19:xform-define"
+  "72}'(l1:y4:body;)%l,.1A1?{.6,.3,@(y10:xform-body)[72}'(l1:y6:define;)%"
-  "-syntax)[73}t?{.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,.3,@(y1"
+  "l,.1A1?{.6,.3da,.4a,@(y12:xform-define)[73}'(l1:y13:define-syntax;)%l,"
-  "0:xform-call)[73}f]7}@!(y5:xform)",
+  ".1A1?{.6,.3da,.4a,@(y19:xform-define-syntax)[73}t?{.1K0?{.6,${.9,.9,.6"
+  "[02},.6,@(y5:xform)[73}.6,.3,.3,@(y10:xform-call)[73}f]7}@!(y5:xform)",
 
   0,
   "&0{%2${.2,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:id->sym)[11}.0p?{${.2"
@@ -202,6 +203,17 @@ char *t_code[] = {
   "{.3a,:1[01}c]1}n]1}.!0.0^_1[01}_1,'(y7:lambda*)c]2}'(s21:improper lamb"
   "da* form),'(y9:transform),@(y5:error)[22}@!(y13:xform-lambda*)",
 
+  0,
+  "&0{%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}}{f}?{.0a,${${.4,@(y7:"
+  "id->sym)[01},@(y6:gensym)[01},${${.7,.5,.7,@(y7:add-var)[03},.5d,@(y10"
+  ":xform-body)[02},.1,'(y5:letcc),l3]4}'(s19:improper letcc form),'(y9:t"
+  "ransform),@(y5:error)[22}@!(y11:xform-letcc)",
+
+  0,
+  "&0{%2${.2,@(y7:list2+?)[01}?{${.3,.3d,@(y10:xform-body)[02},${.4,.4a,f"
+  ",@(y5:xform)[03},'(y6:withcc),l3]2}'(s20:improper withcc form),'(y9:tr"
+  "ansform),@(y5:error)[22}@!(y12:xform-withcc)",
+
   0,
   "&0{%2.0u?{n,'(y5:begin)c]2}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,."
   "5a,.0a,${.5,.3,t,@(y5:xform)[03},.0,'(l1:y5:begin;)%l,.1A1?{.4,.4dL6,."
@@ -240,14 +252,15 @@ char *t_code[] = {
 
   0,
   "@(y30:denotation-of-default-ellipsis),${'(y4:body),'(y4:body),@(y12:ma"
-  "ke-binding)[02},${'(y7:lambda*),'(y7:lambda*),@(y12:make-binding)[02},"
+  "ke-binding)[02},${'(y2:if),'(y2:if),@(y12:make-binding)[02},${'(y5:beg"
-  "${'(y6:lambda),'(y6:lambda),@(y12:make-binding)[02},${'(y2:if),'(y2:if"
+  "in),'(y5:begin),@(y12:make-binding)[02},${'(y6:withcc),'(y6:withcc),@("
-  "),@(y12:make-binding)[02},${'(y5:begin),'(y5:begin),@(y12:make-binding"
+  "y12:make-binding)[02},${'(y5:letcc),'(y5:letcc),@(y12:make-binding)[02"
-  ")[02},${'(y4:set!),'(y4:set!),@(y12:make-binding)[02},${'(y5:quote),'("
+  "},${'(y7:lambda*),'(y7:lambda*),@(y12:make-binding)[02},${'(y6:lambda)"
-  "y5:quote),@(y12:make-binding)[02},${'(y13:define-syntax),'(y13:define-"
+  ",'(y6:lambda),@(y12:make-binding)[02},${'(y4:set!),'(y4:set!),@(y12:ma"
-  "syntax),@(y12:make-binding)[02},${'(y6:define),'(y6:define),@(y12:make"
+  "ke-binding)[02},${'(y5:quote),'(y5:quote),@(y12:make-binding)[02},${'("
-  "-binding)[02},${'(y6:syntax),'(y6:syntax),@(y12:make-binding)[02},l(i1"
+  "y13:define-syntax),'(y13:define-syntax),@(y12:make-binding)[02},${'(y6"
-  "1)@!(y14:*transformers*)",
+  ":define),'(y6:define),@(y12:make-binding)[02},${'(y6:syntax),'(y6:synt"
+  "ax),@(y12:make-binding)[02},l(i13)@!(y14:*transformers*)",
 
   0,
   "&0{%1${@(y14:*transformers*),.3,@(y16:find-top-binding)[02},${.2,@(y8:"
@@ -266,8 +279,8 @@ char *t_code[] = {
   ",@(y20:install-transformer!)[42}@!(y26:install-transformer-rules!)",
 
   0,
-  "&0{%!2${f,@(y6:gensym)[01}.0u?{@(y19:top-transformer-env)}{.0a},.3,.3,"
+  "&0{%!2.0u?{@(y19:top-transformer-env)}{.0a},.3,.3,@(y5:xform)[33}@!(y9"
-  "@(y5:xform)[33}@!(y9:transform)",
+  ":transform)",
 
   0,
   "&0{%4,,,,,,,#0#1#2#3#4#5#6.9,&1{%1:0,.1A0]1}.!0.0,&1{%1${.2,:0^[01}~]1"