From 8210c8538a6efb48d8adaf402546f30a8b249bcb Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 8 Mar 2012 01:24:25 -0500 Subject: [PATCH] Fix @ and @@ to not capture lexicals; new @@ @@ form for R6RS libraries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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 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. --- module/Makefile.am | 2 ++ module/ice-9/psyntax-pp.scm | 36 ++++++++++++++++++++++++--------- module/ice-9/psyntax.scm | 19 ++++++++++++++--- module/ice-9/r6rs-libraries.scm | 2 +- test-suite/tests/syncase.test | 16 +++++++-------- 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)