Merge branch 'syntactic-closure'

extlib/xhash/xhash.h

@@ -53,7 +53,7 @@ xh_get(struct xhash *x, const char *key)
 
   idx = xh_hash(key) % x->size;
   for (e = x->buckets[idx]; e; e = e->next) {
-    if (! strcmp(key, e->key))
+    if (strcmp(key, e->key) == 0)
       return e;
   }
   return NULL;
@@ -62,8 +62,7 @@ xh_get(struct xhash *x, const char *key)
 static inline struct xh_entry *
 xh_put(struct xhash *x, const char *key, int val)
 {
-  int idx, len;
+  int idx;
-  char *new_key;
   struct xh_entry *e;
 
   if ((e = xh_get(x, key))) {
@@ -71,14 +70,10 @@ xh_put(struct xhash *x, const char *key, int val)
     return e;
   }
 
-  len = strlen(key);
-  new_key = (char *)malloc(len+1);
-  strcpy(new_key, key);
-
   idx = xh_hash(key) % x->size;
   e = (struct xh_entry *)malloc(sizeof(struct xh_entry));
   e->next = x->buckets[idx];
-  e->key = new_key;
+  e->key = strdup(key);
   e->val = val;
 
   return x->buckets[idx] = e;

include/picrin.h

@@ -50,13 +50,16 @@ typedef struct {
   struct xhash *sym_tbl;
   const char **sym_pool;
   size_t slen, scapa;
+  int uniq_sym_count;
 
-  /* positive for variables, negative for macros (bitwise-not) */
   struct xhash *global_tbl;
   pic_value *globals;
   size_t glen, gcapa;
-  struct pic_proc **macros;
+
-  size_t mlen, mcapa;
+  /* positive for variables, negative for macros (bitwise-not) */
+  struct xhash *var_tbl;
+  struct pic_syntax **stx;
+  size_t xlen, xcapa;
 
   struct pic_irep **irep;
   size_t ilen, icapa;
@@ -98,6 +101,7 @@ void pic_close(pic_state *);
 struct pic_proc *pic_get_proc(pic_state *);
 int pic_get_args(pic_state *, const char *, ...);
 void pic_defun(pic_state *, const char *, pic_func_t);
+void pic_defmacro(pic_state *, const char *, struct pic_proc *);
 
 pic_sym pic_intern_cstr(pic_state *, const char *);
 const char *pic_symbol_name(pic_state *, pic_sym);

include/picrin/macro.h

@@ -0,0 +1,34 @@
+#ifndef MACRO_H__
+#define MACRO_H__
+
+struct pic_senv {
+  PIC_OBJECT_HEADER
+  struct pic_senv *up;
+  struct xhash *tbl;
+  struct pic_syntax **stx;
+  size_t xlen, xcapa;
+};
+
+struct pic_syntax {
+  PIC_OBJECT_HEADER
+  enum {
+    PIC_STX_DEFINE,
+    PIC_STX_SET,
+    PIC_STX_QUOTE,
+    PIC_STX_LAMBDA,
+    PIC_STX_IF,
+    PIC_STX_BEGIN,
+    PIC_STX_MACRO,
+    PIC_STX_DEFMACRO
+  } kind;
+  pic_sym sym;
+  struct pic_proc *macro;
+};
+
+#define pic_syntax(v) ((struct pic_syntax *)pic_ptr(v))
+#define pic_syntax_p(v) (pic_type(v) == PIC_TT_SYNTAX)
+
+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 *);
+
+#endif

include/picrin/pair.h

@@ -15,4 +15,9 @@ pic_value pic_reverse(pic_state *, pic_value);
 pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
 
+pic_value pic_caar(pic_state *, pic_value);
+pic_value pic_cadr(pic_state *, pic_value);
+pic_value pic_cdar(pic_state *, pic_value);
+pic_value pic_cddr(pic_state *, pic_value);
+
 #endif

include/picrin/value.h

@@ -89,7 +89,9 @@ enum pic_tt {
   PIC_TT_PORT,
   PIC_TT_ERROR,
   PIC_TT_ENV,
-  PIC_TT_CONT
+  PIC_TT_CONT,
+  PIC_TT_SENV,
+  PIC_TT_SYNTAX
 };
 
 #define PIC_OBJECT_HEADER			\

piclib/built-in.scm

@@ -314,18 +314,6 @@
 
 ;;; 6.2. Numbers
 
-(define (+ . args)
-  (do ((acc 0)
-       (nums args (cdr nums)))
-      ((pair? nums) acc)
-    (set! acc (+ acc (car nums)))))
-
-(define (* . args)
-  (do ((acc 1)
-       (nums args (cdr nums)))
-      ((pair? nums) acc)
-    (set! acc (* acc (car nums)))))
-
 (define (min x . args)
   (let loop ((pivot x) (rest args))
     (if (null? rest)

src/codegen.c

@@ -201,7 +201,10 @@ codegen(codegen_state *state, pic_value obj, bool tailpos)
     name = pic_symbol_name(pic, pic_sym(obj));
     s = scope_lookup(state, name, &depth, &idx);
     if (! s) {
-      pic_error(pic, "unbound variable");
+#if DEBUG
+      printf("%s\n", name);
+#endif
+      pic_error(pic, "symbol: unbound variable");
     }
 
     switch (depth) {
@@ -658,7 +661,9 @@ codegen(codegen_state *state, pic_value obj, bool tailpos)
   case PIC_TT_UNDEF:
   case PIC_TT_EOF:
   case PIC_TT_PORT:
-  case PIC_TT_ERROR: {
+  case PIC_TT_ERROR:
+  case PIC_TT_SENV:
+  case PIC_TT_SYNTAX: {
     pic_error(pic, "invalid expression given");
   }
   }

src/gc.c

@@ -8,6 +8,8 @@
 #include "picrin/blob.h"
 #include "picrin/cont.h"
 #include "picrin/error.h"
+#include "picrin/macro.h"
+#include "xhash/xhash.h"
 
 #if GC_DEBUG
 # include <stdio.h>
@@ -259,6 +261,29 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     gc_mark(pic, cont->result);
     break;
   }
+  case PIC_TT_SYNTAX: {
+    struct pic_syntax *stx = (struct pic_syntax *)obj;
+
+    if (stx->macro) {
+      gc_mark_object(pic, (struct pic_object *)stx->macro);
+    }
+    break;
+  }
+  case PIC_TT_SENV: {
+    struct pic_senv *senv = (struct pic_senv *)obj;
+
+    if (senv->up) {
+      gc_mark_object(pic, (struct pic_object *)senv->up);
+    }
+    if (senv->stx) {
+      int i;
+
+      for (i = 0; i < senv->xlen; ++i) {
+	gc_mark_object(pic, (struct pic_object *)senv->stx[i]);
+      }
+    }
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
@@ -321,8 +346,8 @@ gc_mark_phase(pic_state *pic)
   }
 
   /* macros */
-  for (i = 0; i < pic->mlen; ++i) {
+  for (i = 0; i < pic->xlen; ++i) {
-    gc_mark_object(pic, (struct pic_object *)pic->macros[i]);
+    gc_mark_object(pic, (struct pic_object *)pic->stx[i]);
   }
 
   /* pool */
@@ -383,6 +408,18 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     PIC_BLK_DECREF(pic, cont->blk);
     break;
   }
+  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);
+    }
+    break;
+  }
+  case PIC_TT_SYNTAX: {
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:

src/macro.c

@@ -1,95 +1,159 @@
 #include <stdio.h>
 #include <assert.h>
+#include <string.h>
+#include <math.h>
 
 #include "picrin.h"
 #include "picrin/pair.h"
 #include "picrin/proc.h"
+#include "picrin/macro.h"
 #include "xhash/xhash.h"
 
 #define FALLTHROUGH ((void)0)
 
-struct syntactic_env {
+static pic_sym
-  struct syntactic_env *up;
+new_uniq_sym(pic_state *pic, pic_sym base)
+{
+  int s = ++pic->uniq_sym_count;
+  char *str;
+  pic_sym uniq;
 
-  struct xhash *tbl;
+  str = (char *)pic_alloc(pic, strlen(pic_symbol_name(pic, base)) + (int)log10(s) + 2);
-};
+  sprintf(str, "%s@%d", pic_symbol_name(pic, base), s);
+  uniq = pic_intern_cstr(pic, str);
 
-static void
+  pic_free(pic, str);
-define_macro(pic_state *pic, const char *name, struct pic_proc *macro)
+  return uniq;
+}
+
+static struct pic_senv *
+new_global_senv(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;
+  return senv;
+}
+
+static struct pic_senv *
+new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
+{
+  struct pic_senv *senv;
+  pic_value a;
+  pic_sym sym;
+
+  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  senv->up = up;
+  senv->tbl = xh_new();
+  senv->stx = NULL;
+  senv->xlen = 0;
+  senv->xcapa = 0;
+
+  for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) {
+    sym = pic_sym(pic_car(pic, a));
+    xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym));
+  }
+  if (pic_symbol_p(a)) {
+    sym = pic_sym(a);
+    xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym));
+  }
+  return senv;
+}
+
+struct pic_syntax *
+pic_syntax_new(pic_state *pic, int kind, pic_sym sym)
+{
+  struct pic_syntax *stx;
+
+  stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX);
+  stx->kind = kind;
+  stx->sym = sym;
+  stx->macro = NULL;
+  return stx;
+}
+
+struct pic_syntax *
+pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro)
+{
+  struct pic_syntax *stx;
+
+  stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX);
+  stx->kind = PIC_STX_MACRO;
+  stx->sym = sym;
+  stx->macro = macro;
+  return stx;
+}
+
+void
+pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
 {
   int idx;
 
-  idx = pic->mlen++;
+  idx = pic->xlen;
-  if (idx >= pic->mcapa) {
+  if (idx >= pic->xcapa) {
     pic_abort(pic, "macro table overflow");
   }
-  pic->macros[idx] = macro;
+  pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro);
-  xh_put(pic->global_tbl, name, ~idx);
+  xh_put(pic->var_tbl, name, ~idx);
+  pic->xlen++;
 }
 
