artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: Add continuations, call/cc.

Browse source 
* 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 2016-12-28 22:04:57 +01:00
parent b66cd8627c
commit d0f7db73f9
7 changed files with 77 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
mes.c
View file

@ -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)) == 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));
|| 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);

1
module/mes/base-0.mes
View file

@ -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))

1
module/mes/base.mes
View file

@ -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)

4
module/mes/display.mes
View file

@ -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)

8
module/mes/read-0.mes
View file

@ -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))

29
module/mes/type-0.mes
View file

@ -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>))

9
tests/base.test
View file

@ -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)