Merge branch 'proc_env'

contrib/03.callcc/callcc.c

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

extlib/benz/cont.c

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

extlib/benz/error.c

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

extlib/benz/gc.c

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

extlib/benz/include/picrin/proc.h

@@ -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 {
-    struct pic_irep *irep;
+      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_func_p(proc) ((proc)->tag == PIC_PROC_TAG_FUNC)
-#define PIC_PROC_KIND_IREP 2
+#define pic_proc_irep_p(proc) ((proc)->tag == PIC_PROC_TAG_IREP)
-
-#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_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)
 }

extlib/benz/proc.c

@@ -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->tag = PIC_PROC_TAG_FUNC;
-  proc->u.func.f = func;
+  proc->u.f.func = func;
-  proc->u.func.name = sym;
+  proc->u.f.name = sym;
-  proc->cxt = NULL;
+  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->tag = PIC_PROC_TAG_IREP;
-  proc->u.irep = irep;
+  proc->u.i.irep = irep;
-  proc->cxt = cxt;
+  proc->u.i.cxt = cxt;
   return proc;
 }
 
 pic_sym *
 pic_proc_name(struct pic_proc *proc)
 {
-  switch (proc->kind) {
+  switch (proc->tag) {
-  case PIC_PROC_KIND_FUNC:
+  case PIC_PROC_TAG_FUNC:
-    return proc->u.func.name;
+    return proc->u.f.name;
-  case PIC_PROC_KIND_IREP:
+  case PIC_PROC_TAG_IREP:
-    return proc->u.irep->name;
+    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)
 {

extlib/benz/var.c

@@ -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_proc_env_set(pic, 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, "conv", conv ? pic_obj_value(conv) : pic_false_value());
 
   return var;
 }

extlib/benz/vm.c

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