-static struct pic_proc *
+static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *);
-lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name)
-{
-  struct xh_entry *e;
 
-  e = xh_get(env->tbl, name);
+static pic_value
-  if (! e)
+macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
-    return NULL;
-
-  if (e->val >= 0)
-    return NULL;
-
-  return pic->macros[~e->val];
-}
-
-pic_value
-expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
 {
   int ai = pic_gc_arena_preserve(pic);
 
-#if DEBUG
+  switch (pic_type(expr)) {
-  printf("current ai = %d\n", ai);
-
-  printf("expanding...");
-  pic_debug(pic, obj);
-  puts("");
-#endif
-
-  switch (pic_type(obj)) {
   case PIC_TT_SYMBOL: {
-    return obj;
+    struct xh_entry *e;
+    while (senv) {
+      if ((e = xh_get(senv->tbl, pic_symbol_name(pic, pic_sym(expr)))) != NULL) {
+	if (e->val >= 0)
+	  return pic_symbol_value((pic_sym)e->val);
+	else
+	  return pic_obj_value(senv->stx[~e->val]);
+      }
+      senv = senv->up;
+    }
+    return expr;
   }
   case PIC_TT_PAIR: {
-    pic_value v;
+    pic_value car, v;
 
-    if (! pic_list_p(pic, obj))
+    if (! pic_list_p(pic, expr))
-      return obj;
+      return expr;
 
-    if (pic_symbol_p(pic_car(pic, obj))) {
+    car = macroexpand(pic, pic_car(pic, expr), senv);
-      struct pic_proc *macro;
+    if (pic_syntax_p(car)) {
-      pic_sym sym;
+      switch (pic_syntax(car)->kind) {
-
+      case PIC_STX_DEFMACRO: {
-      sym = pic_sym(pic_car(pic, obj));
-      if (sym == pic->sDEFINE_MACRO) {
 	pic_value var, val;
 	struct pic_proc *proc;
 
-	if (pic_length(pic, obj) < 2) {
+	if (pic_length(pic, expr) < 2) {
 	  pic_error(pic, "syntax error");
 	}
 
-	var = pic_car(pic, pic_cdr(pic, obj));
+	var = pic_car(pic, pic_cdr(pic, expr));
 	if (pic_pair_p(var)) {
+	  /* FIXME: unhygienic */
 	  val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
 			 pic_cons(pic, pic_cdr(pic, var),
-				  pic_cdr(pic, pic_cdr(pic, obj))));
+				  pic_cdr(pic, pic_cdr(pic, expr))));
 	  var = pic_car(pic, var);
 	}
 	else {
-	  if (pic_length(pic, obj) != 3) {
+	  if (pic_length(pic, expr) != 3) {
 	    pic_error(pic, "syntax_error");
 	  }
-	  val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
+	  val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
 	}
 	if (! pic_symbol_p(var)) {
 	  pic_error(pic, "syntax error");
@@ -106,14 +170,13 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
 	  abort();
 	}
 	assert(pic_proc_p(v));
-	define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
+	pic_defmacro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
 
 	pic_gc_arena_restore(pic, ai);
 	return pic_false_value();
       }
-      macro = lookup_macro(pic, env, pic_symbol_name(pic, sym));
+      case PIC_STX_MACRO: {
-      if (macro) {
+	v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr));
-	v = pic_apply(pic, macro, pic_cdr(pic, obj));
 	if (pic->errmsg) {
 	  printf("macroexpand error: %s\n", pic->errmsg);
 	  abort();
@@ -121,37 +184,87 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
 	pic_gc_arena_restore(pic, ai);
 	pic_gc_protect(pic, v);
 
-	v = expand(pic, v, env);
+	return macroexpand(pic, v, senv);
+      }
+      case PIC_STX_LAMBDA: {
+	struct pic_senv *in = new_local_senv(pic, pic_cadr(pic, expr), senv);
+
+	v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym),
+		     pic_cons(pic,
+			      macroexpand_list(pic, pic_cadr(pic, expr), in),
+			      macroexpand_list(pic, pic_cddr(pic, expr), in)));
+
+	pic_gc_arena_restore(pic, ai);
+	pic_gc_protect(pic, v);
+	return v;
+      }
+      case PIC_STX_DEFINE: {
+	pic_sym uniq;
+	pic_value var;
+
+	if (pic_length(pic, expr) < 2) {
+	  pic_error(pic, "syntax error");
+	}
+
+	var = pic_cadr(pic, expr);
+	if (pic_pair_p(var)) {
+	  struct pic_senv *in = new_local_senv(pic, pic_cdr(pic, var), senv);
+	  pic_value a;
+	  pic_sym sym;
+
+	  /* defined symbol */
+	  a = pic_car(pic, var);
+	  if (! pic_symbol_p(a)) {
+	    pic_error(pic, "binding to non-symbol object");
+	  }
+	  sym = pic_sym(a);
+	  xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym));
+
+	  /* binding value */
+	  v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym),
+		       pic_cons(pic,
+				macroexpand_list(pic, pic_cadr(pic, expr), in),
+				macroexpand_list(pic, pic_cddr(pic, expr), in)));
+
+	  pic_gc_arena_restore(pic, ai);
+	  pic_gc_protect(pic, v);
+	  return v;
+	}
+
+	uniq = new_uniq_sym(pic, pic_sym(var));
+	xh_put(senv->tbl, pic_symbol_name(pic, pic_sym(var)), (int)uniq);
+      }
+	FALLTHROUGH;
+      case PIC_STX_SET:
+      case PIC_STX_IF:
+      case PIC_STX_BEGIN:
+	v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), macroexpand_list(pic, pic_cdr(pic, expr), senv));
+	pic_gc_arena_restore(pic, ai);
+	pic_gc_protect(pic, v);
+	return v;
+      case PIC_STX_QUOTE:
+	v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), pic_cdr(pic, expr));
 	pic_gc_arena_restore(pic, ai);
 	pic_gc_protect(pic, v);
 	return v;
       }
     }
 
