replace old macroexpand facility with new renamer implementation

include/picrin.h

@@ -55,8 +55,6 @@ typedef struct {
   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;

src/gc.c

@@ -360,8 +360,6 @@ gc_mark_phase(pic_state *pic)
   }
 
   /* macros */
-  for (i = 0; i < pic->mlen; ++i) {
-    gc_mark_object(pic, (struct pic_object *)pic->macros[i]);
   for (i = 0; i < pic->xlen; ++i) {
     gc_mark_object(pic, (struct pic_object *)pic->stx[i]);
   }

src/macro.c

@@ -11,199 +11,19 @@
 
 #define FALLTHROUGH ((void)0)
 
-struct syntactic_env {
-  struct syntactic_env *up;
-
-  struct xhash *tbl;
-};
-
 static void
 define_macro(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);
 }
 
-static struct pic_proc *
-lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name)
-{
-  struct xh_entry *e;
-
-  e = xh_get(env->tbl, name);
-  if (! e)
-    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
-  printf("current ai = %d\n", ai);
-
-  printf("expanding...");
-  pic_debug(pic, obj);
-  puts("");
-#endif
-
-  switch (pic_type(obj)) {
-  case PIC_TT_SYMBOL: {
-    return obj;
-  }
-  case PIC_TT_PAIR: {
-    pic_value v;
-
-    if (! pic_list_p(pic, obj))
-      return obj;
-
-    if (pic_symbol_p(pic_car(pic, obj))) {
-      struct pic_proc *macro;
-      pic_sym sym;
-
-      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) {
-	  pic_error(pic, "syntax error");
-	}
-
-	var = pic_car(pic, pic_cdr(pic, obj));
-	if (pic_pair_p(var)) {
-	  val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
-			 pic_cons(pic, pic_cdr(pic, var),
-				  pic_cdr(pic, pic_cdr(pic, obj))));
-	  var = pic_car(pic, var);
-	}
-	else {
-	  if (pic_length(pic, obj) != 3) {
-	    pic_error(pic, "syntax_error");
-	  }
-	  val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)));
-	}
-	if (! pic_symbol_p(var)) {
-	  pic_error(pic, "syntax error");
-	}
-
-	proc = pic_codegen(pic, val);
-	if (pic->errmsg) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
-	  abort();
-	}
-	v = pic_apply(pic, proc, pic_nil_value());
-	if (pic->errmsg) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
-	  abort();
-	}
-	assert(pic_proc_p(v));
-	define_macro(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));
-      if (macro) {
-	v = pic_apply(pic, macro, pic_cdr(pic, obj));
-	if (pic->errmsg) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
-	  abort();
-	}
-	pic_gc_arena_restore(pic, ai);
-	pic_gc_protect(pic, v);
-
-	v = expand(pic, v, env);
-	pic_gc_arena_restore(pic, ai);
-	pic_gc_protect(pic, v);
-	return v;
-      }
-    }
-
-    v = pic_nil_value();
-    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_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;
-  }
-  case PIC_TT_PROC:
-  case PIC_TT_PORT:
-  case PIC_TT_ERROR:
-  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) */
-  abort();
-}
-
-pic_value pic_macroexpand_2(pic_state *, pic_value);
-
-pic_value
-pic_macroexpand(pic_state *pic, pic_value obj)
-{
-  struct syntactic_env env;
-  pic_value v;
-
-  env.tbl = pic->global_tbl;
-
-#if DEBUG
-  puts("before expand:");
-  pic_debug(pic, obj);
-  puts("");
-#endif
-
-  v = expand(pic, obj, &env);
-
-#if DEBUG
-  puts("after expand:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  v = pic_macroexpand_2(pic, v);
-#if DEBUG
-  puts("after expand:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-  return v;
-}
-
 static pic_sym
 new_uniq_sym(pic_state *pic, pic_sym base)
 {
@@ -249,6 +69,58 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
     car = macroexpand(pic, pic_car(pic, expr), senv);
     if (pic_syntax_p(car)) {
       switch (pic_syntax(car)->kind) {
+      case PIC_STX_DEFMACRO: {
+	pic_value var, val;
+	struct pic_proc *proc;
+
+	if (pic_length(pic, expr) < 2) {
+	  pic_error(pic, "syntax error");
+	}
+
+	var = pic_car(pic, pic_cdr(pic, expr));
+	if (pic_pair_p(var)) {
+	  val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA),
+			 pic_cons(pic, pic_cdr(pic, var),
+				  pic_cdr(pic, pic_cdr(pic, expr))));
+	  var = pic_car(pic, var);
+	}
+	else {
+	  if (pic_length(pic, expr) != 3) {
+	    pic_error(pic, "syntax_error");
+	  }
+	  val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
+	}
+	if (! pic_symbol_p(var)) {
+	  pic_error(pic, "syntax error");
+	}
+
+	proc = pic_codegen(pic, val);
+	if (pic->errmsg) {
+	  printf("macroexpand error: %s\n", pic->errmsg);
+	  abort();
+	}
+	v = pic_apply(pic, proc, pic_nil_value());
+	if (pic->errmsg) {
+	  printf("macroexpand error: %s\n", pic->errmsg);
+	  abort();
+	}
+	assert(pic_proc_p(v));
+	define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
+
+	pic_gc_arena_restore(pic, ai);
+	return pic_false_value();
+      }
+      case PIC_STX_MACRO: {
+	v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr));
+	if (pic->errmsg) {
+	  printf("macroexpand error: %s\n", pic->errmsg);
+	  abort();
+	}
+	pic_gc_arena_restore(pic, ai);
+	pic_gc_protect(pic, v);
+
+	return macroexpand(pic, v, senv);
+      }
       case PIC_STX_LAMBDA: {
 	struct pic_senv *in;
 	pic_value a;
@@ -284,7 +156,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 	  pic_error(pic, "syntax error");
 	}
 
-	var = pic_car(pic, pic_cdr(pic, expr));
+	var = pic_cadr(pic, expr);
 	if (pic_pair_p(var)) {
 	  pic_value a;
 
@@ -402,7 +274,7 @@ pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro)
 }
 
 pic_value
-pic_macroexpand_2(pic_state *pic, pic_value expr)
+pic_macroexpand(pic_state *pic, pic_value expr)
 {
   struct pic_senv *senv;
   pic_value v;

src/state.c

@@ -64,9 +64,6 @@ 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;
-  pic->mcapa = PIC_MACROS_SIZE;
 
   /* identifier table */
   pic->var_tbl = xh_new();