Merge branch 'er-macro'

include/picrin/macro.h

@@ -45,6 +45,7 @@ struct pic_sc {
 
 #define pic_senv(v) ((struct pic_senv *)pic_ptr(v))
 #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
+#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
 
 struct pic_senv *pic_null_syntactic_env(pic_state *pic);
 struct pic_senv *pic_minimal_syntactic_env(pic_state *pic);

piclib/built-in.scm

@@ -10,14 +10,6 @@
     (lambda (expr use-env mac-env)
       (make-syntactic-closure use-env '() (f expr mac-env))))
 
-  (define (er-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (define (rename identifier)
-        (make-syntactic-closure mac-env '() identifier))
-      (define (compare x y)
-        (identifier=? use-env x use-env y))
-      (make-syntactic-closure use-env '() (f expr rename compare))))
-
   (define (walk f obj)
     (if (pair? obj)
         (cons (walk f (car obj))
@@ -37,7 +29,6 @@
 
   (export sc-macro-transformer
           rsc-macro-transformer
-          er-macro-transformer
           ir-macro-transformer))
 
 ;;; bootstrap utilities
@@ -79,7 +70,7 @@
   (define-syntax let
     (er-macro-transformer
      (lambda (expr r compare)
-       (if (identifier? (cadr expr))
+       (if (symbol? (cadr expr))
            (begin
              (define name (cadr expr))
              (define bindings (caddr expr))
@@ -130,7 +121,7 @@
      (lambda (expr r compare?)
        (let ((x (cadr expr)))
          (cond
-          ((symbol? x) (list (r 'quote) x)) ; should test with identifier?
+          ((symbol? x) (list (r 'quote) x))
           ((pair? x) (cond
                       ((compare? (r 'unquote) (car x))
                        (cadr x))
@@ -245,9 +236,9 @@
     (er-macro-transformer
      (lambda (expr r c)
        `(,(r 'define-syntax) ,(cadr expr)
-          ,(r '(sc-macro-transformer
-                (lambda (expr env)
-                  (error "invalid use of auxiliary syntax"))))))))
+           (,(r 'sc-macro-transformer)
+                (,(r 'lambda) (expr env)
+                  (,(r 'error) "invalid use of auxiliary syntax")))))))
 
   (define-auxiliary-syntax else)
   (define-auxiliary-syntax =>)

src/macro.c

@@ -36,6 +36,20 @@ new_uniq_sym(pic_state *pic, pic_sym base)
   return uniq;
 }
 
+static bool
+uniq_sym_p(pic_state *pic, pic_sym sym)
+{
+  const char *name;
+
+  assert(sym >= 0);
+
+  name = pic->sym_pool[sym];
+  if (sym == pic_intern_cstr(pic, name))
+    return false;
+  else
+    return true;
+}
+
 struct pic_senv *
 pic_null_syntactic_env(pic_state *pic)
 {
@@ -293,6 +307,10 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
   case PIC_TT_SYMBOL: {
     struct xh_entry *e;
     pic_sym uniq;
+
+    if (uniq_sym_p(pic, pic_sym(expr))) {
+      return expr;
+    }
     while (true) {
       if ((e = xh_get(senv->tbl, pic_symbol_name(pic, pic_sym(expr)))) != NULL) {
 	if (e->val >= 0)
@@ -659,6 +677,89 @@ pic_macro_identifier_eq_p(pic_state *pic)
   return pic_bool_value(pic_eq_p(x, y));
 }
 
+static pic_value
+er_macro_rename(pic_state *pic)
+{
+  pic_sym sym;
+  struct pic_senv *mac_env;
+  pic_value v;
+
+  pic_get_args(pic, "m", &sym);
+
+  mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
+
+  v = macroexpand(pic, pic_symbol_value(sym), mac_env);
+  if (pic_syntax_p(v)) {
+    return pic_symbol_value(sym);
+  }
+  else {
+    return v;
+  }
+}
+
+static pic_value
+er_macro_compare(pic_state *pic)
+{
+  pic_value a, b;
+  struct pic_senv *use_env;
+
+  pic_get_args(pic, "oo", &a, &b);
+
+  if (! pic_symbol_p(a) || ! pic_symbol_p(b))
+    return pic_false_value();   /* should be an error? */
+
+  use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
+
+  a = macroexpand(pic, a, use_env);
+  b = macroexpand(pic, b, use_env);
+
+  return pic_bool_value(pic_eq_p(a, b));
+}
+
+static pic_value
+er_macro_call(pic_state *pic)
+{
+  pic_value expr, use_env, mac_env;
+  struct pic_proc *rename, *compare, *cb;
+
+  pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
+
+  if (! pic_senv_p(use_env)) {
+    pic_error(pic, "unexpected type of argument 1");
+  }
+  if (! pic_senv_p(mac_env)) {
+    pic_error(pic, "unexpected type of argument 3");
+  }
+
+  rename = pic_proc_new(pic, er_macro_rename);
+  pic_proc_cv_reserve(pic, rename, 2);
+  pic_proc_cv_set(pic, rename, 0, use_env);
+  pic_proc_cv_set(pic, rename, 1, mac_env);
+
+  compare = pic_proc_new(pic, er_macro_compare);
+  pic_proc_cv_reserve(pic, compare, 2);
+  pic_proc_cv_set(pic, compare, 0, use_env);
+  pic_proc_cv_set(pic, compare, 1, mac_env);
+
+  cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
+
+  return pic_apply_argv(pic, cb, 3, expr, pic_obj_value(rename), pic_obj_value(compare));
+}
+
+static pic_value
+pic_macro_er_macro_transformer(pic_state *pic)
+{
+  struct pic_proc *cb, *proc;
+
+  pic_get_args(pic, "l", &cb);
+
+  proc = pic_proc_new(pic, er_macro_call);
+  pic_proc_cv_reserve(pic, proc, 1);
+  pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
+
+  return pic_obj_value(proc);
+}
+
 void
 pic_init_macro(pic_state *pic)
 {
@@ -667,6 +768,7 @@ pic_init_macro(pic_state *pic)
     pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
+    pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
   }
   ENDLIBRARY(pic);
 }

src/vm.c

@@ -198,7 +198,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
 	    *m = pic_sym(v);
 	  }
 	  else {
-	    pic_error(pic, "pic_get_args: expected vector");
+	    pic_error(pic, "pic_get_args: expected symbol");
 	  }
 	  i++;
 	}