move macroexpander to codegen.c

extlib/benz/codegen.c

@@ -4,6 +4,347 @@
 
 #include "picrin.h"
 
+/**
+ * macro expander
+ */
+
+static pic_sym *
+lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env)
+{
+  xh_entry *e;
+
+  assert(pic_var_p(var));
+
+  while (env != NULL) {
+    if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) {
+      return xh_val(e, pic_sym *);
+    }
+    env = env->up;
+  }
+  return NULL;
+}
+
+static pic_sym *
+resolve(pic_state *pic, pic_value var, struct pic_env *env)
+{
+  pic_sym *uid;
+
+  assert(pic_var_p(var));
+  assert(env != NULL);
+
+  while ((uid = lookup(pic, var, env)) == NULL) {
+    if (pic_sym_p(var)) {
+      break;
+    }
+    env = pic_id_ptr(var)->env;
+    var = pic_id_ptr(var)->var;
+  }
+  if (uid == NULL) {
+    while (env->up != NULL) {
+      env = env->up;
+    }
+    uid = pic_add_variable(pic, env, var);
+  }
+  return uid;
+}
+
+static void
+define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
+{
+  pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
+}
+
+static struct pic_proc *
+find_macro(pic_state *pic, pic_sym *uid)
+{
+  if (! pic_dict_has(pic, pic->macros, uid)) {
+    return NULL;
+  }
+  return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid));
+}
+
+static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value);
+static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *);
+
+static pic_value
+expand_var(pic_state *pic, pic_value var, struct pic_env *env)
+{
+  return pic_obj_value(resolve(pic, var, env));
+}
+
+static pic_value
+expand_quote(pic_state *pic, pic_value expr)
+{
+  return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr));
+}
+
+static pic_value
+expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value x, head, tail;
+
+  if (pic_pair_p(obj)) {
+    head = expand(pic, pic_car(pic, obj), env, deferred);
+    tail = expand_list(pic, pic_cdr(pic, obj), env, deferred);
+    x = pic_cons(pic, head, tail);
+  } else {
+    x = expand(pic, obj, env, deferred);
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, x);
+  return x;
+}
+
+static pic_value
+expand_defer(pic_state *pic, pic_value expr, pic_value deferred)
+{
+  pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#<invalid>) */
+
+  pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred)));
+
+  return skel;
+}
+
+static void
+expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env)
+{
+  pic_value defer, val, src, dst, it;
+
+  deferred = pic_car(pic, deferred);
+
+  pic_for_each (defer, pic_reverse(pic, deferred), it) {
+    src = pic_car(pic, defer);
+    dst = pic_cdr(pic, defer);
+
+    val = expand_lambda(pic, src, env);
+
+    /* copy */
+    pic_set_car(pic, dst, pic_car(pic, val));
+    pic_set_cdr(pic, dst, pic_cdr(pic, val));
+  }
+}
+
+static pic_value
+expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
+{
+  pic_value formal, body;
+  struct pic_env *in;
+  pic_value a, deferred;
+
+  if (pic_length(pic, expr) < 2) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  in = pic_make_env(pic, env);
+
+  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
+    pic_value var = pic_car(pic, a);
+
+    if (! pic_var_p(var)) {
+      pic_errorf(pic, "syntax error");
+    }
+    pic_add_variable(pic, in, var);
+  }
+  if (pic_var_p(a)) {
+    pic_add_variable(pic, in, a);
+  }
+  else if (! pic_nil_p(a)) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  deferred = pic_list1(pic, pic_nil_value());
+
+  formal = expand_list(pic, pic_cadr(pic, expr), in, deferred);
+  body = expand_list(pic, pic_cddr(pic, expr), in, deferred);
+
+  expand_deferred(pic, deferred, in);
+
+  return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body));
+}
+
+static pic_value
+expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
+{
+  pic_sym *uid;
+  pic_value var, val;
+
+  while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
+    var = pic_car(pic, pic_cadr(pic, expr));
+    val = pic_cdr(pic, pic_cadr(pic, expr));
+
+    expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
+  }
+
+  if (pic_length(pic, expr) != 3) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  var = pic_cadr(pic, expr);
+  if (! pic_var_p(var)) {
+    pic_errorf(pic, "binding to non-variable object");
+  }
+  if ((uid = pic_find_variable(pic, env, var)) == NULL) {
+    uid = pic_add_variable(pic, env, var);
+  }
+  val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
+
+  return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val);
+}
+
+static pic_value
+expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
+{
+  pic_value var, val;
+  pic_sym *uid;
+
+  if (pic_length(pic, expr) != 3) {
+    pic_errorf(pic, "syntax error");
+  }
+
+  var = pic_cadr(pic, expr);
+  if (! pic_var_p(var)) {
+    pic_errorf(pic, "binding to non-variable object");
+  }
+  if ((uid = pic_find_variable(pic, env, var)) == NULL) {
+    uid = pic_add_variable(pic, env, var);
+  } else {
+    pic_warnf(pic, "redefining syntax variable: ~s", var);
+  }
+
+  val = pic_cadr(pic, pic_cdr(pic, expr));
+
+  pic_try {
+    val = pic_eval(pic, val, env);
+  } pic_catch {
+    pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic));
+  }
+
+  if (! pic_proc_p(val)) {
+    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
+  }
+
+  define_macro(pic, uid, pic_proc_ptr(val));
+
+  return pic_undef_value();
+}
+
+static pic_value
+expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env)
+{
+  pic_value v;
+
+#if DEBUG
+  puts("before expand-1:");
+  pic_debug(pic, expr);
+  puts("");
+#endif
+
+  pic_try {
+    v = pic_apply2(pic, mac, expr, pic_obj_value(env));
+  } pic_catch {
+    pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic));
+  }
+
+#if DEBUG
+  puts("after expand-1:");
+  pic_debug(pic, v);
+  puts("");
+#endif
+
+  return v;
+}
+
+static pic_value
+expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
+{
+  switch (pic_type(expr)) {
+  case PIC_TT_ID:
+  case PIC_TT_SYMBOL: {
+    return expand_var(pic, expr, env);
+  }
+  case PIC_TT_PAIR: {
+    struct pic_proc *mac;
+
+    if (! pic_list_p(expr)) {
+      pic_errorf(pic, "cannot expand improper list: ~s", expr);
+    }
+
+    if (pic_var_p(pic_car(pic, expr))) {
+      pic_sym *functor;
+
+      functor = resolve(pic, pic_car(pic, expr), env);
+
+      if (functor == pic->uDEFINE_MACRO) {
+        return expand_defmacro(pic, expr, env);
+      }
+      else if (functor == pic->uLAMBDA) {
+        return expand_defer(pic, expr, deferred);
+      }
+      else if (functor == pic->uDEFINE) {
+        return expand_define(pic, expr, env, deferred);
+      }
+      else if (functor == pic->uQUOTE) {
+        return expand_quote(pic, expr);
+      }
+
+      if ((mac = find_macro(pic, functor)) != NULL) {
+        return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred);
+      }
+    }
+    return expand_list(pic, expr, env, deferred);
+  }
+  default:
+    return expr;
+  }
+}
+
+static pic_value
+expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value v;
+
+#if DEBUG
+  printf("[expand] expanding... ");
+  pic_debug(pic, expr);
+  puts("");
+#endif
+
+  v = expand_node(pic, expr, env, deferred);
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, v);
+  return v;
+}
+
+pic_value
+pic_expand(pic_state *pic, pic_value expr, struct pic_env *env)
+{
+  pic_value v, deferred;
+
+#if DEBUG
+  puts("before expand:");
+  pic_debug(pic, expr);
+  puts("");
+#endif
+
+  deferred = pic_list1(pic, pic_nil_value());
+
+  v = expand(pic, expr, env, deferred);
+
+  expand_deferred(pic, deferred, env);
+
+#if DEBUG
+  puts("after expand:");
+  pic_debug(pic, v);
+  puts("");
+#endif
+
+  return v;
+}
+
 typedef xvect_t(pic_sym *) xvect;
 
 #define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x))

