Merge branch 'let-syntax2'

include/picrin.h

@@ -81,6 +81,7 @@ typedef struct {
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
   pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
+  pic_sym sLET_SYNTAX, sLETREC_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
@@ -127,6 +128,13 @@ void pic_gc_run(pic_state *);
 pic_value pic_gc_protect(pic_state *, pic_value);
 size_t pic_gc_arena_preserve(pic_state *);
 void pic_gc_arena_restore(pic_state *, size_t);
+#define pic_void(exec)                          \
+  pic_void_(GENSYM(ai), exec)
+#define pic_void_(ai,exec) do {                 \
+    size_t ai = pic_gc_arena_preserve(pic);     \
+    exec;                                       \
+    pic_gc_arena_restore(pic, ai);              \
+  } while (0)
 
 pic_state *pic_open(int argc, char *argv[], char **envp);
 void pic_close(pic_state *);

include/picrin/dict.h

@@ -23,6 +23,7 @@ pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym);
 void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value);
 void pic_dict_del(pic_state *, struct pic_dict *, pic_sym);
 size_t pic_dict_size(pic_state *, struct pic_dict *);
+bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym);
 
 #if defined(__cplusplus)
 }

src/dict.c

@@ -44,6 +44,14 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict)
   return dict->hash.count;
 }
 
+bool
+pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key)
+{
+  UNUSED(pic);
+
+  return xh_get_int(&dict->hash, key) != NULL;
+}
+
 void
 pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
 {

src/init.c

@@ -75,6 +75,8 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;

src/macro.c

@@ -9,33 +9,7 @@
 #include "picrin/macro.h"
 #include "picrin/lib.h"
 #include "picrin/error.h"
-#include "picrin/box.h"
-
-struct pic_senv *
-pic_null_syntactic_environment(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;
-  xh_init_int(&senv->renames, sizeof(pic_sym));
-
-  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY);
-  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT);
-  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT);
-
-  return senv;
-}
-
-void
-pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym)
-{
-  pic_put_rename(pic, senv, sym, sym);
-
-  if (pic->lib && pic->lib->senv == senv) {
-    pic_export(pic, sym);
-  }
-}
+#include "picrin/dict.h"
 
 pic_sym
 pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
@@ -94,108 +68,10 @@ find_macro(pic_state *pic, pic_sym rename)
   return xh_val(e, struct pic_macro *);
 }
 
-void
-pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
-{
-  pic_sym sym, rename;
-
-  /* symbol registration */
-  sym = pic_intern_cstr(pic, name);
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
-  define_macro(pic, rename, macro, NULL);
-
-  /* auto export! */
-  pic_export(pic, sym);
-}
-
-static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value);
-
-static pic_value
-macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v;
-
-  v = macroexpand_node(pic, expr, senv, assoc_box);
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, v);
-  return v;
-}
-
-static struct pic_senv *
-push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box)
-{
-  struct pic_senv *senv;
-  pic_value a;
-
-  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  senv->up = up;
-  xh_init_int(&senv->renames, sizeof(pic_sym));
-
-  for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) {
-    pic_value v = pic_car(pic, a);
-
-    if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, up, assoc_box);
-    }
-    if (! pic_sym_p(v)) {
-      pic_error(pic, "syntax error");
-    }
-    pic_add_rename(pic, senv, pic_sym(v));
-  }
-  if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, up, assoc_box);
-  }
-  if (pic_sym_p(a)) {
-    pic_add_rename(pic, senv, pic_sym(a));
-  }
-  else if (! pic_nil_p(a)) {
-    pic_error(pic, "syntax error");
-  }
-  return senv;
-}
-
-static pic_value
-macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v, vs;
-
-  /* macroexpand in order */
-  vs = pic_nil_value();
-  while (pic_pair_p(list)) {
-    v = pic_car(pic, list);
-
-    vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs);
-    list = pic_cdr(pic, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
-  }
-
-  list = macroexpand(pic, list, senv, assoc_box);
-
-  /* reverse the result */
-  pic_for_each (v, vs) {
-    list = pic_cons(pic, v, list);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, vs);
-    pic_gc_protect(pic, list);
-  }
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, list);
-  return list;
-}
-
 static pic_sym
-macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box)
+translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_sym rename;
-  pic_value x;
 
   if (! pic_interned_p(pic, sym)) {
     return sym;
@@ -208,48 +84,27 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value
       break;
     senv = senv->up;
   }
