diff --git a/include/picrin.h b/include/picrin.h index 5a12c92d..61cfbb69 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -18,10 +18,18 @@ typedef struct { struct pic_env *env; } pic_callinfo; +struct pic_block { + struct pic_block *prev; + int depth; + struct pic_proc *in, *out; +}; + typedef struct { int argc; char **argv, **envp; + struct pic_block *blk; + pic_value *sp; pic_value *stbase, *stend; diff --git a/include/picrin/cont.h b/include/picrin/cont.h index 66ba6b91..9fe4390f 100644 --- a/include/picrin/cont.h +++ b/include/picrin/cont.h @@ -5,6 +5,8 @@ struct pic_cont { PIC_OBJECT_HEADER jmp_buf jmp; + struct pic_block *blk; + size_t stk_len; pic_value *stk_pos, *stk_ptr; diff --git a/piclib/built-in.scm b/piclib/built-in.scm index fcc0359c..70a36595 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -225,39 +225,3 @@ (eq? '*values-tag* (car res))) (apply consumer (cdr res)) (consumer res)))) - -(define original-cwcc call-with-current-continuation) - -(define *here* (list #f)) - -(define (reroot! there) - (if (not (eq? *here* there)) - (begin - (reroot! (cdr there)) - (let ((before (caar there)) - (after (cdar there))) - (set-car! *here* (cons after before)) - (set-cdr! *here* there) - (set-car! there #f) - (set-cdr! there '()) - (set! *here* there) - (before))))) - -(define (call-with-current-continuation proc) - (let ((here *here*)) - (original-cwcc - (lambda (cont) - (proc (lambda results - (reroot! here) - (apply cont results))))))) - -(define call/cc call-with-current-continuation) - -(define (dynamic-wind before during after) - (let ((here *here*)) - (reroot! (cons (cons before after) here)) - (call-with-values during - (lambda results - (reroot! here) - (apply values results))))) - diff --git a/src/cont.c b/src/cont.c index ddffdca9..f897620e 100644 --- a/src/cont.c +++ b/src/cont.c @@ -30,6 +30,8 @@ save_cont(pic_state *pic) cont = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); + cont->blk = pic->blk; + cont->stk_len = native_stack_length(pic, &pos); cont->stk_pos = pos; cont->stk_ptr = pic_alloc(pic, sizeof(pic_value) * cont->stk_len); @@ -76,6 +78,8 @@ restore_cont(pic_state *pic, struct pic_cont *cont) if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); } + pic->blk = cont->blk; + pic->sp = cont->sp; memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len); @@ -90,6 +94,22 @@ restore_cont(pic_state *pic, struct pic_cont *cont) longjmp(tmp->jmp, 1); } +static void +walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + walk_to_block(pic, here, there->prev); + pic_apply_argv(pic, there->in, 0); + } + else { + pic_apply_argv(pic, there->out, 0); + walk_to_block(pic, here->prev, there); + } +} + static pic_value cont_call(pic_state *pic) { @@ -103,6 +123,9 @@ cont_call(pic_state *pic) cont = (struct pic_cont *)pic_ptr(proc->env->values[0]); cont->result = v; + /* execute winded handlers */ + walk_to_block(pic, pic->blk, cont->blk); + restore_cont(pic, cont); /* the function never returns */ @@ -142,9 +165,53 @@ pic_cont_callcc(pic_state *pic) } } +static pic_value +pic_cont_dynamic_wind(pic_state *pic) +{ + pic_value a,b,c,v; + struct pic_proc *in, *thunk, *out; + + pic_get_args(pic, "ooo", &a, &b, &c); + + if (! pic_proc_p(a)) { + pic_error(pic, "procedure expected"); + } + in = pic_proc_ptr(a); + if (! pic_proc_p(b)) { + pic_error(pic, "procedure expected"); + } + thunk = pic_proc_ptr(b); + if (! pic_proc_p(c)) { + pic_error(pic, "procedure expected"); + } + out = pic_proc_ptr(c); + + /* enter */ + pic_apply_argv(pic, in, 0); + { + struct pic_block *here; + + here = pic->blk; + pic->blk = (struct pic_block *)pic_alloc(pic, sizeof(struct pic_block)); + pic->blk->prev = here; + pic->blk->depth = here->depth + 1; + pic->blk->in = in; + pic->blk->out = out; + + v = pic_apply_argv(pic, thunk, 0); + + pic->blk = here; + } + /* exit */ + pic_apply_argv(pic, out, 0); + + return v; +} + void pic_init_cont(pic_state *pic) { pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); pic_defun(pic, "call/cc", pic_cont_callcc); + pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); } diff --git a/src/state.c b/src/state.c index c7d2681c..fbcf99b1 100644 --- a/src/state.c +++ b/src/state.c @@ -22,6 +22,12 @@ pic_open(int argc, char *argv[], char **envp) pic->argv = argv; pic->envp = envp; + /* root block */ + pic->blk = (struct pic_block *)malloc(sizeof(struct pic_block)); + pic->blk->prev = NULL; + pic->blk->depth = 0; + pic->blk->in = pic->blk->out = NULL; + /* prepare VM stack */ pic->stbase = pic->sp = (pic_value *)malloc(sizeof(pic_value) * PIC_STACK_SIZE); pic->stend = pic->stbase + PIC_STACK_SIZE;