summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/Makefile.am2
-rw-r--r--module/ice-9/psyntax-pp.scm36
-rw-r--r--module/ice-9/psyntax.scm19
-rw-r--r--module/ice-9/r6rs-libraries.scm2
-rw-r--r--test-suite/tests/syncase.test16
5 files changed, 53 insertions, 22 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 0133ddd88..93fe9c8c4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -32,6 +32,8 @@ nobase_ccache_DATA += ice-9/eval.go
EXTRA_DIST += ice-9/eval.scm
ETAGS_ARGS += ice-9/eval.scm
+ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm
+
# We can compile these in any order, but it's fastest if we compile
# psyntax and boot-9 first, then the compiler itself, then the rest of
# the code.
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7475983e5..68d1bf6eb 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1950,7 +1950,7 @@
(values
(syntax->datum id)
r
- w
+ '((top))
#f
(syntax->datum
(cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
@@ -1982,16 +1982,32 @@
(loop (+ i 1)))))))
(else x)))))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
- (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
- (apply (lambda (mod exp)
- (let ((mod (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
- (values (remodulate exp mod) r w (source-annotation exp) mod)))
+ (if (and tmp
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
+ each-any
+ any))))
+ (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
+ (apply (lambda (mod exp)
+ (let ((mod (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+ (values (remodulate exp mod) r w (source-annotation exp) mod)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
(global-extend
'core
'if
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0e6f5660d..6c264a6df 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2239,7 +2239,9 @@
(syntax-case e ()
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
- (values (syntax->datum #'id) r w #f
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
(syntax->datum
#'(public mod ...)))))))
@@ -2262,9 +2264,20 @@
((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x i) mod)))))
(else x))))
- (syntax-case e ()
- ((_ (mod ...) exp)
+ (syntax-case e (@@)
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
+ (syntax->datum
+ #'(private mod ...))))
+ ((_ @@ (mod ...) exp)
(and-map id? #'(mod ...))
+ ;; This is a special syntax used to support R6RS library forms.
+ ;; Unlike the syntax above, the last item is not restricted to
+ ;; be a single identifier, and the syntax objects are kept
+ ;; intact, with only their module changed.
(let ((mod (syntax->datum #'(private mod ...))))
(values (remodulate #'exp mod)
r w (source-annotation #'exp)
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index bf1127e11..f71b90bea 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -197,7 +197,7 @@
(export e ...)
(re-export r ...)
(export! x ...)
- (@@ (name name* ...) body)
+ (@@ @@ (name name* ...) body)
...))))))))
(define-syntax import
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 6183df813..0e81f6506 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -115,16 +115,16 @@
'foo)))
(with-test-prefix "changes to expansion environment"
- (pass-if "expander detects changes to current-module with @@"
+ (pass-if "expander detects changes to current-module with @@ @@"
(compile '(begin
(define-module (new-module))
- (@@ (new-module)
- (define-syntax new-module-macro
- (lambda (stx)
- (syntax-case stx ()
- ((_ arg) (syntax arg))))))
- (@@ (new-module)
- (new-module-macro #t)))
+ (@@ @@ (new-module)
+ (define-syntax new-module-macro
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ arg) (syntax arg))))))
+ (@@ @@ (new-module)
+ (new-module-macro #t)))
#:env (current-module))))
(define-module (test-suite test-syncase-2)