-  x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box));
-  if (pic_test(x)) {
-    return pic_sym(pic_cdr(pic, x));
+  if (pic_dict_has(pic, cxt, sym)) {
+    return pic_sym(pic_dict_ref(pic, cxt, sym));
   } else {
     rename = pic_gensym(pic, sym);
-    pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box)));
+    pic_dict_set(pic, cxt, sym, pic_sym_value(rename));
     return rename;
   }
 }
 
+static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
+
 static pic_value
-macroexpand_deflibrary(pic_state *pic, pic_value expr)
+macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  struct pic_lib *prev = pic->lib;
-  pic_value v;
+  return pic_sym_value(translate(pic, sym, senv, cxt));
+}
 
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  pic_make_library(pic, pic_cadr(pic, expr));
-
-  pic_try {
-    pic_in_library(pic, pic_cadr(pic, expr));
-
-    pic_for_each (v, pic_cddr(pic, expr)) {
-      size_t ai = pic_gc_arena_preserve(pic);
-
-      pic_eval(pic, v);
-
-      pic_gc_arena_restore(pic, ai);
-    }
-
-    pic_in_library(pic, prev->name);
-  }
-  pic_catch {
-    /* restores pic->lib even if an error occurs */
-    pic_in_library(pic, prev->name);
-    pic_throw_error(pic, pic->err);
-  }
-
-  return pic_none_value();
+static pic_value
+macroexpand_quote(pic_state *pic, pic_value expr)
+{
+  return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr));
 }
 
 static pic_value
@@ -301,7 +156,135 @@ macroexpand_export(pic_state *pic, pic_value expr)
 }
 
 static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_deflibrary(pic_state *pic, pic_value expr)
+{
+  struct pic_lib *prev = pic->lib;
+  pic_value v;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  pic_make_library(pic, pic_cadr(pic, expr));
+
+  pic_try {
+    pic_in_library(pic, pic_cadr(pic, expr));
+
+    pic_for_each (v, pic_cddr(pic, expr)) {
+      pic_void(pic_eval(pic, v));
+    }
+
+    pic_in_library(pic, prev->name);
+  }
+  pic_catch {
+    pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
+    pic_throw_error(pic, pic->err);
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value x, head, tail;
+
+  if (pic_pair_p(obj)) {
+    head = macroexpand(pic, pic_car(pic, obj), senv, cxt);
+    tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt);
+    x = pic_cons(pic, head, tail);
+  } else {
+    x = macroexpand(pic, obj, senv, cxt);
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, x);
+  return x;
+}
+
+static pic_value
+macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_value formal, body;
+  struct pic_senv *in;
+  pic_value a;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  in->up = senv;
+  xh_init_int(&in->renames, sizeof(pic_sym));
+
+  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
+    pic_value v = pic_car(pic, a);
+
+    if (! pic_sym_p(v)) {
+      v = macroexpand(pic, v, senv, cxt);
+    }
+    if (! pic_sym_p(v)) {
+      pic_error(pic, "syntax error");
+    }
+    pic_add_rename(pic, in, pic_sym(v));
+  }
+  if (! pic_sym_p(a)) {
+    a = macroexpand(pic, a, senv, cxt);
+  }
+  if (pic_sym_p(a)) {
+    pic_add_rename(pic, in, pic_sym(a));
+  }
+  else if (! pic_nil_p(a)) {
+    pic_error(pic, "syntax error");
+  }
+
+  formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
+  body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);
+
+  return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body));
+}
+
+static pic_value
+macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  pic_sym sym;
+  pic_value formal, body, var, val;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_error(pic, "syntax error");
+  }
+
+  formal = pic_cadr(pic, expr);
+  if (pic_pair_p(formal)) {
+    var = pic_car(pic, formal);
+  } else {
+    if (pic_length(pic, expr) != 3) {
+      pic_error(pic, "syntax error");
+    }
+    var = formal;
+  }
+  if (! pic_sym_p(var)) {
+    var = macroexpand(pic, var, senv, cxt);
+  }
+  if (! pic_sym_p(var)) {
+    pic_error(pic, "binding to non-symbol object");
+  }
+  sym = pic_sym(var);
+  if (! pic_find_rename(pic, senv, sym, NULL)) {
+    pic_add_rename(pic, senv, sym);
+  }
+  body = pic_cddr(pic, expr);
+  if (pic_pair_p(formal)) {
+    val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv, cxt);
+  } else {
+    val = macroexpand(pic, pic_car(pic, body), senv, cxt);
+  }
+  return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
+}
+
+static pic_value
+macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_value var, val;
   pic_sym sym, rename;