extlib/benz/include/picrin/macro.h

@@ -36,6 +36,7 @@ pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value);
 void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *);
 pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value);
 
+bool pic_var_p(pic_value);
 pic_sym *pic_var_name(pic_state *, pic_value);
 
 #if defined(__cplusplus)

extlib/benz/macro.c

@@ -4,7 +4,7 @@
 
 #include "picrin.h"
 
-static bool
+bool
 pic_var_p(pic_value obj)
 {
   return pic_sym_p(obj) || pic_id_p(obj);
@@ -57,46 +57,6 @@ pic_uniq(pic_state *pic, pic_value var)
   return pic_intern(pic, str);
 }
 
-static pic_sym *
-lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env)
-{
-  xh_entry *e;
-
-  assert(pic_var_p(var));
-
-  while (env != NULL) {
-    if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) {
-      return xh_val(e, pic_sym *);
-    }
-    env = env->up;
-  }
-  return NULL;
-}
-
-static pic_sym *
-resolve(pic_state *pic, pic_value var, struct pic_env *env)
-{
-  pic_sym *uid;
-
-  assert(pic_var_p(var));
-  assert(env != NULL);
-
-  while ((uid = lookup(pic, var, env)) == NULL) {
-    if (pic_sym_p(var)) {
-      break;
-    }
-    env = pic_id_ptr(var)->env;
-    var = pic_id_ptr(var)->var;
-  }
-  if (uid == NULL) {
-    while (env->up != NULL) {
-      env = env->up;
-    }
-    uid = pic_add_variable(pic, env, var);
-  }
-  return uid;
-}
-
 pic_sym *
 pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var)
 {
@@ -132,335 +92,6 @@ pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var
   return xh_val(e, pic_sym *);
 }
 