-    v = pic_nil_value();
+    v = pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
-    while (! pic_nil_p(obj)) {
-      v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), v);
-      obj = pic_cdr(pic, obj);
-
-      pic_gc_arena_restore(pic, ai);
-      pic_gc_protect(pic, v);
-    }
-    v = pic_reverse(pic, v);
-
     pic_gc_arena_restore(pic, ai);
     pic_gc_protect(pic, v);
     return v;
   }
+  case PIC_TT_EOF:
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
   case PIC_TT_INT:
   case PIC_TT_CHAR:
-  case PIC_TT_EOF:
   case PIC_TT_STRING:
   case PIC_TT_VECTOR:
   case PIC_TT_BLOB: {
-    return obj;
+    return expr;
   }
   case PIC_TT_PROC:
   case PIC_TT_PORT:
@@ -159,28 +272,45 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
   case PIC_TT_ENV:
   case PIC_TT_CONT:
   case PIC_TT_UNDEF:
+  case PIC_TT_SENV:
+  case PIC_TT_SYNTAX:
     pic_error(pic, "unexpected value type");
     return pic_undef_value();	/* unreachable */
   }
-  /* logic flaw (suppress warnings gcc will emit) */
+  /* suppress warnings, never be called */
   abort();
 }
 
-pic_value
+static pic_value
-pic_macroexpand(pic_state *pic, pic_value obj)
+macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv)
 {
-  struct syntactic_env env;
   pic_value v;
 
-  env.tbl = pic->global_tbl;
+  if (pic_nil_p(list))
+    return pic_nil_value();
+
+  if (pic_symbol_p(list))
+    return macroexpand(pic, list, senv);
+
+  v = macroexpand(pic, pic_car(pic, list), senv);
+  return pic_cons(pic, v, macroexpand_list(pic, pic_cdr(pic, list), senv));
+}
+
+pic_value
+pic_macroexpand(pic_state *pic, pic_value expr)
+{
+  struct pic_senv *senv;
+  pic_value v;
+
+  senv = new_global_senv(pic);
 
 #if DEBUG
   puts("before expand:");
-  pic_debug(pic, obj);
+  pic_debug(pic, expr);
   puts("");
 #endif
 
-  v = expand(pic, obj, &env);
+  v = macroexpand(pic, expr, senv);
 
 #if DEBUG
   puts("after expand:");

src/pair.c

@@ -134,6 +134,30 @@ pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
   return pic_cons(pic, pic_cons(pic, key, val), assoc);
 }
 
