Merge branch 'record-procedure-name'

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;

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 *);

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);
+  name = pic_list_ref(pic, obj, 1);
-  locals = pic_list_ref(pic, obj, 2);
+  args = pic_list_ref(pic, obj, 2);
-  varg = pic_true_p(pic_list_ref(pic, obj, 3));
+  locals = pic_list_ref(pic, obj, 3);
-  closes = pic_list_ref(pic, obj, 4);
+  varg = pic_true_p(pic_list_ref(pic, obj, 4));
-  body = pic_list_ref(pic, obj, 5);
+  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);

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, "<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);

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, "<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)") {
 

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, "<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);

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, "<var-procedure>");
   pic_proc_cv_init(pic, proc, 1);
   pic_proc_cv_set(pic, proc, 0, pic_obj_value(var));
   return proc;

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