Merge branch 'generalized-attribute'

attr.c

@@ -0,0 +1,50 @@
+#include "picrin.h"
+#include "picrin/dict.h"
+
+struct pic_dict *
+pic_attr(pic_state *pic, pic_value obj)
+{
+  xh_entry *e;
+
+  if (pic_vtype(obj) != PIC_VTYPE_HEAP) {
+    pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
+  }
+
+  e = xh_get_ptr(&pic->attrs, pic_ptr(obj));
+  if (e == NULL) {
+    struct pic_dict *dict = pic_make_dict(pic);
+
+    e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict);
+
+    assert(dict == xh_val(e, struct pic_dict *));
+  }
+  return xh_val(e, struct pic_dict *);
+}
+
+pic_value
+pic_attr_ref(pic_state *pic, pic_value obj, const char *key)
+{
+  return pic_dict_ref(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)));
+}
+
+void
+pic_attr_set(pic_state *pic, pic_value obj, const char *key, pic_value v)
+{
+  pic_dict_set(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)), v);
+}
+
+static pic_value
+pic_attr_attribute(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_obj_value(pic_attr(pic, obj));
+}
+
+void
+pic_init_attr(pic_state *pic)
+{
+  pic_defun(pic, "attribute", pic_attr_attribute);
+}

cont.c

@@ -102,7 +102,7 @@ escape_call(pic_state *pic)
 
   pic_get_args(pic, "*", &argc, &argv);
 
-  e = pic_data_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape"));
+  e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
 
   pic_load_point(pic, e->data);
 
@@ -121,7 +121,7 @@ pic_make_econt(pic_state *pic, struct pic_escape *escape)
   e = pic_data_alloc(pic, &escape_type, escape);
 
   /* save the escape continuation in proc */
-  pic_attr_set(pic, cont, "@@escape", pic_obj_value(e));
+  pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e));
 
   return cont;
 }

error.c

@@ -79,7 +79,7 @@ native_exception_handler(pic_state *pic)
 
   pic->err = err;
 
-  cont = pic_proc_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape"));
+  cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
 
   pic_apply1(pic, cont, pic_false_value());
 
@@ -96,7 +96,7 @@ pic_push_try(pic_state *pic, struct pic_escape *escape)
 
   handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)");
 
-  pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont));
+  pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont));
 
   if (pic->xp >= pic->xpend) {
     xp_len = (pic->xpend - pic->xpbase) * 2;
@@ -116,11 +116,11 @@ pic_pop_try(pic_state *pic)
 
   assert(pic->xp > pic->xpbase);
 
-  cont = pic_attr_ref(pic, *--pic->xp, "@@escape");
+  cont = pic_attr_ref(pic, pic_obj_value(*--pic->xp), "@@escape");
 
   assert(pic_proc_p(cont));
 
-  escape = pic_attr_ref(pic, pic_proc_ptr(cont), "@@escape");
+  escape = pic_attr_ref(pic, cont, "@@escape");
 
   assert(pic_data_p(escape));
 

gc.c

@@ -327,6 +327,16 @@ gc_is_marked(union header *p)
   return p->s.mark == PIC_GC_MARK;
 }
 
+static bool
+gc_obj_is_marked(struct pic_object *obj)
+{
+  union header *p;
+
+  p = ((union header *)obj) - 1;
+
+  return gc_is_marked(p);
+}
+
 static void
 gc_unmark(union header *p)
 {
@@ -381,9 +391,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     if (proc->env) {
       gc_mark_object(pic, (struct pic_object *)proc->env);
     }
-    if (proc->attr) {
-      gc_mark_object(pic, (struct pic_object *)proc->attr);
-    }
     if (pic_proc_irep_p(proc)) {
       gc_mark_object(pic, (struct pic_object *)proc->u.irep);
     }
@@ -528,6 +535,7 @@ gc_mark_phase(pic_state *pic)
   struct pic_proc **xhandler;
   size_t j;
   xh_entry *it;
+  struct pic_object *obj;
 
   /* winder */
   if (pic->wind) {
@@ -562,7 +570,7 @@ gc_mark_phase(pic_state *pic)
   }
 
   /* macro objects */
- for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) {
+  for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) {
     gc_mark_object(pic, xh_val(it, struct pic_object *));
   }
 