+pic_value
+pic_caar(pic_state *pic, pic_value v)
+{
+  return pic_car(pic, pic_car(pic, v));
+}
+
+pic_value
+pic_cadr(pic_state *pic, pic_value v)
+{
+  return pic_car(pic, pic_cdr(pic, v));
+}
+
+pic_value
+pic_cdar(pic_state *pic, pic_value v)
+{
+  return pic_cdr(pic, pic_car(pic, v));
+}
+
+pic_value
+pic_cddr(pic_state *pic, pic_value v)
+{
+  return pic_cdr(pic, pic_cdr(pic, v));
+}
+
 static pic_value
 pic_pair_pair_p(pic_state *pic)
 {

src/port.c

@@ -97,6 +97,12 @@ write(pic_state *pic, pic_value obj)
   case PIC_TT_CONT:
     printf("#<cont %p>", pic_ptr(obj));
     break;
+  case PIC_TT_SENV:
+    printf("#<senv %p>", pic_ptr(obj));
+    break;
+  case PIC_TT_SYNTAX:
+    printf("#<senv %p>", pic_ptr(obj));
+    break;
   }
 }
 

src/state.c

@@ -3,6 +3,7 @@
 #include "picrin.h"
 #include "picrin/gc.h"
 #include "picrin/proc.h"
