diff --git a/contrib/20.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm index 45cbdac9..17af9302 100644 --- a/contrib/20.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -739,6 +739,40 @@ ;; 6.10. Control features + (define checkpoints '((0 #f . #f))) + + (define (dynamic-wind in thunk out) + (in) + (set! checkpoints `((,(+ 1 (caar checkpoints)) ,in . ,out) . ,checkpoints)) + (let ((ans (thunk))) + (set! checkpoints (cdr checkpoints)) + (out) + ans)) + + (define (do-wind here there) + (unless (eq? here there) + (if (< (caar here) (caar there)) + (begin + (do-wind here (cdr there)) + ((cadr (car there)))) + (begin + ((cddr (car here))) + (do-wind (cdr here) there))))) + + (define scheme:call/cc + (let ((c call/cc)) + (lambda (f) + (c (lambda (k) + (f (let ((save checkpoints)) + (lambda args + (do-wind checkpoints save) + (set! checkpoints save) + (apply k args))))))))) + + ;; call/cc and scheme:call/cc cannot coincide, so overwrite them + (set! call/cc scheme:call/cc) + (set! call-with-current-continuation scheme:call/cc) + (export procedure? apply map diff --git a/lib/cont.c b/lib/cont.c index 2b6fb1f7..17e02a34 100644 --- a/lib/cont.c +++ b/lib/cont.c @@ -9,7 +9,6 @@ struct cont { PIC_JMPBUF *jmp; - struct checkpoint *cp; ptrdiff_t sp_offset; ptrdiff_t ci_offset; size_t arena_idx; @@ -24,29 +23,12 @@ struct cont { static const pic_data_type cont_type = { "cont", NULL }; -static void -do_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there) -{ - if (here == there) - return; - - if (here->depth < there->depth) { - do_wind(pic, here, there->prev); - pic_call(pic, obj_value(pic, there->in), 0); - } - else { - pic_call(pic, obj_value(pic, here->out), 0); - do_wind(pic, here->prev, there); - } -} - void pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) { cont->jmp = jmp; /* save runtime context */ - cont->cp = pic->cp; cont->sp_offset = pic->sp - pic->stbase; cont->ci_offset = pic->ci - pic->cibase; cont->arena_idx = pic->arena_idx; @@ -62,10 +44,7 @@ pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) void pic_load_point(pic_state *pic, struct cont *cont) { - do_wind(pic, pic->cp, cont->cp); - /* load runtime context */ - pic->cp = cont->cp; pic->sp = pic->stbase + cont->sp_offset; pic->ci = pic->cibase + cont->ci_offset; pic->arena_idx = cont->arena_idx; @@ -80,30 +59,6 @@ pic_exit_point(pic_state *pic) pic->cc = pic->cc->prev; } -pic_value -pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out) -{ - struct checkpoint *here; - pic_value val; - - pic_call(pic, in, 0); /* enter */ - - here = pic->cp; - pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); - pic->cp->prev = here; - pic->cp->depth = here->depth + 1; - pic->cp->in = pic_proc_ptr(pic, in); - pic->cp->out = pic_proc_ptr(pic, out); - - val = pic_call(pic, thunk, 0); - - pic->cp = here; - - pic_call(pic, out, 0); /* exit */ - - return val; -} - static pic_value cont_call(pic_state *pic) { @@ -131,7 +86,6 @@ cont_call(pic_state *pic) pic_load_point(pic, cont); PIC_LONGJMP(pic, *cont->jmp, 1); - PIC_UNREACHABLE(); } @@ -232,16 +186,6 @@ pic_cont_callcc(pic_state *pic) return pic_callcc(pic, f); } -static pic_value -pic_cont_dynamic_wind(pic_state *pic) -{ - pic_value in, thunk, out; - - pic_get_args(pic, "lll", &in, &thunk, &out); - - return pic_dynamic_wind(pic, in, thunk, out); -} - static pic_value pic_cont_values(pic_state *pic) { @@ -276,7 +220,6 @@ 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); pic_defun(pic, "values", pic_cont_values); pic_defun(pic, "call-with-values", pic_cont_call_with_values); } diff --git a/lib/ext/write.c b/lib/ext/write.c index b471d850..510fb6ae 100644 --- a/lib/ext/write.c +++ b/lib/ext/write.c @@ -463,8 +463,6 @@ typename(pic_state *pic, pic_value obj) return "ephemeron"; case PIC_TYPE_RECORD: return "record"; - case PIC_TYPE_CP: - return "checkpoint"; default: pic_error(pic, "typename: invalid type given", 1, obj); } diff --git a/lib/gc.c b/lib/gc.c index 3ebd4af2..b7652e54 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -32,7 +32,6 @@ struct object { struct context cxt; struct port port; struct error err; - struct checkpoint cp; struct irep irep; } u; }; @@ -441,18 +440,6 @@ gc_mark_object(pic_state *pic, struct object *obj) pic->heap->weaks = weak; break; } - case PIC_TYPE_CP: { - if (obj->u.cp.prev) { - gc_mark_object(pic, (struct object *)obj->u.cp.prev); - } - if (obj->u.cp.in) { - gc_mark_object(pic, (struct object *)obj->u.cp.in); - } - if (obj->u.cp.out) { - LOOP((struct object *)obj->u.cp.out); - } - break; - } default: PIC_UNREACHABLE(); } @@ -604,7 +591,6 @@ gc_finalize_object(pic_state *pic, struct object *obj) case PIC_TYPE_ERROR: case PIC_TYPE_ID: case PIC_TYPE_RECORD: - case PIC_TYPE_CP: case PIC_TYPE_PROC_FUNC: case PIC_TYPE_PROC_IREP: break; diff --git a/lib/include/picrin/value.h b/lib/include/picrin/value.h index f82ac694..1b17f048 100644 --- a/lib/include/picrin/value.h +++ b/lib/include/picrin/value.h @@ -35,10 +35,10 @@ enum { PIC_TYPE_SYMBOL = 28, PIC_TYPE_PAIR = 29, PIC_TYPE_CXT = 30, - PIC_TYPE_CP = 31, PIC_TYPE_PROC_FUNC = 32, PIC_TYPE_PROC_IREP = 33, - PIC_TYPE_IREP = 34 + PIC_TYPE_IREP = 34, + PIC_TYPE_MAX = 63 }; #if !PIC_NAN_BOXING @@ -221,7 +221,6 @@ DEFPRED(pic_env_p, PIC_TYPE_ENV) DEFPRED(pic_rec_p, PIC_TYPE_RECORD) DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL) DEFPRED(pic_pair_p, PIC_TYPE_PAIR) -DEFPRED(pic_cp_p, PIC_TYPE_CP) DEFPRED(pic_proc_func_p, PIC_TYPE_PROC_FUNC) DEFPRED(pic_proc_irep_p, PIC_TYPE_PROC_IREP) DEFPRED(pic_irep_p, PIC_TYPE_IREP) diff --git a/lib/object.h b/lib/object.h index 4493d903..d38d496f 100644 --- a/lib/object.h +++ b/lib/object.h @@ -169,14 +169,6 @@ struct port { } file; }; -struct checkpoint { - OBJECT_HEADER - struct proc *in; - struct proc *out; - int depth; - struct checkpoint *prev; -}; - #define TYPENAME_int "integer" #define TYPENAME_blob "bytevector" #define TYPENAME_char "character" @@ -277,7 +269,6 @@ DEFPTR(pic_env_ptr, struct env) DEFPTR(pic_port_ptr, struct port) DEFPTR(pic_error_ptr, struct error) DEFPTR(pic_rec_ptr, struct record) -DEFPTR(pic_cp_ptr, struct checkpoint) DEFPTR(pic_irep_ptr, struct irep) struct object *pic_obj_alloc(pic_state *, size_t, int type); @@ -300,7 +291,6 @@ struct cont *pic_alloca_cont(pic_state *); pic_value pic_make_cont(pic_state *, struct cont *); void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *); void pic_exit_point(pic_state *); -pic_value pic_dynamic_wind(pic_state *, pic_value in, pic_value thunk, pic_value out); pic_value pic_library_environment(pic_state *, const char *); diff --git a/lib/state.c b/lib/state.c index aebad456..75fe19a5 100644 --- a/lib/state.c +++ b/lib/state.c @@ -181,9 +181,6 @@ pic_open(pic_allocf allocf, void *userdata) /* continuation chain */ pic->cc = NULL; - /* root block */ - pic->cp = NULL; - /* prepare VM stack */ pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value)); pic->stend = pic->stbase + PIC_STACK_SIZE; @@ -243,12 +240,6 @@ pic_open(pic_allocf allocf, void *userdata) pic->macros = pic_make_weak(pic); pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic)); - /* root block */ - pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); - pic->cp->prev = NULL; - pic->cp->depth = 0; - pic->cp->in = pic->cp->out = NULL; - /* user land */ pic_deflibrary(pic, "picrin.user");