@@ -312,7 +295,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic
 
   var = pic_cadr(pic, expr);
   if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv, assoc_box);
+    var = macroexpand(pic, var, senv, cxt);
   }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
@@ -387,73 +370,47 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
 }
 
 static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
-  pic_sym sym;
-  pic_value formals;
+  struct pic_senv *in;
+  pic_value formal, v, var, val;
+  pic_sym sym, rename;
+
+  in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
+  in->up = senv;
+  xh_init_int(&in->renames, sizeof(pic_sym));
 
   if (pic_length(pic, expr) < 2) {
     pic_error(pic, "syntax error");
   }
 
-  formals = pic_cadr(pic, expr);
-  if (pic_pair_p(formals)) {
-    struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box);
-    pic_value a;
-
-    /* defined symbol */
-    a = pic_car(pic, formals);
-    if (! pic_sym_p(a)) {
-      a = macroexpand(pic, a, senv, assoc_box);
+  formal = pic_cadr(pic, expr);
+  if (! pic_list_p(formal)) {
+    pic_error(pic, "syntax error");
+  }
+  pic_for_each (v, formal) {
+    var = pic_car(pic, v);
+    if (! pic_sym_p(var)) {
+      var = macroexpand(pic, var, senv, cxt);
     }
-    if (! pic_sym_p(a)) {
+    if (! pic_sym_p(var)) {
       pic_error(pic, "binding to non-symbol object");
     }
-    sym = pic_sym(a);
-    if (! pic_find_rename(pic, senv, sym, NULL)) {
-      pic_add_rename(pic, senv, sym);
+    sym = pic_sym(var);
+    if (! pic_find_rename(pic, in, sym, &rename)) {
+      rename = pic_add_rename(pic, in, sym);
     }
-
-    /* binding value */
-    return pic_cons(pic, pic_sym_value(pic->sDEFINE),
-                    pic_cons(pic,
-                             macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box),
-                             macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box)));
+    val = pic_eval(pic, pic_cadr(pic, v));
+    if (! pic_proc_p(val)) {
+      pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var);
+    }
+    define_macro(pic, rename, pic_proc_ptr(val), senv);
   }
-
-  if (! pic_sym_p(formals)) {
-    formals = macroexpand(pic, formals, senv, assoc_box);
-  }
-  if (! pic_sym_p(formals)) {
-    pic_error(pic, "binding to non-symbol object");
-  }
-  sym = pic_sym(formals);
-  if (! pic_find_rename(pic, senv, sym, NULL)) {
-    pic_add_rename(pic, senv, sym);
-  }
-
-  return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box));
+  return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
 }
 
 static pic_value
-macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
-{
-  struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box);
-
-  return pic_cons(pic, pic_sym_value(pic->sLAMBDA),
-                  pic_cons(pic,
-                           macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box),
-                           macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box)));
-}
-
-static pic_value
-macroexpand_quote(pic_state *pic, pic_value expr)
-{
-  return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr));
-}
-
-static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
   pic_value v, args;
 
@@ -482,11 +439,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
   puts("");
 #endif
 
-  return macroexpand(pic, v, senv, assoc_box);
+  return macroexpand(pic, v, senv, cxt);
 }
 
 static pic_value
-macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box)
+macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
 {
 #if DEBUG
   printf("[macroexpand] expanding... ");
@@ -496,10 +453,10 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
 
   switch (pic_type(expr)) {
   case PIC_TT_SC: {
-    return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box);
+    return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt);
   }
   case PIC_TT_SYMBOL: {
-    return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box));
+    return macroexpand_symbol(pic, pic_sym(expr), senv, cxt);
   }
   case PIC_TT_PAIR: {
     pic_value car;
@@ -509,7 +466,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
       pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
     }
 
