diff --git a/contrib/03.callcc/callcc.c b/contrib/03.callcc/callcc.c index 2f953269..c51a7861 100644 --- a/contrib/03.callcc/callcc.c +++ b/contrib/03.callcc/callcc.c @@ -216,7 +216,7 @@ cont_call(pic_state *pic) proc = pic_get_proc(pic); pic_get_args(pic, "*", &argc, &argv); - cont = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(proc), "@@cont"))->data; + cont = pic_data_ptr(pic_proc_env_ref(pic, proc, "cont"))->data; cont->results = pic_list_by_array(pic, argc, argv); /* execute guard handlers */ @@ -243,7 +243,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc) dat = pic_data_alloc(pic, &cont_type, cont); /* save the continuation object in proc */ - pic_attr_set(pic, pic_obj_value(c), "@@cont", pic_obj_value(dat)); + pic_proc_env_set(pic, c, "cont", pic_obj_value(dat)); return pic_apply1(pic, proc, pic_obj_value(c)); } @@ -267,7 +267,7 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc) dat = pic_data_alloc(pic, &cont_type, cont); /* save the continuation object in proc */ - pic_attr_set(pic, pic_obj_value(c), "@@cont", pic_obj_value(dat)); + pic_proc_env_set(pic, c, "cont", pic_obj_value(dat)); return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); } diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 40ff119e..b331d0c6 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -99,7 +99,7 @@ cont_call(pic_state *pic) pic_get_args(pic, "*", &argc, &argv); - e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); + e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape")); ((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv); pic_load_point(pic, e->data); @@ -121,7 +121,7 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont) e = pic_data_alloc(pic, &cont_type, cont); /* save the escape continuation in proc */ - pic_attr_set(pic, pic_obj_value(c), "@@escape", pic_obj_value(e)); + pic_proc_env_set(pic, c, "escape", pic_obj_value(e)); return c; } diff --git a/extlib/benz/error.c b/extlib/benz/error.c index d9684386..a9390af2 100644 --- a/extlib/benz/error.c +++ b/extlib/benz/error.c @@ -73,7 +73,7 @@ native_exception_handler(pic_state *pic) pic->err = err; - cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); + cont = pic_proc_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "cont")); pic_apply1(pic, cont, pic_false_value()); @@ -89,7 +89,7 @@ pic_push_try(pic_state *pic, struct pic_proc *cont) handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); - pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont)); + pic_proc_env_set(pic, handler, "cont", pic_obj_value(cont)); if (pic->xp >= pic->xpend) { xp_len = (size_t)(pic->xpend - pic->xpbase) * 2; diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index c60f377a..aedd9836 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -368,13 +368,16 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_PROC: { struct pic_proc *proc = (struct pic_proc *)obj; - if (proc->cxt) { - gc_mark_object(pic, (struct pic_object *)proc->cxt); - } if (pic_proc_irep_p(proc)) { - gc_mark_object(pic, (struct pic_object *)proc->u.irep); + gc_mark_object(pic, (struct pic_object *)proc->u.i.irep); + if (proc->u.i.cxt) { + gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt); + } } else { - gc_mark_object(pic, (struct pic_object *)proc->u.func.name); + gc_mark_object(pic, (struct pic_object *)proc->u.f.name); + if (proc->u.f.env) { + gc_mark_object(pic, (struct pic_object *)proc->u.f.env); + } } break; } diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index 472dfe8a..caa49cc6 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -9,12 +9,6 @@ extern "C" { #endif -/* native C function */ -struct pic_func { - pic_func_t f; - pic_sym *name; -}; - struct pic_context { PIC_OBJECT_HEADER pic_value *regs; @@ -25,19 +19,25 @@ struct pic_context { struct pic_proc { PIC_OBJECT_HEADER - char kind; + enum { + PIC_PROC_TAG_IREP, + PIC_PROC_TAG_FUNC + } tag; union { - struct pic_func func; - struct pic_irep *irep; + struct { + pic_func_t func; + pic_sym *name; + struct pic_dict *env; + } f; + struct { + struct pic_irep *irep; + struct pic_context *cxt; + } i; } u; - struct pic_context *cxt; }; -#define PIC_PROC_KIND_FUNC 1 -#define PIC_PROC_KIND_IREP 2 - -#define pic_proc_func_p(proc) ((proc)->kind == PIC_PROC_KIND_FUNC) -#define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP) +#define pic_proc_func_p(proc) ((proc)->tag == PIC_PROC_TAG_FUNC) +#define pic_proc_irep_p(proc) ((proc)->tag == PIC_PROC_TAG_IREP) #define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC) #define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o)) @@ -49,6 +49,9 @@ struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *); struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_context *); pic_sym *pic_proc_name(struct pic_proc *); +struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *); +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); #if defined(__cplusplus) } diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 71b3195a..d730c909 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -15,10 +15,10 @@ pic_make_proc(pic_state *pic, pic_func_t func, const char *name) sym = pic_intern_cstr(pic, name); proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_FUNC; - proc->u.func.f = func; - proc->u.func.name = sym; - proc->cxt = NULL; + proc->tag = PIC_PROC_TAG_FUNC; + proc->u.f.func = func; + proc->u.f.name = sym; + proc->u.f.env = NULL; return proc; } @@ -28,24 +28,47 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cx struct pic_proc *proc; proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_IREP; - proc->u.irep = irep; - proc->cxt = cxt; + proc->tag = PIC_PROC_TAG_IREP; + proc->u.i.irep = irep; + proc->u.i.cxt = cxt; return proc; } pic_sym * pic_proc_name(struct pic_proc *proc) { - switch (proc->kind) { - case PIC_PROC_KIND_FUNC: - return proc->u.func.name; - case PIC_PROC_KIND_IREP: - return proc->u.irep->name; + switch (proc->tag) { + case PIC_PROC_TAG_FUNC: + return proc->u.f.name; + case PIC_PROC_TAG_IREP: + return proc->u.i.irep->name; } PIC_UNREACHABLE(); } +struct pic_dict * +pic_proc_env(pic_state *pic, struct pic_proc *proc) +{ + assert(pic_proc_func_p(proc)); + + if (! proc->u.f.env) { + proc->u.f.env = pic_make_dict(pic); + } + return proc->u.f.env; +} + +pic_value +pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key) +{ + return pic_dict_ref(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key)); +} + +void +pic_proc_env_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value val) +{ + pic_dict_set(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key), val); +} + static pic_value pic_proc_proc_p(pic_state *pic) { diff --git a/extlib/benz/var.c b/extlib/benz/var.c index e1b7ff06..6ef88ece 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -5,12 +5,13 @@ #include "picrin.h" static pic_value -var_lookup(pic_state *pic, pic_value var) +var_lookup(pic_state *pic, struct pic_proc *var) { 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, var)) { + if (pic_eq_p(val, key)) { return pic_false_value(); } @@ -19,7 +20,7 @@ var_lookup(pic_state *pic, pic_value var) binding = pic_car(pic, env); while (! pic_nil_p(binding)) { - if (pic_eq_p(pic_caar(pic, binding), var)) { + if (pic_eq_p(pic_caar(pic, binding), key)) { return pic_car(pic, binding); } binding = pic_cdr(pic, binding); @@ -39,9 +40,9 @@ var_call(pic_state *pic) n = pic_get_args(pic, "|oo", &val, &tmp); - box = var_lookup(pic, pic_obj_value(self)); + box = var_lookup(pic, self); if (! pic_test(box)) { - box = pic_attr_ref(pic, pic_obj_value(self), "@@box"); + box = pic_proc_env_ref(pic, self, "box"); } switch (n) { @@ -49,7 +50,7 @@ var_call(pic_state *pic) return pic_cdr(pic, box); case 1: - conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); + conv = pic_proc_env_ref(pic, self, "conv"); if (pic_test(conv)) { pic_assert_type(pic, conv, proc); @@ -62,7 +63,7 @@ var_call(pic_state *pic) case 2: assert(pic_false_p(tmp)); - conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); + conv = pic_proc_env_ref(pic, self, "conv"); if (pic_test(conv)) { pic_assert_type(pic, conv, proc); @@ -80,8 +81,8 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) struct pic_proc *var; var = pic_make_proc(pic, var_call, ""); - pic_attr_set(pic, pic_obj_value(var), "@@box", pic_cons(pic, pic_false_value(), init)); - pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); + 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()); return var; } diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 9d26ee6b..91cedab6 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -524,7 +524,7 @@ vm_get_irep(pic_state *pic) if (! pic_proc_p(self)) { pic_errorf(pic, "logic flaw"); } - irep = pic_proc_ptr(self)->u.irep; + irep = pic_proc_ptr(self)->u.i.irep; if (! pic_proc_irep_p(pic_proc_ptr(self))) { pic_errorf(pic, "logic flaw"); } @@ -642,12 +642,12 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 } \ puts(")"); \ if (! pic_proc_func_p(proc)) { \ - printf(" irep = %p\n", proc->u.irep); \ + printf(" irep = %p\n", proc->u.i.irep); \ printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ - pic_dump_irep(proc->u.irep); \ + pic_dump_irep(proc->u.i.irep); \ } \ else { \ - printf(" cfunc = %p\n", (void *)proc->u.func.f); \ + printf(" cfunc = %p\n", (void *)proc->u.f.func); \ printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ } \ puts("== end\n"); \ @@ -765,7 +765,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) struct pic_irep *irep; if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { - irep = pic_get_proc(pic)->u.irep; + irep = pic_get_proc(pic)->u.i.irep; if (c.u.i >= irep->argc + irep->localc) { PUSH(ci->cxt->regs[c.u.i - (ci->regs - ci->fp)]); NEXT; @@ -779,7 +779,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) struct pic_irep *irep; if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) { - irep = pic_get_proc(pic)->u.irep; + irep = pic_get_proc(pic)->u.i.irep; if (c.u.i >= irep->argc + irep->localc) { ci->cxt->regs[c.u.i - (ci->regs - ci->fp)] = POP(); NEXT; @@ -862,7 +862,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) if (pic_proc_func_p(pic_proc_ptr(x))) { /* invoke! */ - v = proc->u.func.f(pic); + v = proc->u.f.func(pic); pic->sp[0] = v; pic->sp += pic->ci->retc; @@ -870,7 +870,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) goto L_RET; } else { - struct pic_irep *irep = proc->u.irep; + struct pic_irep *irep = proc->u.i.irep; int i; pic_value rest; @@ -900,7 +900,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) } /* prepare cxt */ - ci->up = proc->cxt; + if (pic_proc_irep_p(proc)) { + ci->up = proc->u.i.cxt; + } else { + ci->up = NULL; + } ci->regc = irep->capturec; ci->regs = ci->fp + irep->argc + irep->localc; @@ -969,7 +973,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) if (! pic_proc_p(self)) { pic_errorf(pic, "logic flaw"); } - irep = pic_proc_ptr(self)->u.irep; + irep = pic_proc_ptr(self)->u.i.irep; if (! pic_proc_irep_p(pic_proc_ptr(self))) { pic_errorf(pic, "logic flaw"); }