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

add pic_closure_ref, pic_closure_set, and pic_lambda

This commit is contained in:
Yuichi Nishiwaki 2016-02-14 22:23:14 +09:00
parent 8814469eac
commit f70dd4d376
12 changed files with 105 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
contrib/10.callcc/callcc.c
View File

@ -218,14 +218,13 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
PIC_NORETURN static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *self;
int argc;
pic_value *argv;
struct pic_fullcont *cont;
pic_get_args(pic, "&*", &self, &argc, &argv);
pic_get_args(pic, "*", &argc, &argv);
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "cont"))->data;
cont = pic_data_ptr(pic_closure_ref(pic, 0))->data;
cont->results = pic_list_by_array(pic, argc, argv);
/* execute guard handlers */
@ -245,14 +244,9 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc)
}
else {
struct pic_proc *c;
struct pic_data *dat;
c = pic_make_proc(pic, cont_call);
dat = pic_data_alloc(pic, &cont_type, cont);
/* save the continuation object in proc */
pic_proc_env_set(pic, c, "cont", pic_obj_value(dat));
c = pic_lambda(pic, cont_call, 1, pic_obj_value(pic_data_alloc(pic, &cont_type, cont)));
return pic_call(pic, proc, 1, pic_obj_value(c));
}
@ -272,15 +266,10 @@ pic_callcc_callcc(pic_state *pic)
}
else {
struct pic_proc *c;
struct pic_data *dat;
pic_value args[1];
c = pic_make_proc(pic, cont_call);
dat = pic_data_alloc(pic, &cont_type, cont);
/* save the continuation object in proc */
pic_proc_env_set(pic, c, "cont", pic_obj_value(dat));
c = pic_lambda(pic, cont_call, 1, pic_obj_value(pic_data_alloc(pic, &cont_type, cont)));
args[0] = pic_obj_value(c);
return pic_applyk(pic, proc, 1, args);
@ -288,7 +277,7 @@ pic_callcc_callcc(pic_state *pic)
}
#define pic_redefun(pic, lib, name, func) \
pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func)))
pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func, 0, NULL)))
void
pic_init_callcc(pic_state *pic)

2
contrib/40.srfi/src/106.c
View File

@ -399,7 +399,7 @@ pic_socket_call_with_socket(pic_state *pic)
void
pic_init_srfi_106(pic_state *pic)
{
#define pic_defun_(pic, name, f) pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, f)))
#define pic_defun_(pic, name, f) pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)))
#define pic_define_(pic, name, v) pic_define(pic, pic->lib, name, v)
pic_deflibrary (pic, "(srfi 106)") {

18
extlib/benz/cont.c
View File

@ -82,18 +82,20 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
pic->cc = cont->prev;
}
#define CV_ID 0
#define CV_ESCAPE 1
static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *self;
int argc;
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
pic_get_args(pic, "&*", &self, &argc, &argv);
pic_get_args(pic, "*", &argc, &argv);
id = pic_int(pic_proc_env_ref(pic, self, "id"));
id = pic_int(pic_closure_ref(pic, CV_ID));
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
@ -105,7 +107,7 @@ cont_call(pic_state *pic)
pic_errorf(pic, "calling dead escape continuation");
}
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
cont = pic_data_ptr(pic_closure_ref(pic, CV_ESCAPE))->data;
cont->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, cont);
@ -120,15 +122,9 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont)
{
static const pic_data_type cont_type = { "cont", NULL, NULL };
struct pic_proc *c;
struct pic_data *e;
c = pic_make_proc(pic, cont_call);
e = pic_data_alloc(pic, &cont_type, cont);
/* save the escape continuation in proc */
pic_proc_env_set(pic, c, "escape", pic_obj_value(e));
pic_proc_env_set(pic, c, "id", pic_int_value(cont->id));
c = pic_lambda(pic, cont_call, 2, pic_int_value(cont->id), pic_obj_value(pic_data_alloc(pic, &cont_type, cont)));
return c;
}

2
extlib/benz/error.c
View File

@ -56,7 +56,7 @@ pic_native_exception_handler(pic_state *pic)
pic->err = err;
cont = pic_proc_ptr(pic_proc_env_ref(pic, self, "cont"));
cont = pic_proc_ptr(pic_closure_ref(pic, 0));
pic_call(pic, cont, 1, pic_false_value());

5
extlib/benz/gc.c
View File

@ -302,8 +302,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
LOOP(obj->u.proc.u.i.cxt);
}
} else {
if (obj->u.proc.u.f.env) {
LOOP(obj->u.proc.u.f.env);
int i;
for (i = 0; i < obj->u.proc.u.f.localc; ++i) {
gc_mark(pic, obj->u.proc.locals[i]);
}
}
break;

8
extlib/benz/include/picrin.h
View File

@ -151,6 +151,8 @@ void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *);
void pic_define(pic_state *, struct pic_lib *, const char *, pic_value);
pic_value pic_ref(pic_state *, struct pic_lib *, const char *);
void pic_set(pic_state *, struct pic_lib *, const char *, pic_value);
pic_value pic_closure_ref(pic_state *, int);
void pic_closure_set(pic_state *, int, pic_value);
pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, int, ...);
struct pic_lib *pic_make_library(pic_state *, pic_value);
@ -161,13 +163,13 @@ void pic_export(pic_state *, pic_sym *);
PIC_NORETURN void pic_panic(pic_state *, const char *);
PIC_NORETURN void pic_errorf(pic_state *, const char *, ...);
struct pic_proc *pic_lambda(pic_state *, pic_func_t, int, ...);
struct pic_proc *pic_vlambda(pic_state *, pic_func_t, int, va_list);
pic_value pic_call(pic_state *, struct pic_proc *, int, ...);
pic_value pic_vcall(pic_state *, struct pic_proc *, int, va_list);
pic_value pic_apply(pic_state *, struct pic_proc *, int, pic_value *);
pic_value pic_applyk(pic_state *, struct pic_proc *, int, pic_value *);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
bool pic_eq_p(pic_value, pic_value);
bool pic_eqv_p(pic_value, pic_value);
bool pic_equal_p(pic_state *, pic_value, pic_value);
@ -208,6 +210,8 @@ pic_value pic_read_cstr(pic_state *, const char *);
void pic_load(pic_state *, struct pic_port *);
void pic_load_cstr(pic_state *, const char *);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
#define pic_deflibrary(pic, spec) \

3
extlib/benz/include/picrin/error.h
View File

@ -35,8 +35,7 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_value
if (PIC_SETJMP(pic, cont.jmp) == 0) { \
extern pic_value pic_native_exception_handler(pic_state *); \
struct pic_proc *handler; \
handler = pic_make_proc(pic, pic_native_exception_handler); \
pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, &cont))); \
handler = pic_lambda(pic, pic_native_exception_handler, 1, pic_obj_value(pic_make_cont(pic, &cont))); \
do { \
pic_push_handler(pic, handler);
#define pic_catch_(label) \

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

@ -26,13 +26,14 @@ struct pic_proc {
union {
struct {
pic_func_t func;
struct pic_dict *env;
int localc;
} f;
struct {
struct pic_irep *irep;
struct pic_context *cxt;
} i;
} u;
pic_value locals[1];
};
#define pic_proc_func_p(proc) ((proc)->tag == PIC_PROC_TAG_FUNC)
@ -44,14 +45,9 @@ struct pic_proc {
#define pic_context_p(o) (pic_type(o) == PIC_TT_CXT)
#define pic_context_ptr(o) ((struct pic_context *)pic_ptr(o))
struct pic_proc *pic_make_proc(pic_state *, pic_func_t);
struct pic_proc *pic_make_proc(pic_state *, pic_func_t, int, pic_value *);
struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_context *);
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);
#if defined(__cplusplus)
}
#endif

2
extlib/benz/port.c
View File

@ -163,7 +163,7 @@ pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir)
port->file = file;
port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN;
pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port));
pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port, 0, NULL));
}
#define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \

101
extlib/benz/proc.c
View File

