From 6d0f75dd7eb2954d2920e95e15c1e7936565fc56 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 28 Nov 2013 18:39:27 +0900
Subject: [PATCH] add ir-macro-transformer

---
 piclib/built-in.scm | 62 +++++++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 27 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index b8ce4658..7e6665d6 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -177,33 +177,6 @@
       (single-for-each f list)
       (multiple-for-each f (cons list lists))))
 
-(define sc-macro-transformer
-  (lambda (f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure mac-env '() (f expr use-env)))))
-
-(define rsc-macro-transformer
-  (lambda (f)
-    (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
@@ -561,3 +534,38 @@
       (bytevector-copy! res (bytevector-length v) w)
       res))
   (fold bytevector-append-2-inv #() vs))
+
+;;; hygienic macros
+
+(define (walk f obj)
+  (write obj)
+  (newline)
+  (if (pair? obj)
+      (cons (walk f (car obj)) (walk f (cdr obj)))
+      (if (vector? obj)
+	  (list->vector (map (lambda (x) (walk f x)) (vector->list obj)))
+	  (f obj))))
+
+(define (sc-macro-transformer f)
+  (lambda (expr use-env mac-env)
+    (make-syntactic-closure mac-env '() (f expr use-env))))
+
+(define (rsc-macro-transformer f)
+  (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 (ir-macro-transformer f)
+  (lambda (expr use-env mac-env)
+    (define (inject identifier)
+      (make-syntactic-closure use-env '() identifier))
+    (define (compare x y)
+      (identifier=? use-env x use-env y))
+    (make-syntactic-closure mac-env '() (f (walk inject expr) inject compare))))