conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'proc_env'

This commit is contained in:
Yuichi Nishiwaki 2015-06-02 07:30:31 +09:00
parent 65dc4020f4 8f891c00c6
commit bc4b112d8e
8 changed files with 92 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
contrib/03.callcc/callcc.c
View File

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

4
extlib/benz/cont.c
View File

@ -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;
}

4
extlib/benz/error.c
View File

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

13
extlib/benz/gc.c
View File

@ -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;
}

33
extlib/benz/include/picrin/proc.h
View File

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

47
extlib/benz/proc.c
View File

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

19
extlib/benz/var.c
View File

@ -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, "<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;
}

24
extlib/benz/vm.c
View File

@ -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");
}