core: Add continuations, call/cc.

* mes.c (type_t): Add CONTINUATION.
  (scm_t): Add continuation;
  (scm_call_with_current_continuation): New symbol.
  (scm_symbol_call_with_current_continuation): New special.
  (g_continuations): New global
  (CONTINUATION): New field accessor.
  (MAKE_CONTINUATION): New make_cell helper.
  (car_): Update.
  (eval_apply): Implement call/cc.
* module/mes/display.mes (display): Handle continuations.
* module/mes/type-0.mes (<cell:continuation>): New type.
  (cell-type-alist): Add it.
  (continuation?): New function.
* tests/base.test ("call/cc"): New test.

mes.c

@@ -46,7 +46,7 @@ int MAX_ARENA_SIZE = 20000000;
 int GC_SAFETY = 100;
 
 typedef int SCM;
-enum type_t {CHAR, CLOSURE, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
+enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
 typedef SCM (*function0_t) (void);
 typedef SCM (*function1_t) (SCM);
 typedef SCM (*function2_t) (SCM, SCM);
@@ -77,6 +77,7 @@ typedef struct scm_struct {
     int function;
     SCM cdr;
     SCM closure;
+    SCM continuation;
     SCM macro;
     SCM vector;
     int hits;
@@ -106,6 +107,8 @@ scm scm_symbol_macro_expand = {SYMBOL, "macro-expand"};
 scm scm_symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
 
 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
+scm scm_call_with_current_continuation = {SPECIAL, "*call/cc*"};
+scm scm_symbol_call_with_current_continuation = {SYMBOL, "call-with-current-continuation"};
 scm scm_symbol_current_module = {SYMBOL, "current-module"};
 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
@@ -146,6 +149,7 @@ scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
 scm scm_vm_if = {SPECIAL, "*vm-if*"};
 scm scm_vm_if_expr = {SPECIAL, "*vm-if-expr*"};
 scm scm_vm_call_with_values2 = {SPECIAL, "*vm-call-with-values2*"};
+scm scm_vm_call_with_current_continuation2 = {SPECIAL, "*vm-call-with-current-continuation2*"};
 scm scm_vm_return = {SPECIAL, "*vm-return*"};
 
 scm scm_test = {SYMBOL, "test"};
@@ -163,6 +167,7 @@ SCM tmp_num2;
 function_t functions[200];
 int g_function = 0;
 
+SCM g_continuations = 0;
 SCM g_symbols = 0;
 SCM g_stack = 0;
 SCM r0 = 0; // a/env
@@ -178,6 +183,7 @@ SCM r3 = 0; // continuation
 
 #define CAR(x) g_cells[x].car
 #define CDR(x) g_cells[x].cdr
+#define CONTINUATION(x) g_cells[x].cdr
 #define HITS(x) g_cells[x].hits
 #define LENGTH(x) g_cells[x].length
 #define NAME(x) g_cells[x].name
@@ -202,6 +208,7 @@ SCM r3 = 0; // continuation
 #define CADR(x) CAR (CDR (x))
 
 #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
+#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
 #define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
@@ -293,11 +300,12 @@ type_ (SCM x)
 SCM
 car_ (SCM x)
 {
-  return (TYPE (CAR (x)) == PAIR
+  return (TYPE (x) != CONTINUATION
-          || TYPE (CAR (x)) == REF
+          && (TYPE (CAR (x)) == PAIR // FIXME: this is weird
-          || TYPE (CAR (x)) == SPECIAL
+              || TYPE (CAR (x)) == REF
-          || TYPE (CAR (x)) == SYMBOL
+              || TYPE (CAR (x)) == SPECIAL
-          || TYPE (CAR (x)) == STRING) ? CAR (x) : MAKE_NUMBER (CAR (x));
+              || TYPE (CAR (x)) == SYMBOL
+              || TYPE (CAR (x)) == STRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
 }
 
 SCM
@@ -412,6 +420,7 @@ eval_apply ()
     case cell_vm_begin2: goto begin2;
     case cell_vm_if: goto vm_if;
     case cell_vm_if_expr: goto if_expr;
+    case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
     case cell_vm_call_with_values2: goto call_with_values2;
     case cell_vm_return: goto vm_return;
     case cell_unspecified: return r1;
@@ -453,6 +462,14 @@ eval_apply ()
         call_lambda (body, p, aa, r0);
         goto begin;
       }
+      case CONTINUATION:
+        {
+          x = r1;
+          g_stack = CONTINUATION (CAR (r1));
+          gc_pop_frame ();
+          r1 = cadr (x);
+          goto eval_apply;
+        }
     case SPECIAL:
       {
         switch (car (r1))
@@ -467,6 +484,11 @@ eval_apply ()
               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
               goto eval;
             }
+          case cell_call_with_current_continuation:
+            {
+              r1 = cdr (r1);
+              goto call_with_current_continuation;
+            }
           default: error ("cannot apply special: ", car (r1));
           }
       }
@@ -668,6 +690,16 @@ eval_apply ()
   r1 = cell_unspecified;
   goto vm_return;
 
+ call_with_current_continuation:
+  gc_push_frame ();
+  x = MAKE_CONTINUATION (g_continuations++);
+  gc_pop_frame ();
+  push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
+  goto apply;
+ call_with_current_continuation2:
+  CONTINUATION (r2) = g_stack;
+  goto vm_return;
+
  call_with_values:
   push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
   goto apply;
@@ -921,6 +953,7 @@ gc_loop (SCM scan)
   while (scan < g_free)
     {
       if (NTYPE (scan) == CLOSURE
+          || NTYPE (scan) == CONTINUATION
           || NTYPE (scan) == FUNCTION
           || NTYPE (scan) == KEYWORD
           || NTYPE (scan) == MACRO
@@ -935,6 +968,7 @@ gc_loop (SCM scan)
           gc_relocate_car (scan, car);
         }
       if ((NTYPE (scan) == CLOSURE
+           || NTYPE (scan) == CONTINUATION
            || NTYPE (scan) == MACRO
            || NTYPE (scan) == PAIR
            || NTYPE (scan) == VALUES)
@@ -1047,6 +1081,7 @@ mes_symbols () ///((internal))
 #endif
   a = acons (cell_symbol_dot, cell_dot, a);
   a = acons (cell_symbol_begin, cell_begin, a);
+  a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
   a = acons (cell_symbol_sc_expand, cell_f, a);
   a = acons (cell_closure, a, a);
 

module/mes/base-0.mes

@@ -159,6 +159,7 @@
 (mes-use-module (srfi srfi-0))
 (mes-use-module (mes base))
 (mes-use-module (mes quasiquote))
+(mes-use-module (mes let))
 (mes-use-module (mes scm))
 (mes-use-module (srfi srfi-13))
 (mes-use-module (mes display))

module/mes/base.mes

@@ -41,6 +41,7 @@
 (define (cadddr x) (car (cdr (cdr (cdr x)))))
 
 (define (identity x) x)
+(define call/cc call-with-current-continuation)
 
 (define (command-line) argv)
 

module/mes/display.mes

@@ -86,6 +86,10 @@
         (display " " port)
         (display (cadr (core:cdr x)) port)
         (display ">" port))
+       ((continuation? x)
+        (display "#<continuation " port)
+        (display (core:car x) port)
+        (display ">" port))
        ((macro? x)
         (display "#<macro " port)
         (display (core:cdr x) port)

module/mes/read-0.mes

@@ -43,8 +43,8 @@
           (set-cdr! (assq (quote *closure*) a) a+)
           (car a+)))
 
-  (env:define (cons (cons (quote <cell:macro>) 4) (list)) (current-module))
+  (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
-  (env:define (cons (cons (quote <cell:pair>) 6) (list)) (current-module))
+  (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
   (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
   (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
   (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
@@ -105,8 +105,8 @@
      (current-module))) (current-module))
 
   (define <cell:character> 0)
-  (define <cell:keyword> 3)
+  (define <cell:keyword> 4)
-  (define <cell:string> 9)
+  (define <cell:string> 10)
 
   (define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
   (define (display x . rest) (core:stderr x))

module/mes/type-0.mes

@@ -27,22 +27,24 @@
 
 (define <cell:char> 0)
 (define <cell:closure> 1)
-(define <cell:function> 2)
+(define <cell:continuation> 2)
-(define <cell:keyword> 3)
+(define <cell:function> 3)
-(define <cell:macro> 4)
+(define <cell:keyword> 4)
-(define <cell:number> 5)
+(define <cell:macro> 5)
-(define <cell:pair> 6)
+(define <cell:number> 6)
-(define <cell:ref> 7)
+(define <cell:pair> 7)
-(define <cell:special> 8)
+(define <cell:ref> 8)
-(define <cell:string> 9)
+(define <cell:special> 9)
-(define <cell:symbol> 10)
+(define <cell:string> 10)
-(define <cell:values> 11)
+(define <cell:symbol> 11)
-(define <cell:vector> 12)
+(define <cell:values> 12)
-(define <cell:broken-heart> 13)
+(define <cell:vector> 13)
+(define <cell:broken-heart> 14)
 
 (define cell:type-alist
   (list (cons <cell:char> (quote <cell:char>))
         (cons <cell:closure> (quote <cell:closure>))
+        (cons <cell:continuation> (quote <cell:continuation>))
         (cons <cell:function> (quote <cell:function>))
         (cons <cell:keyword> (quote <cell:keyword>))
         (cons <cell:macro> (quote <cell:macro>))
@@ -65,6 +67,9 @@
 (define (closure? x)
   (eq? (core:type x) <cell:closure>))
 
+(define (continuation? x)
+  (eq? (core:type x) <cell:continuation>))
+
 (define (function? x)
   (eq? (core:type x) <cell:function>))
 

tests/base.test

@@ -89,4 +89,13 @@ exit $?
 (if (not guile?)
   (pass-if-equal "load" 42 (begin (load "tests/data/load.scm") the-answer)))
 
+(pass-if-equal "call/cc"
+    0
+  (let ((cont #f)
+        (seen? #f))
+    (+ 1 (call/cc (lambda (c) (set! cont c) 1)))
+    (if seen? 0
+        (begin (set! seen? #t)
+               (cont 2)))))
+
 (result 'report)