add pic_closure_ref, pic_closure_set, and pic_lambda

contrib/10.callcc/callcc.c

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

contrib/40.srfi/src/106.c

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

extlib/benz/cont.c

@@ -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));
+  c = pic_lambda(pic, cont_call, 2, pic_int_value(cont->id), pic_obj_value(pic_data_alloc(pic, &cont_type, cont)));
-  pic_proc_env_set(pic, c, "id", pic_int_value(cont->id));
 
   return c;
 }

extlib/benz/error.c

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

extlib/benz/gc.c

@@ -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) {
+      int i;
-        LOOP(obj->u.proc.u.f.env);
+      for (i = 0; i < obj->u.proc.u.f.localc; ++i) {
+        gc_mark(pic, obj->u.proc.locals[i]);
       }
     }
     break;

extlib/benz/include/picrin.h

@@ -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)                                       \

extlib/benz/include/picrin/error.h

@@ -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);       \
+      handler = pic_lambda(pic, pic_native_exception_handler, 1, pic_obj_value(pic_make_cont(pic, &cont))); \
-      pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, &cont))); \
       do {                                                              \
         pic_push_handler(pic, handler);
 #define pic_catch_(label)                                 \

extlib/benz/include/picrin/proc.h

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

extlib/benz/port.c

@@ -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)        \

extlib/benz/proc.c

@@ -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)
 {

extlib/benz/var.c

@@ -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;
-
+  pic_value c = pic_false_value();
-  var = pic_make_proc(pic, var_call);
 
   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);
 

extlib/benz/weak.c

@@ -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_lambda(pic, weak_call, 1, pic_obj_value(pic_make_weak(pic)));
-
-  proc = pic_make_proc(pic, weak_call);
-
-  pic_proc_env_set(pic, proc, "weak", pic_obj_value(weak));
 
   return pic_obj_value(proc);
 }