Merge branch 'registry'

extlib/benz/attr.c

@@ -3,21 +3,20 @@
 struct pic_dict *
 pic_attr(pic_state *pic, pic_value obj)
 {
-  xh_entry *e;
+  struct pic_dict *dict;
 
-  if (pic_vtype(obj) != PIC_VTYPE_HEAP) {
+  if (! pic_obj_p(obj)) {
     pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
   }
 
-  e = xh_get_ptr(&pic->attrs, pic_ptr(obj));
+  if (! pic_reg_has(pic, pic->attrs, pic_ptr(obj))) {
-  if (e == NULL) {
+    dict = pic_make_dict(pic);
-    struct pic_dict *dict = pic_make_dict(pic);
 
-    e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict);
+    pic_reg_set(pic, pic->attrs, pic_ptr(obj), pic_obj_value(dict));
 
-    assert(dict == xh_val(e, struct pic_dict *));
+    return dict;
   }
-  return xh_val(e, struct pic_dict *);
+  return pic_dict_ptr(pic_reg_ref(pic, pic->attrs, pic_ptr(obj)));
 }
 
 pic_value

extlib/benz/gc.c

@@ -317,6 +317,12 @@ gc_obj_is_marked(struct pic_object *obj)
   return gc_is_marked(p);
 }
 
+static bool
+gc_value_need_mark(pic_value value)
+{
+  return pic_obj_p(value) && (! gc_obj_is_marked(pic_obj_ptr(value)));
+}
+
 static void
 gc_unmark(union header *p)
 {
@@ -473,6 +479,13 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     gc_mark_object(pic, (struct pic_object *)sym->str);
     break;
   }
