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.
This commit is contained in:
Jan Nieuwenhuizen
parent
b66cd8627c
commit
d0f7db73f9
47
mes.c
47
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
|
||||
|| TYPE (CAR (x)) == REF
|
||||
|| TYPE (CAR (x)) == SPECIAL
|
||||
|| TYPE (CAR (x)) == SYMBOL
|
||||
|| TYPE (CAR (x)) == STRING) ? CAR (x) : MAKE_NUMBER (CAR (x));
|
||||
return (TYPE (x) != CONTINUATION
|
||||
&& (TYPE (CAR (x)) == PAIR // FIXME: this is weird
|
||||
|| TYPE (CAR (x)) == REF
|
||||
|| TYPE (CAR (x)) == SPECIAL
|
||||
|| 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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:pair>) 6) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:macro>) 5) (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:string> 9)
|
||||
(define <cell:keyword> 4)
|
||||
(define <cell:string> 10)
|
||||
|
||||
(define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
|
||||
(define (display x . rest) (core:stderr x))
|
||||
|
|
|
|||
|
|
@ -27,22 +27,24 @@
|
|||
|
||||
(define <cell:char> 0)
|
||||
(define <cell:closure> 1)
|
||||
(define <cell:function> 2)
|
||||
(define <cell:keyword> 3)
|
||||
(define <cell:macro> 4)
|
||||
(define <cell:number> 5)
|
||||
(define <cell:pair> 6)
|
||||
(define <cell:ref> 7)
|
||||
(define <cell:special> 8)
|
||||
(define <cell:string> 9)
|
||||
(define <cell:symbol> 10)
|
||||
(define <cell:values> 11)
|
||||
(define <cell:vector> 12)
|
||||
(define <cell:broken-heart> 13)
|
||||
(define <cell:continuation> 2)
|
||||
(define <cell:function> 3)
|
||||
(define <cell:keyword> 4)
|
||||
(define <cell:macro> 5)
|
||||
(define <cell:number> 6)
|
||||
(define <cell:pair> 7)
|
||||
(define <cell:ref> 8)
|
||||
(define <cell:special> 9)
|
||||
(define <cell:string> 10)
|
||||
(define <cell:symbol> 11)
|
||||
(define <cell:values> 12)
|
||||
(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>))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue