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

Merge branch 'record-procedure-name'

This commit is contained in:
Yuichi Nishiwaki 2014-03-28 12:35:09 +09:00
parent fbbbf7b019 cf1e1a8746
commit dec4ddc125
8 changed files with 60 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
include/picrin/irep.h
View File

@ -60,6 +60,7 @@ struct pic_code {
struct pic_irep {
PIC_OBJECT_HEADER
pic_sym name;
pic_code *code;
int argc, localc, capturec;
bool varg;

4
include/picrin/proc.h
View File

@ -45,9 +45,11 @@ struct pic_proc {
#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o))
#define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o))
struct pic_proc *pic_proc_new(pic_state *, pic_func_t);
struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *);
struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_env *);
pic_sym pic_proc_name(struct pic_proc *);
/* closed variables accessor */
void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t);
int pic_proc_cv_size(pic_state *, struct pic_proc *);

40
src/codegen.c
View File

@ -343,11 +343,13 @@ analyze_var(analyze_state *state, pic_sym sym)
}
static pic_value
analyze_procedure(analyze_state *state, pic_value formals, pic_value body_exprs)
analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs)
{
pic_state *pic = state->pic;
pic_value args, locals, varg, captures, body;
assert(pic_sym_p(name) || pic_false_p(name));
if (push_scope(state, formals)) {
analyze_scope *scope = state->scope;
pic_sym *var;
@ -384,7 +386,7 @@ analyze_procedure(analyze_state *state, pic_value formals, pic_value body_exprs)
pic_errorf(pic, "invalid formal syntax: ~s", args);
}
return pic_list6(pic, pic_sym_value(pic->sLAMBDA), args, locals, varg, captures, body);
return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body);
}
static pic_value
@ -400,7 +402,7 @@ analyze_lambda(analyze_state *state, pic_value obj)
formals = pic_list_ref(pic, obj, 1);
body_exprs = pic_list_tail(pic, obj, 2);
return analyze_procedure(state, formals, body_exprs);
return analyze_procedure(state, pic_false_value(), formals, body_exprs);
}
static pic_value
@ -439,7 +441,7 @@ analyze_define(analyze_state *state, pic_value obj)
formals = pic_list_tail(pic, pic_list_ref(pic, obj, 1), 1);
body_exprs = pic_list_tail(pic, obj, 2);
val = analyze_procedure(state, formals, body_exprs);
val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs);
} else {
if (pic_length(pic, obj) != 3) {
pic_error(pic, "syntax error");
@ -844,8 +846,9 @@ pic_analyze(pic_state *pic, pic_value obj)
*/
typedef struct codegen_context {
bool varg;
pic_sym name;
/* rest args variable is counted as a local */
bool varg;
xvect args, locals, captures;
/* actual bit code sequence */
pic_code *code;
@ -872,7 +875,7 @@ typedef struct codegen_state {
pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
} codegen_state;
static void push_codegen_context(codegen_state *, pic_value, pic_value, bool, pic_value);
static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value);
static struct pic_irep *pop_codegen_context(codegen_state *);
static codegen_state *
@ -893,7 +896,7 @@ new_codegen_state(pic_state *pic)
register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
push_codegen_context(state, pic_nil_value(), pic_nil_value(), false, pic_nil_value());
push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value());
return state;
}
@ -951,14 +954,19 @@ create_activation(codegen_context *cxt)
}
static void
push_codegen_context(codegen_state *state, pic_value args, pic_value locals, bool varg, pic_value captures)
push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures)
{
pic_state *pic = state->pic;
codegen_context *cxt;
pic_value var;
assert(pic_sym_p(name) || pic_false_p(name));
cxt = pic_alloc(pic, sizeof(codegen_context));
cxt->up = state->cxt;
cxt->name = pic_false_p(name)
? pic_intern_cstr(pic, "(anonymous lambda)")
: pic_sym(name);
cxt->varg = varg;
xv_init(&cxt->args, sizeof(pic_sym));
@ -1001,6 +1009,7 @@ pop_codegen_context(codegen_state *state)
/* create irep */
irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP);
irep->name = state->cxt->name;
irep->varg = state->cxt->varg;
irep->argc = state->cxt->args.size + 1;
irep->localc = state->cxt->locals.size;
@ -1392,17 +1401,18 @@ static struct pic_irep *
codegen_lambda(codegen_state *state, pic_value obj)
{
pic_state *pic = state->pic;
pic_value args, locals, closes, body;
pic_value name, args, locals, closes, body;
bool varg;
args = pic_list_ref(pic, obj, 1);
locals = pic_list_ref(pic, obj, 2);
varg = pic_true_p(pic_list_ref(pic, obj, 3));
closes = pic_list_ref(pic, obj, 4);
body = pic_list_ref(pic, obj, 5);
name = pic_list_ref(pic, obj, 1);
args = pic_list_ref(pic, obj, 2);
locals = pic_list_ref(pic, obj, 3);
varg = pic_true_p(pic_list_ref(pic, obj, 4));
closes = pic_list_ref(pic, obj, 5);
body = pic_list_ref(pic, obj, 6);
/* inner environment */
push_codegen_context(state, args, locals, varg, closes);
push_codegen_context(state, name, args, locals, varg, closes);
{
/* body */
codegen(state, body);

4
src/cont.c
View File

@ -219,7 +219,7 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
else {
struct pic_proc *c;
c = pic_proc_new(pic, cont_call);
c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
/* save the continuation object in proc */
pic_proc_cv_init(pic, c, 1);
@ -241,7 +241,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
else {
struct pic_proc *c;
c = pic_proc_new(pic, cont_call);
c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
/* save the continuation object in proc */
pic_proc_cv_init(pic, c, 1);

14
src/macro.c
View File

@ -764,12 +764,12 @@ er_macro_call(pic_state *pic)
pic_error(pic, "unexpected type of argument 3");
}
rename = pic_proc_new(pic, er_macro_rename);
rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
pic_proc_cv_init(pic, rename, 2);
pic_proc_cv_set(pic, rename, 0, use_env);
pic_proc_cv_set(pic, rename, 1, mac_env);
compare = pic_proc_new(pic, er_macro_compare);
compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
pic_proc_cv_init(pic, compare, 2);
pic_proc_cv_set(pic, compare, 0, use_env);
pic_proc_cv_set(pic, compare, 1, mac_env);
@ -786,7 +786,7 @@ pic_macro_er_macro_transformer(pic_state *pic)
pic_get_args(pic, "l", &cb);
proc = pic_proc_new(pic, er_macro_call);
proc = pic_proc_new(pic, er_macro_call, "<er-macro-procedure>");
pic_proc_cv_init(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
@ -887,12 +887,12 @@ ir_macro_call(pic_state *pic)
pic_error(pic, "unexpected type of argument 3");
}
inject = pic_proc_new(pic, ir_macro_inject);
inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
pic_proc_cv_init(pic, inject, 2);
pic_proc_cv_set(pic, inject, 0, use_env);
pic_proc_cv_set(pic, inject, 1, mac_env);
compare = pic_proc_new(pic, ir_macro_compare);
compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
pic_proc_cv_init(pic, compare, 2);
pic_proc_cv_set(pic, compare, 0, use_env);
pic_proc_cv_set(pic, compare, 1, mac_env);
@ -912,7 +912,7 @@ pic_macro_ir_macro_transformer(pic_state *pic)
pic_get_args(pic, "l", &cb);
proc = pic_proc_new(pic, ir_macro_call);
proc = pic_proc_new(pic, ir_macro_call, "<ir-macro-procedure>");
pic_proc_cv_init(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
@ -922,7 +922,7 @@ pic_macro_ir_macro_transformer(pic_state *pic)
void
pic_init_macro(pic_state *pic)
{
pic_defmacro(pic, "include", pic_proc_new(pic, pic_macro_include));
pic_defmacro(pic, "include", pic_proc_new(pic, pic_macro_include, "<include-procedure>"));
pic_deflibrary ("(picrin macro)") {

20
src/proc.c
View File

@ -8,14 +8,16 @@
#include "picrin/irep.h"
struct pic_proc *
pic_proc_new(pic_state *pic, pic_func_t func)
pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
{
struct pic_proc *proc;
assert(name != NULL);
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 = pic_intern_cstr(pic, "(no name)");
proc->u.func.name = pic_intern_cstr(pic, name);
proc->env = NULL;
return proc;
}
@ -32,6 +34,18 @@ pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
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;
}
UNREACHABLE();
}
void
pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
{
@ -95,7 +109,7 @@ pic_papply(pic_state *pic, struct pic_proc *proc, pic_value arg)
{
struct pic_proc *pa_proc;
pa_proc = pic_proc_new(pic, papply_call);
pa_proc = pic_proc_new(pic, papply_call, "<partial-applied-procedure>");
pic_proc_cv_init(pic, pa_proc, 2);
pic_proc_cv_set(pic, pa_proc, 0, pic_obj_value(proc));
pic_proc_cv_set(pic, pa_proc, 1, arg);

2
src/var.c
View File

@ -100,7 +100,7 @@ pic_wrap_var(pic_state *pic, struct pic_var *var)
{
struct pic_proc *proc;
proc = pic_proc_new(pic, var_call);
proc = pic_proc_new(pic, var_call, "<var-procedure>");
pic_proc_cv_init(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(var));
return proc;

6
src/vm.c
View File

@ -409,7 +409,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
{
struct pic_proc *proc;
proc = pic_proc_new(pic, cfunc);
proc = pic_proc_new(pic, cfunc, name);
pic_define(pic, name, pic_obj_value(proc));
}
@ -686,11 +686,13 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
}
puts(")");
if (! pic_proc_func_p(proc)) {
printf(" irep = ");
printf(" irep = %p\n", proc->u.irep);
printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc)));
pic_dump_irep(proc->u.irep);
}
else {
printf(" cfunc = %p\n", (void *)proc->u.func.f);
printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc)));
}
puts("== end\n");
#endif