-    car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box);
+    car = macroexpand(pic, pic_car(pic, expr), senv, cxt);
     if (pic_sym_p(car)) {
       pic_sym tag = pic_sym(car);
 
@@ -523,27 +480,33 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
         return macroexpand_export(pic, expr);
       }
       else if (tag == pic->sDEFINE_SYNTAX) {
-        return macroexpand_defsyntax(pic, expr, senv, assoc_box);
+        return macroexpand_defsyntax(pic, expr, senv, cxt);
       }
       else if (tag == pic->sDEFINE_MACRO) {
         return macroexpand_defmacro(pic, expr, senv);
       }
+      else if (tag == pic->sLET_SYNTAX) {
+        return macroexpand_let_syntax(pic, expr, senv, cxt);
+      }
+      /* else if (tag == pic->sLETREC_SYNTAX) { */
+      /*   return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
+      /* } */
       else if (tag == pic->sLAMBDA) {
-        return macroexpand_lambda(pic, expr, senv, assoc_box);
+        return macroexpand_lambda(pic, expr, senv, cxt);
       }
       else if (tag == pic->sDEFINE) {
-        return macroexpand_define(pic, expr, senv, assoc_box);
+        return macroexpand_define(pic, expr, senv, cxt);
       }
       else if (tag == pic->sQUOTE) {
         return macroexpand_quote(pic, expr);
       }
 
       if ((mac = find_macro(pic, tag)) != NULL) {
-        return macroexpand_macro(pic, mac, expr, senv, assoc_box);
+        return macroexpand_macro(pic, mac, expr, senv, cxt);
       }
     }
 
-    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box));
+    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
   }
   case PIC_TT_EOF:
   case PIC_TT_NIL:
@@ -575,10 +538,23 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
   UNREACHABLE();
 }
 
+static pic_value
+macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value v;
+
+  v = macroexpand_node(pic, expr, senv, cxt);
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, v);
+  return v;
+}
+
 pic_value
 pic_macroexpand(pic_state *pic, pic_value expr)
 {
-  pic_value v, box;
+  pic_value v;
 
 #if DEBUG
   puts("before expand:");
@@ -586,9 +562,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  box = pic_box(pic, pic_nil_value());
-
-  v = macroexpand(pic, expr, pic->lib->senv, box);
+  v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic));
 
 #if DEBUG
   puts("after expand:");
@@ -599,6 +573,46 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   return v;
 }
 
+struct pic_senv *
+pic_null_syntactic_environment(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;
+  xh_init_int(&senv->renames, sizeof(pic_sym));
+
+  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT);
+  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT);
+
+  return senv;
+}
+
+void
+pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym)
+{
+  pic_put_rename(pic, senv, sym, sym);
+
+  if (pic->lib && pic->lib->senv == senv) {
+    pic_export(pic, sym);
+  }
+}
+
+void
+pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
+{
+  pic_sym sym, rename;
+
+  /* symbol registration */
+  sym = pic_intern_cstr(pic, name);
+  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  define_macro(pic, rename, macro, NULL);
+
+  /* auto export! */
+  pic_export(pic, sym);
+}
+
 static pic_value
 pic_macro_gensym(pic_state *pic)
 {
@@ -647,16 +661,16 @@ sc_identifier_p(pic_value obj)
 static bool
 sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y)
 {
-  pic_value box;
+  struct pic_dict *cxt;
 
   if (! (sc_identifier_p(x) && sc_identifier_p(y))) {
     return false;
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
-  x = macroexpand(pic, x, e1, box);
-  y = macroexpand(pic, y, e2, box);
+  x = macroexpand(pic, x, e1, cxt);
+  y = macroexpand(pic, y, e2, cxt);
 
   return pic_eq_p(x, y);
 }
@@ -713,14 +727,14 @@ er_macro_rename(pic_state *pic)
 {
   pic_sym sym;
   struct pic_senv *mac_env;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "m", &sym);
 
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, mac_env, cxt));
 }
 
 static pic_value
@@ -729,7 +743,7 @@ er_macro_compare(pic_state *pic)
   pic_value a, b;
   struct pic_senv *use_env;
   pic_sym m, n;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "oo", &a, &b);
 
@@ -737,10 +751,10 @@ er_macro_compare(pic_state *pic)
     return pic_false_value();   /* should be an error? */
 
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box);
-  n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box);
+  m = translate(pic, pic_sym(a), use_env, cxt);
+  n = translate(pic, pic_sym(b), use_env, cxt);
 
   return pic_bool_value(m == n);
 }