@ -200,7 +200,7 @@ vm_push_cxt(pic_state *pic)
{
pic_callinfo *ci = pic->ci;
ci->cxt = (struct pic_context *)pic_obj_alloc(pic, sizeof(struct pic_context) + sizeof(pic_value) * ci->regc, PIC_TT_CXT);
ci->cxt = (struct pic_context *)pic_obj_alloc(pic, offsetof(struct pic_context, storage) + sizeof(pic_value) * ci->regc, PIC_TT_CXT);
ci->cxt->up = ci->up;
ci->cxt->regc = ci->regc;
ci->cxt->regs = ci->regs;
@ -836,6 +836,30 @@ pic_vcall(pic_state *pic, struct pic_proc *proc, int n, va_list ap)
return pic_apply(pic, proc, n, args);
}
struct pic_proc *
pic_lambda(pic_state *pic, pic_func_t f, int n, ...)
{
struct pic_proc *proc;
va_list ap;
va_start(ap, n);
proc = pic_vlambda(pic, f, n, ap);
va_end(ap);
return proc;
}
struct pic_proc *
pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap)
{
pic_value *env = pic_alloca(pic, sizeof(pic_value) * n);
int i;
for (i = 0; i < n; ++i) {
env[i] = va_arg(ap, pic_value);
}
return pic_make_proc(pic, f, n, env);
}
void
pic_define(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
{
@ -855,9 +879,9 @@ pic_define(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
}
void
pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
pic_defun(pic_state *pic, const char *name, pic_func_t f)
{
pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, cfunc)));
pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)));
pic_export(pic, pic_intern_cstr(pic, name));
}
@ -896,6 +920,36 @@ pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
vm_gset(pic, uid, val);
}
pic_value
pic_closure_ref(pic_state *pic, int n)
{
struct pic_proc *self;
self = pic_proc_ptr(GET_OPERAND(pic, 0));
assert(pic_proc_func_p(self));
if (n < 0 || self->u.f.localc <= n) {
pic_errorf(pic, "pic_closure_ref: index out of range (%d)", n);
}
return pic_proc_ptr(GET_OPERAND(pic, 0))->locals[n];
}
void
pic_closure_set(pic_state *pic, int n, pic_value v)
{
struct pic_proc *self;
self = pic_proc_ptr(GET_OPERAND(pic, 0));
assert(pic_proc_func_p(self));
if (n < 0 || self->u.f.localc <= n) {
pic_errorf(pic, "pic_closure_ref: index out of range (%d)", n);
}
pic_proc_ptr(GET_OPERAND(pic, 0))->locals[n] = v;
}
pic_value
pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, int n, ...)
{
@ -943,14 +997,18 @@ pic_irep_decref(pic_state *pic, struct pic_irep *irep)
}
struct pic_proc *
pic_make_proc(pic_state *pic, pic_func_t func)
pic_make_proc(pic_state *pic, pic_func_t func, int n, pic_value *env)
{
struct pic_proc *proc;
int i;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc = (struct pic_proc *)pic_obj_alloc(pic, offsetof(struct pic_proc, locals) + sizeof(pic_value) * n, PIC_TT_PROC);
proc->tag = PIC_PROC_TAG_FUNC;
proc->u.f.func = func;
proc->u.f.env = NULL;
proc->u.f.localc = n;
for (i = 0; i < n; ++i) {
proc->locals[i] = env[i];
}
return proc;
}
@ -959,7 +1017,7 @@ 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 = (struct pic_proc *)pic_obj_alloc(pic, offsetof(struct pic_proc, locals), PIC_TT_PROC);
proc->tag = PIC_PROC_TAG_IREP;
proc->u.i.irep = irep;
proc->u.i.cxt = cxt;
@ -967,35 +1025,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cx
return proc;
}
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;
}
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)
{
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)
{

23
extlib/benz/var.c
View File

@ -4,15 +4,6 @@
#include "picrin.h"
static pic_value
var_conv(pic_state *pic, struct pic_proc *var, pic_value val)
{
if (pic_proc_env_has(pic, var, "conv") != 0) {
return pic_call(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), 1, val);
}
return val;
}
static pic_value
var_get(pic_state *pic, struct pic_proc *var)
{
@ -52,7 +43,13 @@ var_call(pic_state *pic)
if (n == 0) {
return var_get(pic, self);
} else {
return var_set(pic, self, var_conv(pic, self, val));
pic_value conv;
conv = pic_closure_ref(pic, 0);
if (! pic_false_p(conv)) {
val = pic_call(pic, pic_proc_ptr(conv), 1, val);
}
return var_set(pic, self, val);
}
}
@ -60,12 +57,12 @@ struct pic_proc *
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_value c = pic_false_value();
if (conv != NULL) {
pic_proc_env_set(pic, var, "conv", pic_obj_value(conv));
c = pic_obj_value(conv);
}
var = pic_lambda(pic, var_call, 1, c);
pic_call(pic, var, 1, init);

9
extlib/benz/weak.c
View File

@ -115,7 +115,7 @@ weak_call(pic_state *pic)
pic_errorf(pic, "attempted to set a non-object key '~s' in an ephemeron", key);
}
weak = pic_weak_ptr(pic_proc_env_ref(pic, self, "weak"));
weak = pic_weak_ptr(pic_closure_ref(pic, 0));
if (n == 1) {
return weak_get(pic, weak, pic_obj_ptr(key));
@ -127,16 +127,11 @@ weak_call(pic_state *pic)
static pic_value
pic_weak_make_ephemeron(pic_state *pic)
{
struct pic_weak *weak;
struct pic_proc *proc;
pic_get_args(pic, "");
weak = pic_make_weak(pic);
proc = pic_make_proc(pic, weak_call);
pic_proc_env_set(pic, proc, "weak", pic_obj_value(weak));
proc = pic_lambda(pic, weak_call, 1, pic_obj_value(pic_make_weak(pic)));
return pic_obj_value(proc);
}