@@ -588,6 +596,21 @@ gc_mark_phase(pic_state *pic)
   if (pic->xSTDERR) {
     gc_mark_object(pic, (struct pic_object *)pic->xSTDERR);
   }
+
+  /* attributes */
+  do {
+    j = 0;
+
+    for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) {
+      if (gc_obj_is_marked(xh_key(it, struct pic_object *))) {
+        obj = (struct pic_object *)xh_val(it, struct pic_dict *);
+        if (! gc_obj_is_marked(obj)) {
+          gc_mark_object(pic, obj);
+          ++j;
+        }
+      }
+    }
+  } while (j > 0);
 }
 
 static void
@@ -730,6 +753,16 @@ static void
 gc_sweep_phase(pic_state *pic)
 {
   struct heap_page *page = pic->heap->pages;
+  xh_entry *it, *next;
+
+  do {
+    for (it = xh_begin(&pic->attrs); 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 *));
+      }
+    }
+  } while (it != NULL);
 
   while (page) {
     gc_sweep_page(pic, page);

include/picrin.h

@@ -111,6 +111,7 @@ typedef struct {
   xhash globals;
   xhash macros;
   pic_value libs;
+  xhash attrs;
 
   struct pic_reader *reader;
 
@@ -224,6 +225,10 @@ static inline void pic_warn(pic_state *pic, const char *msg)
   pic_warnf(pic, msg);
 }
 
+struct pic_dict *pic_attr(pic_state *, pic_value);
+pic_value pic_attr_ref(pic_state *, pic_value, const char *);
+void pic_attr_set(pic_state *, pic_value, const char *, pic_value);
+
 struct pic_port *pic_stdin(pic_state *);
 struct pic_port *pic_stdout(pic_state *);
 struct pic_port *pic_stderr(pic_state *);

include/picrin/proc.h

@@ -31,7 +31,6 @@ struct pic_proc {
     struct pic_irep *irep;
   } u;
   struct pic_env *env;
-  struct pic_dict *attr;
 };
 
 #define PIC_PROC_KIND_FUNC 1
@@ -51,10 +50,6 @@ struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_e
 
 pic_sym pic_proc_name(struct pic_proc *);
 
-struct pic_dict *pic_attr(pic_state *, struct pic_proc *);
-pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *);
-void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value);
-
 #if defined(__cplusplus)
 }
 #endif

init.c

@@ -38,6 +38,7 @@ void pic_init_dict(pic_state *);
 void pic_init_record(pic_state *);
 void pic_init_eval(pic_state *);
 void pic_init_lib(pic_state *);
+void pic_init_attr(pic_state *);
 
 extern const char pic_boot[];
 
@@ -138,6 +139,7 @@ pic_init_core(pic_state *pic)
     pic_init_record(pic); DONE;
     pic_init_eval(pic); DONE;
     pic_init_lib(pic); DONE;
+    pic_init_attr(pic); DONE;
 
     pic_load_cstr(pic, pic_boot);
   }

proc.c

@@ -6,7 +6,6 @@
 #include "picrin/pair.h"
 #include "picrin/proc.h"
 #include "picrin/irep.h"
-#include "picrin/dict.h"
 
 struct pic_proc *
 pic_make_proc(pic_state *pic, pic_func_t func, const char *name)
@@ -20,7 +19,6 @@ pic_make_proc(pic_state *pic, pic_func_t func, const char *name)
   proc->u.func.f = func;
   proc->u.func.name = pic_intern_cstr(pic, name);
   proc->env = NULL;