@@ -748,8 +762,9 @@ er_macro_compare(pic_state *pic)
 static pic_value
 er_macro_call(pic_state *pic)
 {
-  pic_value expr, use_env, mac_env, box;
+  pic_value expr, use_env, mac_env;
   struct pic_proc *rename, *compare, *cb;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
 
@@ -760,19 +775,19 @@ er_macro_call(pic_state *pic)
     pic_error(pic, "unexpected type of argument 3");
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
   rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
   pic_proc_cv_init(pic, rename, 3);
   pic_proc_cv_set(pic, rename, 0, use_env);
   pic_proc_cv_set(pic, rename, 1, mac_env);
-  pic_proc_cv_set(pic, rename, 2, box);
+  pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt));
 
   compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
   pic_proc_cv_init(pic, compare, 3);
   pic_proc_cv_set(pic, compare, 0, use_env);
   pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, box);
+  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
 
   cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
 
@@ -798,14 +813,14 @@ ir_macro_inject(pic_state *pic)
 {
   pic_sym sym;
   struct pic_senv *use_env;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "m", &sym);
 
   use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box));
+  return pic_sym_value(translate(pic, sym, use_env, cxt));
 }
 
 static pic_value
@@ -814,7 +829,7 @@ ir_macro_compare(pic_state *pic)
   pic_value a, b;
   struct pic_senv *mac_env;
   pic_sym m, n;
-  pic_value assoc_box;
+  struct pic_dict *cxt;
 
   pic_get_args(pic, "oo", &a, &b);
 
@@ -822,27 +837,27 @@ ir_macro_compare(pic_state *pic)
     return pic_false_value();   /* should be an error? */
 
   mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
-  assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2);
+  cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
 
-  m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box);
-  n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box);
+  m = translate(pic, pic_sym(a), mac_env, cxt);
+  n = translate(pic, pic_sym(b), mac_env, cxt);
 
   return pic_bool_value(m == n);
 }
 
 static pic_value
-ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_value assoc_box, pic_value *ir)
+ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir)
 {
   if (pic_sym_p(expr)) {
     pic_value r;
-    r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box));
+    r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt));
     *ir = pic_acons(pic, r, expr, *ir);
     return r;
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,
-                    ir_macro_wrap(pic, pic_car(pic, expr), use_env, assoc_box, ir),
-                    ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, assoc_box, ir));
+                    ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir),
+                    ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir));
   }
   else {
     return expr;
@@ -850,19 +865,19 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu
 }
 
 static pic_value
-ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value assoc_box, pic_value *ir)
+ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir)
 {
   if (pic_sym_p(expr)) {
     pic_value r;
     if (pic_test(r = pic_assq(pic, expr, *ir))) {
       return pic_cdr(pic, r);
     }
-    return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box));
+    return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt));
   }
   else if (pic_pair_p(expr)) {
     return pic_cons(pic,
-                    ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, assoc_box, ir),
-                    ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, assoc_box, ir));
+                    ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir),
+                    ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir));
   }
   else {
     return expr;
@@ -872,8 +887,9 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va
 static pic_value
 ir_macro_call(pic_state *pic)
 {
-  pic_value expr, use_env, mac_env, box;
+  pic_value expr, use_env, mac_env;
   struct pic_proc *inject, *compare, *cb;
+  struct pic_dict *cxt;
   pic_value ir = pic_nil_value();
 
   pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
@@ -885,25 +901,25 @@ ir_macro_call(pic_state *pic)
     pic_error(pic, "unexpected type of argument 3");
   }
 
-  box = pic_box(pic, pic_nil_value());
+  cxt = pic_dict_new(pic);
 
   inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
   pic_proc_cv_init(pic, inject, 3);
   pic_proc_cv_set(pic, inject, 0, use_env);
   pic_proc_cv_set(pic, inject, 1, mac_env);
-  pic_proc_cv_set(pic, inject, 2, box);
+  pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt));
 
   compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
   pic_proc_cv_init(pic, compare, 3);
   pic_proc_cv_set(pic, compare, 0, use_env);
   pic_proc_cv_set(pic, compare, 1, mac_env);
-  pic_proc_cv_set(pic, compare, 2, box);
+  pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
 
   cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
 
-  expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), box, &ir);
+  expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir);
   expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare));
-  expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), box, &ir);
+  expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir);
 
   return expr;
 }

src/state.c

@@ -96,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
   register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
+  register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
+  register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");