From 7b8ee3eb97c691bcece7f0dcf0a113f52dbc28fb Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 27 Nov 2013 17:26:07 +0900
Subject: [PATCH] add er-macro-transformer

---
 piclib/built-in.scm | 17 ++++++++++++++
 src/macro.c         | 57 +++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 72 insertions(+), 2 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index f31b1b57..b8ce4658 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -187,6 +187,23 @@
     (lambda (expr use-env mac-env)
       (make-syntactic-closure use-env '() (f expr mac-env)))))
 
+(define er-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      ((lambda (rename compare) (f expr rename compare))
+       ((lambda (renames)
+          (lambda (identifier)
+            ((lambda (cell)
+               (if cell
+                   (cdr cell)
+                   ((lambda (name)
+                      (set! renames (cons (cons identifier name) renames))
+                      name)
+                    (make-syntactic-closure mac-env '() identifier))))
+             (assq identifier renames))))
+        '())
+       (lambda (x y) (identifier=? use-env x use-env y))))))
+
 (define-macro (let bindings . body)
   (if (symbol? bindings)
       (begin
diff --git a/src/macro.c b/src/macro.c
index e9eff1b2..eeb050f1 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -102,6 +102,18 @@ sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return sc;
 }
 
+static bool
+pic_identifier_p(pic_value obj)
+{
+  if (pic_symbol_p(obj)) {
+    return true;
+  }
+  if (pic_sc_p(obj)) {
+    return pic_identifier_p(pic_sc(obj)->expr);
+  }
+  return false;
+}
+
 static void
 pic_defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct pic_senv *mac_env)
 {
@@ -395,7 +407,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
 }
 
 static pic_value
-pic_make_sc(pic_state *pic)
+pic_macro_make_sc(pic_state *pic)
 {
   pic_value senv, free_vars, expr;
   struct pic_sc *sc;
@@ -411,8 +423,49 @@ pic_make_sc(pic_state *pic)
   return pic_obj_value(sc);
 }
 
+static pic_value
+pic_macro_identifier_p(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_bool_value(pic_identifier_p(obj));
+}
+
+static pic_value
+pic_macro_identifier_eq_p(pic_state *pic)
+{
+  pic_value e, x, f, y;
+  struct pic_senv *e1, *e2;
+
+  pic_get_args(pic, "oooo", &e, &x, &f, &y);
+
+  if (! pic_senv_p(e)) {
+    pic_error(pic, "unexpected type of argument 1");
+  }
+  e1 = pic_senv(e);
+  if (! pic_identifier_p(x)) {
+    pic_error(pic, "unexpected type of argument 2");
+  }
+  if (! pic_senv_p(f)) {
+    pic_error(pic, "unexpected type of argument 3");
+  }
+  e2 = pic_senv(f);
+  if (! pic_identifier_p(y)) {
+    pic_error(pic, "unexpected type of argument 4");
+  }
+
+  x = macroexpand(pic, x, e1);
+  y = macroexpand(pic, y, e2);
+
+  return pic_bool_value(pic_eq_p(x, y));
+}
+
 void
 pic_init_macro(pic_state *pic)
 {
-  pic_defun(pic, "make-syntactic-closure", pic_make_sc);
+  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);
 }