mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
Fix @ and @@ to not capture lexicals; new @@ @@ form for R6RS libraries
* module/ice-9/psyntax.scm (@): Return top-wrap instead of the wrap applied to the '@' form, so that the symbol will be interpreted as a top-level identifier and never refer to any lexical variable. (@@): Change the syntax used to support R6RS 'library' forms to: (@@ @@ (mod ...) body). Change the behavior of the documented (@@ (mod ...) id) form to be the same as that of @, except for the use of 'private' instead of 'public' in the psyntax mod: use syntax->datum on the identifier, and return top-wrap instead of the wrap applied to the '@@' form. This fixes <http://bugs.gnu.org/10756> reported by Ludovic Courtès. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/r6rs-libraries.scm (library): Use '@@ @@' syntax instead of the older '@@' syntax. * test-suite/tests/syncase.test (changes to expansion environment): Use '@@ @@' syntax. * module/Makefile.am: Add explicit dependencies for boot-9.go on the files that it includes: quasisyntax.scm and r6rs-libraries.scm.
This commit is contained in:
parent
5f8d67ad09
commit
8210c8538a
5 changed files with 53 additions and 22 deletions
|
@ -32,6 +32,8 @@ nobase_ccache_DATA += ice-9/eval.go
|
||||||
EXTRA_DIST += ice-9/eval.scm
|
EXTRA_DIST += ice-9/eval.scm
|
||||||
ETAGS_ARGS += 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
|
# 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
|
# psyntax and boot-9 first, then the compiler itself, then the rest of
|
||||||
# the code.
|
# the code.
|
||||||
|
|
|
@ -1950,7 +1950,7 @@
|
||||||
(values
|
(values
|
||||||
(syntax->datum id)
|
(syntax->datum id)
|
||||||
r
|
r
|
||||||
w
|
'((top))
|
||||||
#f
|
#f
|
||||||
(syntax->datum
|
(syntax->datum
|
||||||
(cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
|
(cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
|
||||||
|
@ -1982,6 +1982,22 @@
|
||||||
(loop (+ i 1)))))))
|
(loop (+ i 1)))))))
|
||||||
(else x)))))
|
(else x)))))
|
||||||
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
|
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
|
||||||
|
(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)
|
||||||
|
(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))
|
(if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
|
||||||
(apply (lambda (mod exp)
|
(apply (lambda (mod exp)
|
||||||
(let ((mod (syntax->datum
|
(let ((mod (syntax->datum
|
||||||
|
@ -1991,7 +2007,7 @@
|
||||||
(syntax-violation
|
(syntax-violation
|
||||||
#f
|
#f
|
||||||
"source expression failed to match any pattern"
|
"source expression failed to match any pattern"
|
||||||
tmp-1))))))
|
tmp-1))))))))
|
||||||
(global-extend
|
(global-extend
|
||||||
'core
|
'core
|
||||||
'if
|
'if
|
||||||
|
|
|
@ -2239,7 +2239,9 @@
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ (mod ...) id)
|
((_ (mod ...) id)
|
||||||
(and (and-map id? #'(mod ...)) (id? #'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
|
(syntax->datum
|
||||||
#'(public mod ...)))))))
|
#'(public mod ...)))))))
|
||||||
|
|
||||||
|
@ -2262,9 +2264,20 @@
|
||||||
((fx= i n) v)
|
((fx= i n) v)
|
||||||
(vector-set! v i (remodulate (vector-ref x i) mod)))))
|
(vector-set! v i (remodulate (vector-ref x i) mod)))))
|
||||||
(else x))))
|
(else x))))
|
||||||
(syntax-case e ()
|
(syntax-case e (@@)
|
||||||
((_ (mod ...) exp)
|
((_ (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 ...))
|
(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 ...))))
|
(let ((mod (syntax->datum #'(private mod ...))))
|
||||||
(values (remodulate #'exp mod)
|
(values (remodulate #'exp mod)
|
||||||
r w (source-annotation #'exp)
|
r w (source-annotation #'exp)
|
||||||
|
|
|
@ -197,7 +197,7 @@
|
||||||
(export e ...)
|
(export e ...)
|
||||||
(re-export r ...)
|
(re-export r ...)
|
||||||
(export! x ...)
|
(export! x ...)
|
||||||
(@@ (name name* ...) body)
|
(@@ @@ (name name* ...) body)
|
||||||
...))))))))
|
...))))))))
|
||||||
|
|
||||||
(define-syntax import
|
(define-syntax import
|
||||||
|
|
|
@ -115,15 +115,15 @@
|
||||||
'foo)))
|
'foo)))
|
||||||
|
|
||||||
(with-test-prefix "changes to expansion environment"
|
(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
|
(compile '(begin
|
||||||
(define-module (new-module))
|
(define-module (new-module))
|
||||||
(@@ (new-module)
|
(@@ @@ (new-module)
|
||||||
(define-syntax new-module-macro
|
(define-syntax new-module-macro
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
((_ arg) (syntax arg))))))
|
((_ arg) (syntax arg))))))
|
||||||
(@@ (new-module)
|
(@@ @@ (new-module)
|
||||||
(new-module-macro #t)))
|
(new-module-macro #t)))
|
||||||
#:env (current-module))))
|
#:env (current-module))))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue