diff --git a/include/picrin/irep.h b/include/picrin/irep.h index de0b8e80..4cb1cfba 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -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; diff --git a/include/picrin/proc.h b/include/picrin/proc.h index fc8c39cf..86e11121 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -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 *); diff --git a/src/codegen.c b/src/codegen.c index d72217f3..9ab47032 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -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); diff --git a/src/cont.c b/src/cont.c index 9ee93c60..6248a503 100644 --- a/src/cont.c +++ b/src/cont.c @@ -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, ""); /* 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, ""); /* save the continuation object in proc */ pic_proc_cv_init(pic, c, 1); diff --git a/src/macro.c b/src/macro.c index e11fd3ed..5db52872 100644 --- a/src/macro.c +++ b/src/macro.c @@ -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, ""); 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, ""); 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, ""); 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, ""); 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, ""); 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, ""); 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, "")); pic_deflibrary ("(picrin macro)") { diff --git a/src/proc.c b/src/proc.c index eea16bc1..d4c73d7a 100644 --- a/src/proc.c +++ b/src/proc.c @@ -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, ""); 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); diff --git a/src/var.c b/src/var.c index 6aa4e18a..a779ddff 100644 --- a/src/var.c +++ b/src/var.c @@ -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, ""); pic_proc_cv_init(pic, proc, 1); pic_proc_cv_set(pic, proc, 0, pic_obj_value(var)); return proc; diff --git a/src/vm.c b/src/vm.c index be3fe654..760a63eb 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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