-static void
-define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
-{
-  pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
-}
-
-static struct pic_proc *
-find_macro(pic_state *pic, pic_sym *uid)
-{
-  if (! pic_dict_has(pic, pic->macros, uid)) {
-    return NULL;
-  }
-  return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid));
-}
-
-static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value);
-static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *);
-
-static pic_value
-expand_var(pic_state *pic, pic_value var, struct pic_env *env)
-{
-  return pic_obj_value(resolve(pic, var, env));
-}
-
-static pic_value
-expand_quote(pic_state *pic, pic_value expr)
-{
-  return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr));
-}
-
-static pic_value
-expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value x, head, tail;
-
-  if (pic_pair_p(obj)) {
-    head = expand(pic, pic_car(pic, obj), env, deferred);
-    tail = expand_list(pic, pic_cdr(pic, obj), env, deferred);
-    x = pic_cons(pic, head, tail);
-  } else {
-    x = expand(pic, obj, env, deferred);
-  }
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, x);
-  return x;
-}
-
-static pic_value
-expand_defer(pic_state *pic, pic_value expr, pic_value deferred)
-{
-  pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#<invalid>) */
-
-  pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred)));
-
-  return skel;
-}
-
-static void
-expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env)
-{
-  pic_value defer, val, src, dst, it;
-
-  deferred = pic_car(pic, deferred);
-
-  pic_for_each (defer, pic_reverse(pic, deferred), it) {
-    src = pic_car(pic, defer);
-    dst = pic_cdr(pic, defer);
-
-    val = expand_lambda(pic, src, env);
-
-    /* copy */
-    pic_set_car(pic, dst, pic_car(pic, val));
-    pic_set_cdr(pic, dst, pic_cdr(pic, val));
-  }
-}
-
-static pic_value
-expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
-{
-  pic_value formal, body;
-  struct pic_env *in;
-  pic_value a, deferred;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_errorf(pic, "syntax error");
-  }
-
-  in = pic_make_env(pic, env);
-
-  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
-    pic_value var = pic_car(pic, a);
-
-    if (! pic_var_p(var)) {
-      pic_errorf(pic, "syntax error");
-    }
-    pic_add_variable(pic, in, var);
-  }
-  if (pic_var_p(a)) {
-    pic_add_variable(pic, in, a);
-  }
-  else if (! pic_nil_p(a)) {
-    pic_errorf(pic, "syntax error");
-  }
-
-  deferred = pic_list1(pic, pic_nil_value());
-
-  formal = expand_list(pic, pic_cadr(pic, expr), in, deferred);
-  body = expand_list(pic, pic_cddr(pic, expr), in, deferred);
-
-  expand_deferred(pic, deferred, in);
-
-  return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body));
-}
-
-static pic_value
-expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
-{
-  pic_sym *uid;
-  pic_value var, val;
-
-  while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
-    var = pic_car(pic, pic_cadr(pic, expr));
-    val = pic_cdr(pic, pic_cadr(pic, expr));
-
-    expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
-  }
-
-  if (pic_length(pic, expr) != 3) {
-    pic_errorf(pic, "syntax error");
-  }
-
-  var = pic_cadr(pic, expr);
-  if (! pic_var_p(var)) {
-    pic_errorf(pic, "binding to non-variable object");
-  }
-  if ((uid = pic_find_variable(pic, env, var)) == NULL) {
-    uid = pic_add_variable(pic, env, var);
-  }
-  val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
-
-  return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val);
-}
-
-static pic_value
-expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
-{
-  pic_value var, val;
-  pic_sym *uid;
-
-  if (pic_length(pic, expr) != 3) {
-    pic_errorf(pic, "syntax error");
-  }
-
-  var = pic_cadr(pic, expr);
-  if (! pic_var_p(var)) {
-    pic_errorf(pic, "binding to non-variable object");
-  }
-  if ((uid = pic_find_variable(pic, env, var)) == NULL) {
-    uid = pic_add_variable(pic, env, var);
-  } else {
-    pic_warnf(pic, "redefining syntax variable: ~s", var);
-  }
-
-  val = pic_cadr(pic, pic_cdr(pic, expr));
-
-  pic_try {
-    val = pic_eval(pic, val, env);
-  } pic_catch {
-    pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, uid, pic_proc_ptr(val));
-
-  return pic_undef_value();
-}
-
-static pic_value
-expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env)
-{
-  pic_value v;
-
-#if DEBUG
-  puts("before expand-1:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  pic_try {
-    v = pic_apply2(pic, mac, expr, pic_obj_value(env));
-  } pic_catch {
-    pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic));
-  }
-
-#if DEBUG
-  puts("after expand-1:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return v;
-}
-
-static pic_value
-expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
-{
-  switch (pic_type(expr)) {
-  case PIC_TT_ID:
-  case PIC_TT_SYMBOL: {
-    return expand_var(pic, expr, env);
-  }
-  case PIC_TT_PAIR: {
-    struct pic_proc *mac;
-
-    if (! pic_list_p(expr)) {
-      pic_errorf(pic, "cannot expand improper list: ~s", expr);
-    }
-
-    if (pic_var_p(pic_car(pic, expr))) {
-      pic_sym *functor;
-
-      functor = resolve(pic, pic_car(pic, expr), env);
-
-      if (functor == pic->uDEFINE_MACRO) {
-        return expand_defmacro(pic, expr, env);
-      }
-      else if (functor == pic->uLAMBDA) {
-        return expand_defer(pic, expr, deferred);
-      }
-      else if (functor == pic->uDEFINE) {
-        return expand_define(pic, expr, env, deferred);
-      }
-      else if (functor == pic->uQUOTE) {
-        return expand_quote(pic, expr);
-      }
-
-      if ((mac = find_macro(pic, functor)) != NULL) {
-        return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred);
-      }
-    }
-    return expand_list(pic, expr, env, deferred);
-  }
-  default:
-    return expr;
-  }
-}
-
-static pic_value
-expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v;
-
-#if DEBUG
-  printf("[expand] expanding... ");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  v = expand_node(pic, expr, env, deferred);
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, v);
-  return v;
-}
-
-pic_value
-pic_expand(pic_state *pic, pic_value expr, struct pic_env *env)
-{
-  pic_value v, deferred;
-
-#if DEBUG
-  puts("before expand:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  deferred = pic_list1(pic, pic_nil_value());
-
-  v = expand(pic, expr, env, deferred);
-
-  expand_deferred(pic, deferred, env);
-
-#if DEBUG
-  puts("after expand:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return v;
-}
-
-static pic_value
-defmacro_call(pic_state *pic)
-{
-  struct pic_proc *self = pic_get_proc(pic);
-  pic_value args, tmp, proc;
-
-  pic_get_args(pic, "oo", &args, &tmp);
-
-  proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer");
-
-  return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args));
-}
-
-void
-pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
-{
-  struct pic_proc *proc, *trans;
-
-  trans = pic_make_proc(pic, func, pic_symbol_name(pic, name));
-
-  pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id);
-
-  proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
-  pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
-
-  /* symbol registration */
-  define_macro(pic, id, proc);
-
-  /* auto export! */
-  pic_export(pic, name);
-}
-
 static pic_value
 pic_macro_identifier_p(pic_state *pic)
 {
@@ -536,7 +167,7 @@ pic_macro_variable_eq_p(pic_state *pic)
 
     id1 = pic_id_ptr(var1);
     id2 = pic_id_ptr(var2);
-    return pic_bool_value(resolve(pic, id1->var, id1->env) == resolve(pic, id2->var, id2->env));
+    return pic_bool_value(pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env)));
   }
   return pic_false_value();
 }

extlib/benz/vm.c

@@ -499,6 +499,38 @@ pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *co
   pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv)));
 }
 
+static pic_value
+defmacro_call(pic_state *pic)
+{
+  struct pic_proc *self = pic_get_proc(pic);
+  pic_value args, tmp, proc;
+
+  pic_get_args(pic, "oo", &args, &tmp);
+
+  proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer");
+
+  return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args));
+}
+
+void
+pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
+{
+  struct pic_proc *proc, *trans;
+
+  trans = pic_make_proc(pic, func, pic_symbol_name(pic, name));
+
+  pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id);
+
+  proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
+  pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
+
+  /* symbol registration */
+  pic_dict_set(pic, pic->macros, id, pic_obj_value(proc));
+
+  /* auto export! */
+  pic_export(pic, name);
+}
+
 static void
 vm_push_cxt(pic_state *pic)
 {