+  case PIC_TT_REG: {
+    struct pic_reg *reg = (struct pic_reg *)obj;
+
+    reg->prev = pic->regs;
+    pic->regs = reg;
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
 #if PIC_ENABLE_FLOAT
@@ -536,8 +549,8 @@ gc_mark_phase(pic_state *pic)
   pic_callinfo *ci;
   struct pic_proc **xhandler;
   size_t j;
-  xh_entry *it;
+
-  struct pic_object *obj;
+  assert(pic->regs == NULL);
 
   /* checkpoint */
   if (pic->cp) {
@@ -579,6 +592,11 @@ gc_mark_phase(pic_state *pic)
     gc_mark_object(pic, (struct pic_object *)pic->macros);
   }
 
+  /* attribute table */
+  if (pic->attrs) {
+    gc_mark_object(pic, (struct pic_object *)pic->attrs);
+  }
+
   /* error object */
   gc_mark(pic, pic->err);
 
@@ -602,18 +620,26 @@ gc_mark_phase(pic_state *pic)
   /* parameter table */
   gc_mark(pic, pic->ptable);
 
-  /* attributes */
+  /* registries */
   do {
-    j = 0;
+    struct pic_object *key;
+    pic_value val;
+    xh_entry *it;
+    struct pic_reg *reg;
 
-    for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) {
+    j = 0;
-      if (gc_obj_is_marked(xh_key(it, struct pic_object *))) {
+    reg = pic->regs;
-        obj = (struct pic_object *)xh_val(it, struct pic_dict *);
+
-        if (! gc_obj_is_marked(obj)) {
+    while (reg != NULL) {
-          gc_mark_object(pic, obj);
+      for (it = xh_begin(&reg->hash); it != NULL; it = xh_next(it)) {
+        key = xh_key(it, struct pic_object *);
+        val = xh_val(it, pic_value);
+        if (gc_obj_is_marked(key) && gc_value_need_mark(val)) {
+          gc_mark(pic, val);
           ++j;
         }
       }
+      reg = reg->prev;
     }
   } while (j > 0);
 }
@@ -686,6 +712,11 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_SYMBOL: {
     break;
   }
+  case PIC_TT_REG: {
+    struct pic_reg *reg = (struct pic_reg *)obj;
+    xh_destroy(&reg->hash);
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
 #if PIC_ENABLE_FLOAT
@@ -782,14 +813,16 @@ gc_sweep_phase(pic_state *pic)
   struct heap_page *page = pic->heap->pages;
   xh_entry *it, *next;
 
-  do {
+  /* registries */
-    for (it = xh_begin(&pic->attrs); it != NULL; it = next) {
+  while (pic->regs != NULL) {
+    for (it = xh_begin(&pic->regs->hash); it != NULL; it = next) {
       next = xh_next(it);
       if (! gc_obj_is_marked(xh_key(it, struct pic_object *))) {
-        xh_del_ptr(&pic->attrs, xh_key(it, struct pic_object *));
+        xh_del_ptr(&pic->regs->hash, xh_key(it, struct pic_object *));
       }
     }
-  } while (it != NULL);
+    pic->regs = pic->regs->prev;
+  }
 
   gc_sweep_symbols(pic);
 

extlib/benz/include/picrin.h

@@ -92,6 +92,8 @@ typedef struct {
 
   pic_code *ip;
 
+  pic_value ptable;
+
   struct pic_lib *lib, *prev_lib;
 
   pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
@@ -128,10 +130,7 @@ typedef struct {
   struct pic_dict *globals;
   struct pic_dict *macros;
   pic_value libs;
-  xhash attrs;
+  struct pic_reg *attrs;
-
-  pic_value ptable;
-  size_t pnum;
 
   struct pic_reader *reader;
 
@@ -139,6 +138,7 @@ typedef struct {
   struct pic_heap *heap;
   struct pic_object **arena;
   size_t arena_size, arena_idx;
+  struct pic_reg *regs;
 
   struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR;
 
@@ -285,6 +285,7 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
 #include "picrin/symbol.h"
 #include "picrin/read.h"
 #include "picrin/vector.h"
+#include "picrin/reg.h"
 
 #if defined(__cplusplus)
 }

extlib/benz/include/picrin/reg.h

@@ -0,0 +1,32 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_REG_H
+#define PICRIN_REG_H
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+struct pic_reg {
+  PIC_OBJECT_HEADER
+  xhash hash;
+  struct pic_reg *prev;         /* for GC */
+};
+
+#define pic_reg_p(v) (pic_type(v) == PIC_TT_REG)
+#define pic_reg_ptr(v) ((struct pic_reg *)pic_ptr(v))
+
+struct pic_reg *pic_make_reg(pic_state *);
+
+pic_value pic_reg_ref(pic_state *, struct pic_reg *, void *);
+void pic_reg_set(pic_state *, struct pic_reg *, void *, pic_value);
+void pic_reg_del(pic_state *, struct pic_reg *, void *);
+bool pic_reg_has(pic_state *, struct pic_reg *, void *);
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

extlib/benz/include/picrin/value.h

@@ -163,6 +163,7 @@ enum pic_tt {
   PIC_TT_IREP,
   PIC_TT_DATA,
   PIC_TT_DICT,
+  PIC_TT_REG,
   PIC_TT_RECORD
 };
 
@@ -327,6 +328,8 @@ pic_type_repr(enum pic_tt tt)
     return "data";
   case PIC_TT_DICT:
     return "dict";
+  case PIC_TT_REG:
+    return "reg";
   case PIC_TT_RECORD:
     return "record";
   }

extlib/benz/reg.c

@@ -0,0 +1,121 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+
+struct pic_reg *
+pic_make_reg(pic_state *pic)
+{
+  struct pic_reg *reg;
+
+  reg = (struct pic_reg *)pic_obj_alloc(pic, sizeof(struct pic_reg), PIC_TT_REG);
+  reg->prev = NULL;
+  xh_init_ptr(&reg->hash, sizeof(pic_value));
+
+  return reg;
+}
+
+pic_value
+pic_reg_ref(pic_state *pic, struct pic_reg *reg, void *key)
+{
+  xh_entry *e;
+
+  e = xh_get_ptr(&reg->hash, key);
+  if (! e) {
+    pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
+  }
+  return xh_val(e, pic_value);
+}
+
+void
+pic_reg_set(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key, pic_value val)
+{
+  xh_put_ptr(&reg->hash, key, &val);
+}
+
+bool
+pic_reg_has(pic_state PIC_UNUSED(*pic), struct pic_reg *reg, void *key)
+{
+  return xh_get_ptr(&reg->hash, key) != NULL;
+}
+
+void
+pic_reg_del(pic_state *pic, struct pic_reg *reg, void *key)
+{
+  if (xh_get_ptr(&reg->hash, key) == NULL) {
+    pic_errorf(pic, "no slot named ~s found in registry", pic_obj_value(key));
+  }
+
+  xh_del_ptr(&reg->hash, key);
+}
+
+
+static pic_value
+reg_get(pic_state *pic, struct pic_reg *reg, void *key)
+{
+  if (! pic_reg_has(pic, reg, key)) {
+    return pic_undef_value();
+  }
+  return pic_reg_ref(pic, reg, key);
+}
+
+static pic_value
+reg_set(pic_state *pic, struct pic_reg *reg, void *key, pic_value val)
+{
+  if (pic_undef_p(val)) {
+    if (pic_reg_has(pic, reg, key)) {
+      pic_reg_del(pic, reg, key);
+    }
+  } else {
+    pic_reg_set(pic, reg, key, val);
+  }
+
+  return pic_undef_value();
+}
+
+static pic_value
+reg_call(pic_state *pic)
+{
+  struct pic_proc *self = pic_get_proc(pic);
+  struct pic_reg *reg;
+  pic_value key, val;
+  int n;
+
+  n = pic_get_args(pic, "o|o", &key, &val);
+
+  if (! pic_obj_p(key)) {
+    pic_errorf(pic, "attempted to set a non-object key '~s' in a registory", key);
+  }
+
+  reg = pic_reg_ptr(pic_proc_env_ref(pic, self, "reg"));
+
+  if (n == 1) {
+    return reg_get(pic, reg, pic_obj_ptr(key));
+  } else {
+    return reg_set(pic, reg, pic_obj_ptr(key), val);
+  }
+}
+
+static pic_value
+pic_reg_make_registry(pic_state *pic)
+{
+  struct pic_reg *reg;
+  struct pic_proc *proc;
+
+  pic_get_args(pic, "");
+
+  reg = pic_make_reg(pic);
+
+  proc = pic_make_proc(pic, reg_call, "<reg-call>");
+
+  pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg));
+
+  return pic_obj_value(proc);
+}
+
+void
+pic_init_reg(pic_state *pic)
+{
+  pic_defun(pic, "make-registry", pic_reg_make_registry);
+}

extlib/benz/state.c

@@ -32,6 +32,7 @@ void pic_init_record(pic_state *);
 void pic_init_eval(pic_state *);
 void pic_init_lib(pic_state *);
 void pic_init_attr(pic_state *);
+void pic_init_reg(pic_state *);
 
 extern const char pic_boot[][80];
 
@@ -130,6 +131,7 @@ pic_init_core(pic_state *pic)
     pic_init_eval(pic); DONE;
     pic_init_lib(pic); DONE;
     pic_init_attr(pic); DONE;
+    pic_init_reg(pic); DONE;
 
     pic_load_cstr(pic, &pic_boot[0][0]);
   }
@@ -205,6 +207,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   /* memory heap */
   pic->heap = pic_heap_open(pic);
 
+  /* registries */
+  pic->regs = NULL;
+
   /* symbol table */
   xh_init_str(&pic->syms, sizeof(pic_sym *));
 
@@ -215,7 +220,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   pic->macros = NULL;
 
   /* attributes */
-  xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
+  pic->attrs = NULL;
 
   /* features */
   pic->features = pic_nil_value();
@@ -234,7 +239,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
 
   /* parameter table */
   pic->ptable = pic_nil_value();
-  pic->pnum = 0;
 
   /* native stack marker */
   pic->native_stack_start = &t;
@@ -333,6 +337,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   /* root tables */
   pic->globals = pic_make_dict(pic);
   pic->macros = pic_make_dict(pic);
+  pic->attrs = pic_make_reg(pic);
 
   /* root block */
   pic->cp = pic_malloc(pic, sizeof(pic_checkpoint));
@@ -407,8 +412,8 @@ pic_close(pic_state *pic)
   pic->err = pic_invalid_value();
   pic->globals = NULL;
   pic->macros = NULL;
+  pic->attrs = NULL;
   xh_clear(&pic->syms);
-  xh_clear(&pic->attrs);
   pic->features = pic_nil_value();
   pic->libs = pic_nil_value();
 
@@ -428,7 +433,6 @@ pic_close(pic_state *pic)
 
   /* free global stacks */
   xh_destroy(&pic->syms);
-  xh_destroy(&pic->attrs);
 
   /* free GC arena */
   allocf(pic->arena, 0);

extlib/benz/var.c

@@ -17,15 +17,12 @@ static pic_value
 var_get(pic_state *pic, struct pic_proc *var)
 {
   pic_value elem, it;
-  pic_sym *id;
+  struct pic_reg *reg;
-  struct pic_dict *dict;
-
-  id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
 
   pic_for_each (elem, pic->ptable, it) {
-    dict = pic_dict_ptr(elem);
+    reg = pic_reg_ptr(elem);
-    if (pic_dict_has(pic, dict, id)) {
+    if (pic_reg_has(pic, reg, var)) {
-      return pic_dict_ref(pic, dict, id);
+      return pic_reg_ref(pic, reg, var);
     }
   }
   pic_panic(pic, "logic flaw");
@@ -34,14 +31,11 @@ var_get(pic_state *pic, struct pic_proc *var)
 static pic_value
 var_set(pic_state *pic, struct pic_proc *var, pic_value val)
 {
-  pic_sym *id;
+  struct pic_reg *reg;
-  struct pic_dict *dict;
 
-  id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
+  reg = pic_reg_ptr(pic_car(pic, pic->ptable));
 
-  dict = pic_dict_ptr(pic_car(pic, pic->ptable));
+  pic_reg_set(pic, reg, var, val);
-
-  pic_dict_set(pic, dict, id, val);
 
   return pic_undef_value();
 }
@@ -66,16 +60,12 @@ struct pic_proc *
 pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
 {
   struct pic_proc *var;
-  pic_value converter = conv ? pic_obj_value(conv) : pic_false_value();
-  pic_sym *id;
 
   var = pic_make_proc(pic, var_call, "<var-call>");
 
   if (conv != NULL) {
-    pic_proc_env_set(pic, var, "conv", converter);
+    pic_proc_env_set(pic, var, "conv", pic_obj_value(conv));
   }
-  id = pic_intern(pic, pic_format(pic, "%d", pic->pnum++));
-  pic_proc_env_set(pic, var, "id", pic_obj_value(id));
 
   pic_apply1(pic, var, init);
 
@@ -101,7 +91,7 @@ pic_var_with_parameter(pic_state *pic)
 
   pic_get_args(pic, "l", &body);
 
-  pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
+  pic->ptable = pic_cons(pic, pic_obj_value(pic_make_reg(pic)), pic->ptable);
 
   val = pic_apply0(pic, body);