~ chicken-core (chicken-5) 318b0a038b3858a1b9f7d0ae7892e65b301eb68f
commit 318b0a038b3858a1b9f7d0ae7892e65b301eb68f
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Mar 14 14:13:08 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Mar 14 14:13:08 2011 +0100
argh
diff --git a/expand.scm b/expand.scm
index 5f9d98f2..8efd4460 100644
--- a/expand.scm
+++ b/expand.scm
@@ -269,11 +269,12 @@
(define ##sys#enable-runtime-macros #f)
(define (##sys#module-rename sym prefix)
- (##sys#string->symbol
- (string-append
- (##sys#slot prefix 1)
- "#"
- (##sys#slot sym 1) ) ) )
+ (let ((qualified-symbol (##sys#string->symbol (string-append
+ (##sys#slot prefix 1)
+ "#"
+ (##sys#slot sym 1) ) )))
+ (putp qualified-symbol '##core#real-name sym)
+ qualified-symbol) )
(define (##sys#alias-global-hook sym assign where)
(define (mrename sym)
@@ -1388,18 +1389,15 @@
(cond ((eq? n 0)
(##sys#check-syntax 'unquote x '(_ _))
(car tail))
- (else
- `(##sys#cons (##core#quote ,%unquote)
- ,(walk tail (fx- n 1)) ) )))
+ (else (list '##sys#cons `(##core#quote ,%unquote)
+ (walk tail (fx- n 1)) ) )))
((c %quasiquote head)
- `(##sys#cons (##core#quote ,%quasiquote)
- ,(walk tail (fx+ n 1)) ) )
+ (list '##sys#cons `(##core#quote ,%quasiquote)
+ (walk tail (fx+ n 1)) ) )
((and (pair? head) (c %unquote-splicing (car head)))
(cond ((eq? n 0)
(##sys#check-syntax 'unquote-splicing head '(_ _))
- (walk
- `(##sys#append ,(walk (cadr head) 0) ,(walk tail 0))
- 0))
+ `(##sys#append ,(cadr head) ,(walk tail n)))
(else
`(##sys#cons
(##sys#cons (##core#quote ,%unquote-splicing)
@@ -1408,9 +1406,17 @@
(else
`(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
(define (simplify x)
- (cond ((match-expression x '(##sys#append a (##core#quote ())) '(a))
- => (lambda (env)
- (simplify (cdr (assq 'a env))) ))
+ (cond ((match-expression x '(##sys#cons a '()) '(a))
+ => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
+ ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
+ => (lambda (env)
+ (let ([bxs (assq 'b env)])
+ (if (fx< (length bxs) 32)
+ (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
+ ,@(cdr bxs) ) )
+ x) ) ) )
+ ((match-expression x '(##sys#append a '()) '(a))
+ => (lambda (env) (##sys#slot (assq 'a env) 1)) )
(else x) ) )
(##sys#check-syntax 'quasiquote form '(_ _))
(walk (cadr form) 0) ) ) ) )
diff --git a/library.scm b/library.scm
index 386fcd8d..2c64448b 100644
--- a/library.scm
+++ b/library.scm
@@ -3920,9 +3920,7 @@ EOF
(define (make-composite-condition c1 . conds)
(let ([conds (cons c1 conds)])
- (for-each
- (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition))
- conds)
+ (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
(##sys#make-structure
'condition
(apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 545c086e..4f6677d4 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -39,8 +39,6 @@ if test -n "$MSYSTEM"; then
cp ../libchicken.dll .
fi
-rm -f a.out *.exe *.import.* *.so
-
compile="../csc -compiler $CHICKEN -v -I.. -L.. -include-path .. -o a.out"
compile_s="../csc -s -compiler $CHICKEN -v -I.. -L.. -include-path .."
interpret="../csi -n -include-path .."
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 16878b23..3d151ee2 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -196,6 +196,22 @@
(bar foo))))
)
+;;; strip-syntax on renamed module identifiers, as well as core identifiers
+(module foo (bar)
+ (import chicken scheme)
+
+ (define bar 1))
+
+(import foo)
+
+(define-syntax baz
+ (er-macro-transformer
+ (lambda (e r c)
+ `',(strip-syntax (r 'bar)))))
+
+(t 'bar (baz bar))
+(t 'bar (baz void))
+
;;; alternative ellipsis test (SRFI-46)
(define-syntax foo
Trap