+#include "picrin/macro.h"
 #include "xhash/xhash.h"
 
 void pic_init_core(pic_state *);
@@ -51,6 +52,7 @@ pic_open(int argc, char *argv[], char **envp)
   pic->sym_pool = (const char **)calloc(PIC_SYM_POOL_SIZE, sizeof(const char *));
   pic->slen = 0;
   pic->scapa = pic->slen + PIC_SYM_POOL_SIZE;
+  pic->uniq_sym_count = 0;
 
   /* irep */
   pic->irep = (struct pic_irep **)calloc(PIC_IREP_SIZE, sizeof(struct pic_irep *));
@@ -62,9 +64,12 @@ pic_open(int argc, char *argv[], char **envp)
   pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value));
   pic->glen = 0;
   pic->gcapa = PIC_GLOBALS_SIZE;
-  pic->macros = (struct pic_proc **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_proc *));
+
-  pic->mlen = 0;
+  /* identifier table */
-  pic->mcapa = PIC_MACROS_SIZE;
+  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;
 
   /* pool */
   pic->pool = (pic_value *)calloc(PIC_POOL_SIZE, sizeof(pic_value));
@@ -81,31 +86,50 @@ pic_open(int argc, char *argv[], char **envp)
   /* native stack marker */
   pic->native_stack_start = &t;
 
