~ chicken-core (chicken-5) b355fb179d35a9d6a88117af54ef520b330bc06e
commit b355fb179d35a9d6a88117af54ef520b330bc06e
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 29 02:43:40 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 29 02:43:40 2010 -0400
map gensyms in se back to their original name when stripping (fixes #398), thanks to sjamaan, who also provided a test-case
diff --git a/compiler.scm b/compiler.scm
index 5ae4664f..32c7fa66 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -610,7 +610,7 @@
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
(aliases (map gensym vars))
- (se2 (append (map cons vars aliases) se)) )
+ (se2 (##sys#extend-se se vars aliases)))
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
@@ -647,7 +647,7 @@
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
- (se2 (append (map cons vars aliases) se))
+ (se2 (##sys#extend-se se vars aliases))
(body0 (##sys#canonicalize-body
obody se2 compiler-syntax-enabled))
(body (walk body0 (append aliases e) se2 #f #f))
@@ -881,7 +881,7 @@
(let* ([vars (cadr x)]
[obody (cddr x)]
[aliases (map gensym vars)]
- (se2 (append (map cons vars aliases) se))
+ (se2 (##sys#extend-se se vars aliases))
[body
(walk
(##sys#canonicalize-body obody se2 compiler-syntax-enabled)
diff --git a/eval.scm b/eval.scm
index b531547b..98564138 100644
--- a/eval.scm
+++ b/eval.scm
@@ -392,7 +392,7 @@
[vars (map (lambda (x) (car x)) bindings)]
(aliases (map gensym vars))
[e2 (cons aliases e)]
- (se2 (append (map cons vars aliases) se))
+ (se2 (##sys#extend-se se vars aliases))
[body (##sys#compile-to-closure
(##sys#canonicalize-body (cddr x) se2 #f)
e2
@@ -465,7 +465,7 @@
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
- (se2 (append (map cons vars aliases) se))
+ (se2 (##sys#extend-se se vars aliases))
(e2 (cons aliases e))
(body
(##sys#compile-to-closure
diff --git a/expand.scm b/expand.scm
index 0ada41fd..a37d1ce3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -116,6 +116,12 @@
(define strip-syntax ##sys#strip-syntax)
+(define (##sys#extend-se se vars #!optional (aliases (map gensym vars)))
+ (for-each
+ (cut ##sys#put! <> '##core#real-name <>)
+ aliases vars)
+ (append (map cons vars aliases) se))
+
;;; Macro handling
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 65242530..49aafcbd 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -120,6 +120,51 @@
y)))
)
+;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
+(let ((a 1))
+ (letrec-syntax
+ ((foo (syntax-rules ()
+ ((_ b)
+ (bar a b))))
+ (bar (syntax-rules ()
+ ((_ c d)
+ (cons c (let ((c 3))
+ (list d c 'c)))))))
+ (let ((a 2))
+ (t '(1 2 3 a) (foo a)))))
+
+;; ER equivalent
+(let ((a 1))
+ (letrec-syntax
+ ((foo (er-macro-transformer
+ (lambda (x r c)
+ `(,(r 'bar) ,(r 'a) ,(cadr x)))))
+ (bar (er-macro-transformer
+ (lambda (x r c)
+ (let ((c (cadr x))
+ (d (caddr x)))
+ `(,(r 'cons) ,c
+ (,(r 'let) ((,c 3))
+ (,(r 'list) ,d ,c ',c))))))))
+ (let ((a 2))
+ (t '(1 2 3 a) (foo a)))))
+
+;; IR equivalent
+(let ((a 1))
+ (letrec-syntax
+ ((foo (ir-macro-transformer
+ (lambda (x i c)
+ `(bar a ,(cadr x)))))
+ (bar (ir-macro-transformer
+ (lambda (x i c)
+ (let ((c (cadr x))
+ (d (caddr x)))
+ `(cons ,c
+ (let ((,c 3))
+ (list ,d ,c ',c))))))))
+ (let ((a 2))
+ (t '(1 2 3 a) (foo a)))))
+
(define-syntax kw
(syntax-rules (baz)
((_ baz) "baz")
Trap