diff --git a/contrib/03.callcc/callcc.c b/contrib/03.callcc/callcc.c index e013836f..7b6b9609 100644 --- a/contrib/03.callcc/callcc.c +++ b/contrib/03.callcc/callcc.c @@ -21,6 +21,8 @@ struct pic_fullcont { pic_code *ip; + pic_value ptable; + struct pic_object **arena; size_t arena_size; int arena_idx; @@ -83,6 +85,9 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) mark(pic, pic_obj_value(cont->arena[i])); } + /* parameter table */ + mark(pic, cont->ptable); + /* result values */ mark(pic, cont->results); } @@ -144,6 +149,8 @@ save_cont(pic_state *pic, struct pic_fullcont **c) cont->ip = pic->ip; + cont->ptable = pic->ptable; + cont->arena_idx = pic->arena_idx; cont->arena_size = pic->arena_size; cont->arena = pic_malloc(pic, sizeof(struct pic_object *) * pic->arena_size); @@ -195,6 +202,8 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont) pic->ip = cont->ip; + pic->ptable = cont->ptable; + pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size); memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size); pic->arena_size = cont->arena_size; diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index ededb5d4..a65f4c7b 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -306,30 +306,15 @@ my $src = <<'EOL'; `(,(r 'begin) ,@(cdr clause))) ,(loop (cdr clauses))))))))))) - (define (dynamic-bind parameters values body) - (let* ((old-bindings - (current-dynamic-environment)) - (binding - (map (lambda (parameter value) - (cons parameter (parameter value #f))) - parameters - values)) - (new-bindings - (cons binding old-bindings))) - (dynamic-wind - (lambda () (current-dynamic-environment new-bindings)) - body - (lambda () (current-dynamic-environment old-bindings))))) - (define-syntax parameterize (er-macro-transformer (lambda (form r compare) (let ((formal (cadr form)) (body (cddr form))) - `(,(r 'dynamic-bind) - (list ,@(map car formal)) - (list ,@(map cadr formal)) - (,(r 'lambda) () ,@body)))))) + `(,(r 'with-parameter) + (lambda () + ,@formal + ,@body)))))) (define-syntax letrec-syntax (er-macro-transformer @@ -538,26 +523,19 @@ const char pic_boot[][80] = { " (car clause))))\n ,(if (compare (r '=>) (list-ref cla", "use 1))\n `(,(list-ref clause 2) ,(r 'key))\n ", " `(,(r 'begin) ,@(cdr clause)))\n ,(loop (", -"cdr clauses)))))))))))\n\n (define (dynamic-bind parameters values body)\n (let", -"* ((old-bindings\n (current-dynamic-environment))\n (binding\n", -" (map (lambda (parameter value)\n (cons parameter (p", -"arameter value #f)))\n parameters\n values))\n ", -" (new-bindings\n (cons binding old-bindings)))\n (dynamic-win", -"d\n (lambda () (current-dynamic-environment new-bindings))\n bod", -"y\n (lambda () (current-dynamic-environment old-bindings)))))\n\n (define", -"-syntax parameterize\n (er-macro-transformer\n (lambda (form r compare)\n ", -" (let ((formal (cadr form))\n (body (cddr form)))\n `(,(r '", -"dynamic-bind)\n (list ,@(map car formal))\n (list ,@(map cadr ", -"formal))\n (,(r 'lambda) () ,@body))))))\n\n (define-syntax letrec-synta", -"x\n (er-macro-transformer\n (lambda (form r c)\n (let ((formal (car (c", -"dr form)))\n (body (cdr (cdr form))))\n `(let ()\n ", -" ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x", -")))\n formal)\n ,@body)))))\n\n (define-syntax let-syn", -"tax\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-synta", -"x) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n let-values let*", -"-values define-values\n quasiquote unquote unquote-splicing\n an", -"d or\n cond case else =>\n do when unless\n parameterize", -"\n let-syntax letrec-syntax\n syntax-error))\n\n", +"cdr clauses)))))))))))\n\n (define-syntax parameterize\n (er-macro-transformer\n", +" (lambda (form r compare)\n (let ((formal (cadr form))\n (bo", +"dy (cddr form)))\n `(,(r 'with-parameter)\n (lambda ()\n ", +" ,@formal\n ,@body))))))\n\n (define-syntax letrec-syntax\n (er-m", +"acro-transformer\n (lambda (form r c)\n (let ((formal (car (cdr form)))\n", +" (body (cdr (cdr form))))\n `(let ()\n ,@(map (la", +"mbda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n ", +" formal)\n ,@body)))))\n\n (define-syntax let-syntax\n (er", +"-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-syntax) ,@(cdr f", +"orm)))))\n\n (export let let* letrec letrec*\n let-values let*-values def", +"ine-values\n quasiquote unquote unquote-splicing\n and or\n ", +" cond case else =>\n do when unless\n parameterize\n ", +"let-syntax letrec-syntax\n syntax-error))\n\n", "", "" }; diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index b08f50cc..72a9b2cb 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -61,6 +61,7 @@ pic_save_point(pic_state *pic, struct pic_cont *cont) cont->xp_offset = pic->xp - pic->xpbase; cont->arena_idx = pic->arena_idx; cont->ip = pic->ip; + cont->ptable = pic->ptable; cont->results = pic_undef_value(); } @@ -88,6 +89,7 @@ pic_load_point(pic_state *pic, struct pic_cont *cont) pic->xp = pic->xpbase + cont->xp_offset; pic->arena_idx = cont->arena_idx; pic->ip = cont->ip; + pic->ptable = cont->ptable; } static pic_value diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index bf9f37ef..f7056d94 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -598,6 +598,9 @@ gc_mark_phase(pic_state *pic) gc_mark_object(pic, (struct pic_object *)pic->xSTDERR); } + /* parameter table */ + gc_mark(pic, pic->ptable); + /* attributes */ do { j = 0; diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5c4bea31..acc68cb6 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -130,6 +130,9 @@ typedef struct { pic_value libs; xhash attrs; + pic_value ptable; + size_t pnum; + struct pic_reader *reader; bool gc_enable; diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h index a20263ab..303ea0f9 100644 --- a/extlib/benz/include/picrin/cont.h +++ b/extlib/benz/include/picrin/cont.h @@ -21,6 +21,8 @@ struct pic_cont { pic_code *ip; + pic_value ptable; + pic_value results; }; diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index caa49cc6..bf1a0a4e 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -50,6 +50,7 @@ struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_c pic_sym *pic_proc_name(struct pic_proc *); struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *); +bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *); pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *); void pic_proc_env_set(pic_state *, struct pic_proc *, const char *, pic_value); diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index d730c909..9e5713c1 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -57,6 +57,12 @@ pic_proc_env(pic_state *pic, struct pic_proc *proc) return proc->u.f.env; } +bool +pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key) +{ + return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); +} + pic_value pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key) { diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 3bd6f639..75b2df9b 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -230,6 +230,10 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->xSTDOUT = NULL; pic->xSTDERR = NULL; + /* parameter table */ + pic->ptable = pic_nil_value(); + pic->pnum = 0; + /* native stack marker */ pic->native_stack_start = &t; @@ -342,6 +346,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); + /* parameter table */ + pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); + /* standard libraries */ pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)")); pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); diff --git a/extlib/benz/var.c b/extlib/benz/var.c index 6ef88ece..42741215 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -5,84 +5,79 @@ #include "picrin.h" static pic_value -var_lookup(pic_state *pic, struct pic_proc *var) +var_conv(pic_state *pic, struct pic_proc *var, pic_value val) { - pic_value val, env, binding; - pic_value key = pic_obj_value(var); - - val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment"); - if (pic_eq_p(val, key)) { - return pic_false_value(); + if (pic_proc_env_has(pic, var, "conv") != 0) { + return pic_apply1(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), val); } + return val; +} - env = pic_apply0(pic, pic_proc_ptr(val)); - while (! pic_nil_p(env)) { - binding = pic_car(pic, env); +static pic_value +var_get(pic_state *pic, struct pic_proc *var) +{ + pic_value elem, it; + pic_sym *id; + struct pic_dict *dict; - while (! pic_nil_p(binding)) { - if (pic_eq_p(pic_caar(pic, binding), key)) { - return pic_car(pic, binding); - } - binding = pic_cdr(pic, binding); + id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id")); + + pic_for_each (elem, pic->ptable, it) { + dict = pic_dict_ptr(elem); + if (pic_dict_has(pic, dict, id)) { + return pic_dict_ref(pic, dict, id); } - env = pic_cdr(pic, env); } + pic_panic(pic, "logic flaw"); +} - return pic_false_value(); +static pic_value +var_set(pic_state *pic, struct pic_proc *var, pic_value val) +{ + pic_sym *id; + struct pic_dict *dict; + + id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id")); + + dict = pic_dict_ptr(pic_car(pic, pic->ptable)); + + pic_dict_set(pic, dict, id, var_conv(pic, var, val)); + + return pic_none_value(); } static pic_value var_call(pic_state *pic) { struct pic_proc *self = pic_get_proc(pic); - pic_value val, tmp, box, conv; + pic_value val; int n; - n = pic_get_args(pic, "|oo", &val, &tmp); + n = pic_get_args(pic, "|o", &val); - box = var_lookup(pic, self); - if (! pic_test(box)) { - box = pic_proc_env_ref(pic, self, "box"); + if (n == 0) { + return var_get(pic, self); + } else { + return var_set(pic, self, val); } - - switch (n) { - case 0: - return pic_cdr(pic, box); - - case 1: - conv = pic_proc_env_ref(pic, self, "conv"); - if (pic_test(conv)) { - pic_assert_type(pic, conv, proc); - - val = pic_apply1(pic, pic_proc_ptr(conv), val); - } - pic_set_cdr(pic, box, val); - - return pic_none_value(); - - case 2: - assert(pic_false_p(tmp)); - - conv = pic_proc_env_ref(pic, self, "conv"); - if (pic_test(conv)) { - pic_assert_type(pic, conv, proc); - - return pic_apply1(pic, pic_proc_ptr(conv), val); - } else { - return val; - } - } - PIC_UNREACHABLE(); } struct pic_proc * pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { struct pic_proc *var; + pic_value converter = conv ? pic_obj_value(conv) : pic_false_value(); + pic_sym *id; var = pic_make_proc(pic, var_call, ""); - pic_proc_env_set(pic, var, "box", pic_cons(pic, pic_false_value(), init)); - pic_proc_env_set(pic, var, "conv", conv ? pic_obj_value(conv) : pic_false_value()); + + if (conv != NULL) { + pic_proc_env_set(pic, var, "conv", converter); + } + id = pic_intern(pic, pic_format(pic, "%d", pic->pnum++)); + pic_proc_env_set(pic, var, "id", pic_obj_value(id)); + + pic_apply1(pic, var, init); return var; } @@ -98,12 +93,26 @@ pic_var_make_parameter(pic_state *pic) return pic_obj_value(pic_make_var(pic, init, conv)); } +static pic_value +pic_var_with_parameter(pic_state *pic) +{ + struct pic_proc *body; + pic_value val; + + pic_get_args(pic, "l", &body); + + pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); + + val = pic_apply0(pic, body); + + pic->ptable = pic_cdr(pic, pic->ptable); + + return val; +} + void pic_init_var(pic_state *pic) { - pic_define_noexport(pic, "current-dynamic-environment", pic_false_value()); - pic_defun(pic, "make-parameter", pic_var_make_parameter); - - pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL))); + pic_defun(pic, "with-parameter", pic_var_with_parameter); }