-  proc->attr = NULL;
   return proc;
 }
 
@@ -33,7 +31,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
   proc->kind = PIC_PROC_KIND_IREP;
   proc->u.irep = irep;
   proc->env = env;
-  proc->attr = NULL;
   return proc;
 }
 
@@ -49,27 +46,6 @@ pic_proc_name(struct pic_proc *proc)
   UNREACHABLE();
 }
 
-struct pic_dict *
-pic_attr(pic_state *pic, struct pic_proc *proc)
-{
-  if (proc->attr == NULL) {
-    proc->attr = pic_make_dict(pic);
-  }
-  return proc->attr;
-}
-
-pic_value
-pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
-{
-  return pic_dict_ref(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)));
-}
-
-void
-pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
-{
-  pic_dict_set(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)), v);
-}
-
 static pic_value
 pic_proc_proc_p(pic_state *pic)
 {
@@ -102,21 +78,9 @@ pic_proc_apply(pic_state *pic)
   return pic_apply_trampoline(pic, proc, arg_list);
 }
 
-static pic_value
-pic_proc_attribute(pic_state *pic)
-{
-  struct pic_proc *proc;
-
-  pic_get_args(pic, "l", &proc);
-
-  return pic_obj_value(pic_attr(pic, proc));
-}
-
 void
 pic_init_proc(pic_state *pic)
 {
   pic_defun(pic, "procedure?", pic_proc_proc_p);
   pic_defun(pic, "apply", pic_proc_apply);
-
-  pic_defun(pic, "attribute", pic_proc_attribute);
 }

state.c

@@ -61,6 +61,9 @@ pic_open(int argc, char *argv[], char **envp)
   /* macros */
   xh_init_int(&pic->macros, sizeof(struct pic_macro *));
 
+  /* attributes */
+  xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
+
   /* features */
   pic->features = pic_nil_value();
 
@@ -195,7 +198,9 @@ pic_close(pic_state *pic)
   pic->xp = pic->xpbase;
   pic->arena_idx = 0;
   pic->err = pic_undef_value();
+  xh_clear(&pic->globals);
   xh_clear(&pic->macros);
+  xh_clear(&pic->attrs);
   pic->features = pic_nil_value();
   pic->libs = pic_nil_value();
 
@@ -219,6 +224,7 @@ pic_close(pic_state *pic)
   xh_destroy(&pic->syms);
   xh_destroy(&pic->globals);
   xh_destroy(&pic->macros);
+  xh_destroy(&pic->attrs);
 
   /* free GC arena */
   free(pic->arena);

var.c

@@ -43,7 +43,7 @@ var_call(pic_state *pic)
 
   box = var_lookup(pic, pic_obj_value(self));
   if (! pic_test(box)) {
-    box = pic_attr_ref(pic, self, "@@box");
+    box = pic_attr_ref(pic, pic_obj_value(self), "@@box");
   }
 
   switch (n) {
@@ -51,7 +51,7 @@ var_call(pic_state *pic)
     return pic_car(pic, box);
 
   case 1:
-    conv = pic_attr_ref(pic, self, "@@converter");
+    conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter");
     if (pic_test(conv)) {
       pic_assert_type(pic, conv, proc);
 
@@ -64,7 +64,7 @@ var_call(pic_state *pic)
   case 2:
     assert(pic_false_p(tmp));
 
-    conv = pic_attr_ref(pic, self, "@@converter");
+    conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter");
     if (pic_test(conv)) {
       pic_assert_type(pic, conv, proc);
 
@@ -82,8 +82,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, var, "@@box", pic_list1(pic, init));
+  pic_attr_set(pic, pic_obj_value(var), "@@box", pic_list1(pic, init));
-  pic_attr_set(pic, var, "@@converter", conv ? pic_obj_value(conv) : pic_false_value());
+  pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value());
 
   return var;
 }