+#define register_core_symbol(pic,slot,name) do {	\
+    pic->slot = pic_intern_cstr(pic, name);		\
+  } while (0)
+
   ai = pic_gc_arena_preserve(pic);
-  pic->sDEFINE = pic_intern_cstr(pic, "define");
+  register_core_symbol(pic, sDEFINE, "define");
-  pic->sLAMBDA = pic_intern_cstr(pic, "lambda");
+  register_core_symbol(pic, sLAMBDA, "lambda");
-  pic->sIF = pic_intern_cstr(pic, "if");
+  register_core_symbol(pic, sIF, "if");
-  pic->sBEGIN = pic_intern_cstr(pic, "begin");
+  register_core_symbol(pic, sBEGIN, "begin");
-  pic->sSETBANG = pic_intern_cstr(pic, "set!");
+  register_core_symbol(pic, sSETBANG, "set!");
-  pic->sQUOTE = pic_intern_cstr(pic, "quote");
+  register_core_symbol(pic, sQUOTE, "quote");
-  pic->sQUASIQUOTE = pic_intern_cstr(pic, "quasiquote");
+  register_core_symbol(pic, sQUASIQUOTE, "quasiquote");
-  pic->sUNQUOTE = pic_intern_cstr(pic, "unquote");
+  register_core_symbol(pic, sUNQUOTE, "unquote");
-  pic->sUNQUOTE_SPLICING = pic_intern_cstr(pic, "unquote-splicing");
+  register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
-  pic->sDEFINE_SYNTAX = pic_intern_cstr(pic, "define-syntax");
+  register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
-  pic->sDEFINE_MACRO = pic_intern_cstr(pic, "define-macro");
+  register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
-  pic->sCONS = pic_intern_cstr(pic, "cons");
+  register_core_symbol(pic, sCONS, "cons");
-  pic->sCAR = pic_intern_cstr(pic, "car");
+  register_core_symbol(pic, sCAR, "car");
-  pic->sCDR = pic_intern_cstr(pic, "cdr");
+  register_core_symbol(pic, sCDR, "cdr");
-  pic->sNILP = pic_intern_cstr(pic, "null?");
+  register_core_symbol(pic, sNILP, "null?");
-  pic->sADD = pic_intern_cstr(pic, "+");
+  register_core_symbol(pic, sADD, "+");
-  pic->sSUB = pic_intern_cstr(pic, "-");
+  register_core_symbol(pic, sSUB, "-");
-  pic->sMUL = pic_intern_cstr(pic, "*");
+  register_core_symbol(pic, sMUL, "*");
-  pic->sDIV = pic_intern_cstr(pic, "/");
+  register_core_symbol(pic, sDIV, "/");
-  pic->sEQ = pic_intern_cstr(pic, "=");
+  register_core_symbol(pic, sEQ, "=");
-  pic->sLT = pic_intern_cstr(pic, "<");
+  register_core_symbol(pic, sLT, "<");
-  pic->sLE = pic_intern_cstr(pic, "<=");
+  register_core_symbol(pic, sLE, "<=");
-  pic->sGT = pic_intern_cstr(pic, ">");
+  register_core_symbol(pic, sGT, ">");
-  pic->sGE = pic_intern_cstr(pic, ">=");
+  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");
   pic_gc_arena_restore(pic, ai);
 
   pic_init_core(pic);