~ chicken-core (chicken-5) 045a0f256d9a5361871cc8fe4d4da52de0fcef75

commit 045a0f256d9a5361871cc8fe4d4da52de0fcef75
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 31 01:06:27 2009 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 31 01:06:27 2009 +0100

    rename and compare procedures for ER macros handle any sexp

diff --git a/expand.scm b/expand.scm
index 91c56f6a..b5d37898 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1,4 +1,4 @@
-;;;; expand.scm
+;;;; expand.scm - The HI/LO expander
 ;
 ; Copyright (c) 2008-2009, The Chicken Team
 ; All rights reserved.
@@ -709,7 +709,12 @@
 (define ((##sys#er-transformer handler) form se dse)
   (let ((renv '()))			; keep rename-environment for this expansion
     (define (rename sym)
-      (cond ((assq sym renv) => 
+      (cond ((pair? sym)
+	     (cons (rename (car sym)) (rename (cdr sym))))
+	    ((vector? sym)
+	     (list->vector (rename (vector->list sym))))
+	    ((not (symbol? sym)) sym)
+	    ((assq sym renv) => 
 	     (lambda (a) 
 	       (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
 	       (cdr a)))
@@ -730,26 +735,37 @@
 	       a))))
     (define (compare s1 s2)
       (let ((result
-	     (if (and (symbol? s1) (symbol? s2))
-		 (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
-				(lookup2 1 s1 dse)
-				s1) )
-		       (ss2 (or (##sys#get s2 '##core#macro-alias)
-				(lookup2 2 s2 dse)
-				s2) ) )
-		   (cond ((symbol? ss1)
-			  (cond ((symbol? ss2) 
-				 (eq? (or (##sys#get ss1 '##core#primitive) ss1)
-				      (or (##sys#get ss2 '##core#primitive) ss2)))
-				((assq ss1 (##sys#macro-environment)) =>
-				 (lambda (a) (eq? (cdr a) ss2)))
-				(else #f) ) )
-			 ((symbol? ss2)
-			  (cond ((assq ss2 (##sys#macro-environment)) =>
-				 (lambda (a) (eq? ss1 (cdr a))))
-				(else #f)))
-			 (else (eq? ss1 ss2))))
-		 (eq? s1 s2))) )
+	     (cond ((pair? s1)
+		    (and (pair? s2)
+			 (compare (car s1) (car s2))
+			 (compare (cdr s1) (cdr s2))))
+		   ((vector? s1)
+		    (and (vector? s2)
+			 (let ((len (vector-length s1)))
+			   (and (fx= len (vector-length s2))
+				(do ((i 0 (fx+ i 1))
+				     (f #t (compare (vector-ref s1 i) (vector-ref s2 i))))
+				    ((or (fx>= i len) (not f)) f))))))
+		   ((and (symbol? s1) (symbol? s2))
+		    (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
+				   (lookup2 1 s1 dse)
+				   s1) )
+			  (ss2 (or (##sys#get s2 '##core#macro-alias)
+				   (lookup2 2 s2 dse)
+				   s2) ) )
+		      (cond ((symbol? ss1)
+			     (cond ((symbol? ss2) 
+				    (eq? (or (##sys#get ss1 '##core#primitive) ss1)
+					 (or (##sys#get ss2 '##core#primitive) ss2)))
+				   ((assq ss1 (##sys#macro-environment)) =>
+				    (lambda (a) (eq? (cdr a) ss2)))
+				   (else #f) ) )
+			    ((symbol? ss2)
+			     (cond ((assq ss2 (##sys#macro-environment)) =>
+				    (lambda (a) (eq? ss1 (cdr a))))
+				   (else #f)))
+			    (else (eq? ss1 ss2)))))
+		   (else (eq? s1 s2))) ) ) 
 	(dd `(COMPARE: ,s1 ,s2 --> ,result)) 
 	result))
     (define (lookup2 n sym dse)
diff --git a/manual/Modules and macros b/manual/Modules and macros
index 73f02a65..3a7035ae 100644
--- a/manual/Modules and macros	
+++ b/manual/Modules and macros	
@@ -194,6 +194,12 @@ not hygienic.  Like {{loop}}, it must be written using procedurally:
            (,(r 'if) (,(r 'not) ,test) (exit #f))
            ,@body))))
 
+Note: this implementation of explicit-renaming macros allows passing
+arbitrary expressions to the renaming and comparison procedures. When
+being renamed, a fresh copy of the expression will be produced, with all
+identifiers renamed appropriately. Comparison also supports arbitrary
+expressions as arguments.
+
 
 === Modules
 
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 95ac3334..fb4b9a39 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1,4 +1,4 @@
-;;;; mtest.scm - various macro tests
+;;;; syntax-tests.scm - various macro tests
 
 
 (use extras)
@@ -384,3 +384,22 @@
   (import scheme m0001 extras)
   (pp (foo bar)))
 
+
+;;; renaming of arbitrary structures
+
+(module m1 (s1 s2)
+
+  (import scheme)
+
+  (define-syntax s1 (syntax-rules () ((_ x) (list x))))
+
+  (define-syntax s2
+    (lambda (x r c)
+      (r `(vector (s1 ,(cadr x)))))) )	; without renaming the local version of `s1'
+					; below will be captured 
+
+(import m1)
+
+(let-syntax ((s1 (syntax-rules () ((_ x) x))))
+  (assert (equal? '#((99)) (s2 99))))
+