add pic_core_syntactic_env

include/picrin.h

@@ -56,10 +56,7 @@ typedef struct {
   pic_value *globals;
   size_t glen, gcapa;
 
-  /* positive for variables, negative for macros (bitwise-not) */
-  struct xhash *var_tbl;
-  struct pic_syntax **stx;
-  size_t xlen, xcapa;
+  struct pic_senv *global_senv;
 
   struct pic_irep **irep;
   size_t ilen, icapa;

include/picrin/macro.h

@@ -4,6 +4,7 @@
 struct pic_senv {
   PIC_OBJECT_HEADER
   struct pic_senv *up;
+  /* positive for variables, negative for macros (bitwise-not) */
   struct xhash *tbl;
   struct pic_syntax **stx;
   size_t xlen, xcapa;
@@ -42,6 +43,8 @@ struct pic_sc {
 #define pic_senv(v) ((struct pic_senv *)pic_ptr(v))
 #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
 
+struct pic_senv *pic_core_syntactic_env(pic_state *pic);
+
 struct pic_syntax *pic_syntax_new(pic_state *, int kind, pic_sym sym);
 struct pic_syntax *pic_syntax_new_macro(pic_state *, pic_sym, struct pic_proc *, struct pic_senv *senv);
 

src/gc.c

@@ -458,8 +458,8 @@ gc_mark_phase(pic_state *pic)
   }
 
   /* macros */
-  for (i = 0; i < pic->xlen; ++i) {
-    gc_mark_object(pic, (struct pic_object *)pic->stx[i]);
+  if (pic->global_senv) {
+    gc_mark_object(pic, (struct pic_object *)pic->global_senv);
   }
 
   /* pool */
@@ -522,11 +522,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   }
   case PIC_TT_SENV: {
     struct pic_senv *senv = (struct pic_senv *)obj;
-    if (senv->up) {
-      xh_destory(senv->tbl);
-      if (senv->stx)
-	pic_free(pic, senv->stx);
-    }
+    xh_destory(senv->tbl);
+    if (senv->stx)
+      pic_free(pic, senv->stx);
     break;
   }
   case PIC_TT_SYNTAX: {

src/macro.c

@@ -29,20 +29,42 @@ new_uniq_sym(pic_state *pic, pic_sym base)
   return uniq;
 }
 
-static struct pic_senv *
-new_global_senv(pic_state *pic)
+struct pic_senv *
+pic_core_syntactic_env(pic_state *pic)
 {
   struct pic_senv *senv;
 
   senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
   senv->up = NULL;
-  senv->tbl = pic->var_tbl;
-  senv->stx = pic->stx;
-  senv->xlen = pic->xlen;
-  senv->xcapa = pic->xcapa;
+  senv->tbl = xh_new();
+  senv->stx = (struct pic_syntax **)pic_calloc(pic, PIC_MACROS_SIZE, sizeof(struct pic_syntax *));
+  senv->xlen = 0;
+  senv->xcapa = PIC_MACROS_SIZE;
+
+#define register_core_syntax(pic,senv,kind,name) do {			\
+    senv->stx[senv->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \
+    xh_put(senv->tbl, name, ~senv->xlen);				\
+    senv->xlen++;							\
+  } while (0)
+
+  register_core_syntax(pic, senv, PIC_STX_DEFINE, "define");
+  register_core_syntax(pic, senv, PIC_STX_SET, "set!");
+  register_core_syntax(pic, senv, PIC_STX_QUOTE, "quote");
+  register_core_syntax(pic, senv, PIC_STX_LAMBDA, "lambda");
+  register_core_syntax(pic, senv, PIC_STX_IF, "if");
+  register_core_syntax(pic, senv, PIC_STX_BEGIN, "begin");
+  register_core_syntax(pic, senv, PIC_STX_DEFMACRO, "define-macro");
+  register_core_syntax(pic, senv, PIC_STX_DEFSYNTAX, "define-syntax");
+
   return senv;
 }
 
+static struct pic_senv *
+new_global_senv(pic_state *pic)
+{
+  return pic->global_senv;
+}
+
 static struct pic_senv *
 new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
 {
@@ -136,13 +158,13 @@ pic_defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct p
 {
   int idx;
 
-  idx = pic->xlen;
-  if (idx >= pic->xcapa) {
+  idx = pic->global_senv->xlen;
+  if (idx >= pic->global_senv->xcapa) {
     pic_abort(pic, "macro table overflow");
   }
-  pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env);
-  xh_put(pic->var_tbl, name, ~idx);
-  pic->xlen++;
+  pic->global_senv->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env);
+  xh_put(pic->global_senv->tbl, name, ~idx);
+  pic->global_senv->xlen++;
 }
 
 void

src/state.c

@@ -65,11 +65,9 @@ pic_open(int argc, char *argv[], char **envp)
   pic->glen = 0;
   pic->gcapa = PIC_GLOBALS_SIZE;
 
-  /* identifier table */
-  pic->var_tbl = xh_new();
-  pic->stx = (struct pic_syntax **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_syntax *));
-  pic->xlen = 0;
-  pic->xcapa = PIC_MACROS_SIZE;
+  /* syntactic env */
+  pic->global_senv = NULL;      /* prevent gc from hanging during marking phase */
+  pic->global_senv = pic_core_syntactic_env(pic);
 
   /* pool */
   pic->pool = (pic_value *)calloc(PIC_POOL_SIZE, sizeof(pic_value));
@@ -117,22 +115,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sGE, ">=");
   pic_gc_arena_restore(pic, ai);
 
-#define register_core_syntax(pic,kind,name) do {			\
-    pic->stx[pic->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \
-    xh_put(pic->var_tbl, name, ~pic->xlen);				\
-    pic->xlen++;							\
-  } while (0)
-
-  register_core_syntax(pic, PIC_STX_DEFINE, "define");
-  register_core_syntax(pic, PIC_STX_SET, "set!");
-  register_core_syntax(pic, PIC_STX_QUOTE, "quote");
-  register_core_syntax(pic, PIC_STX_LAMBDA, "lambda");
-  register_core_syntax(pic, PIC_STX_IF, "if");
-  register_core_syntax(pic, PIC_STX_BEGIN, "begin");
-  register_core_syntax(pic, PIC_STX_DEFMACRO, "define-macro");
-  register_core_syntax(pic, PIC_STX_DEFSYNTAX, "define-syntax");
-  pic_gc_arena_restore(pic, ai);
-
   pic_init_core(pic);
 
   return pic;