mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

fix (set! MACRO exp) hygiene

Browse source 
* module/ice-9/psyntax.scm (lookup): Reflow comment.
  (chi-top, syntax): Add comments about mod for lookup.
  (set!): Lookup the identifier in the module attached to its syntax
  object. In the (set! MACRO foo) case, after expanding the macro, chi
  the resulting expression with the empty wrap, as syntax-type
  does. Seems to fix the case where the expansion references
  lexically-bound variables.

* module/ice-9/psyntax-pp.scm: Regenerated.

* test-suite/tests/syncase.test: Add a bunch of tests.
This commit is contained in:
Andy Wingo 2010-07-01 12:10:02 +01:00
parent 2604f1ad85
commit ab6becd47f
3 changed files with 8297 additions and 8215 deletions
Download patch file Download diff file Expand all files Collapse all files

16413
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

31
module/ice-9/psyntax.scm
View file

@ -656,10 +656,10 @@
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
(define lookup (define lookup
; x may be a label or a symbol ;; x may be a label or a symbol
; although symbols are usually global, we check the environment first ;; although symbols are usually global, we check the environment first
; anyway because a temporary binding may have been established by ;; anyway because a temporary binding may have been established by
; fluid-let-syntax ;; fluid-let-syntax
(lambda (x r mod) (lambda (x r mod)
(cond (cond
((assq x r) => cdr) ((assq x r) => cdr)
@ -1197,6 +1197,7 @@
(chi-void))))) (chi-void)))))
((define-form) ((define-form)
(let* ((n (id-var-name value w)) (let* ((n (id-var-name value w))
;; Lookup the name in the module of the define form.
(type (binding-type (lookup n r mod)))) (type (binding-type (lookup n r mod))))
(case type (case type
((global core macro module-ref) ((global core macro module-ref)
@ -1847,6 +1848,8 @@
(lambda (src e r maps ellipsis? mod) (lambda (src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
(let ((label (id-var-name e empty-wrap))) (let ((label (id-var-name e empty-wrap)))
;; Mod does not matter, we are looking to see if
;; the id is lexical syntax.
(let ((b (lookup label r mod))) (let ((b (lookup label r mod)))
(if (eq? (binding-type b) 'syntax) (if (eq? (binding-type b) 'syntax)
(call-with-values (call-with-values
@ -2139,8 +2142,12 @@
(syntax-case e () (syntax-case e ()
((_ id val) ((_ id val)
(id? #'id) (id? #'id)
(let ((n (id-var-name #'id w))) (let ((n (id-var-name #'id w))
(let ((b (lookup n r mod))) ;; Lookup id in its module
(id-mod (if (syntax-object? #'id)
(syntax-object-module #'id)
mod)))
(let ((b (lookup n r id-mod)))
(case (binding-type b) (case (binding-type b)
((lexical) ((lexical)
(build-lexical-assignment s (build-lexical-assignment s
@ -2148,14 +2155,16 @@
(binding-value b) (binding-value b)
(chi #'val r w mod))) (chi #'val r w mod)))
((global) ((global)
(build-global-assignment s n (chi #'val r w mod) mod)) (build-global-assignment s n (chi #'val r w mod) id-mod))
((macro) ((macro)
(let ((p (binding-value b))) (let ((p (binding-value b)))
(if (procedure-property p 'variable-transformer) (if (procedure-property p 'variable-transformer)
(chi (chi-macro p e r w s #f mod) r w mod) ;; As syntax-type does, call chi-macro with
;; the mod of the expression. Hmm.
(chi (chi-macro p e r w s #f mod) r empty-wrap mod)
(syntax-violation 'set! "not a variable transformer" (syntax-violation 'set! "not a variable transformer"
(wrap e w mod) (wrap e w mod)
(wrap #'id w mod))))) (wrap #'id w id-mod)))))
((displaced-lexical) ((displaced-lexical)
(syntax-violation 'set! "identifier out of context" (syntax-violation 'set! "identifier out of context"
(wrap #'id w mod))) (wrap #'id w mod)))
@ -2172,8 +2181,8 @@
(lambda (e r w s* mod) (lambda (e r w s* mod)
(syntax-case e () (syntax-case e ()
(e (id? #'e) (e (id? #'e)
(build-global-assignment s (syntax->datum #'e) (build-global-assignment s (syntax->datum #'e)
val mod))))))) val mod)))))))
(else (else
(build-application s (build-application s
(chi #'(setter head) r w mod) (chi #'(setter head) r w mod)

68
test-suite/tests/syncase.test
View file

@ -152,3 +152,71 @@
(ciao 1)) (ciao 1))
(current-module)) (current-module))
"ciao")) "ciao"))
(define qux 30)
(with-test-prefix "identifier-syntax"
(pass-if "global reference"
(let-syntax ((baz (identifier-syntax qux)))
(equal? baz qux)))
(pass-if "lexical hygienic reference"
(let-syntax ((baz (identifier-syntax qux)))
(let ((qux 20))
(equal? (+ baz qux)
50))))
(pass-if "lexical hygienic reference (bound)"
(let ((qux 20))
(let-syntax ((baz (identifier-syntax qux)))
(equal? (+ baz qux)
40))))
(pass-if "global reference (settable)"
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(equal? baz qux)))
(pass-if "lexical hygienic reference (settable)"
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(let ((qux 20))
(equal? (+ baz qux)
50))))
(pass-if "lexical hygienic reference (bound, settable)"
(let ((qux 20))
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(equal? (+ baz qux)
40))))
(pass-if "global set!"
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(set! baz 10)
(equal? (+ baz qux) 20)))
(pass-if "lexical hygienic set!"
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(and (let ((qux 20))
(set! baz 5)
(equal? (+ baz qux)
25))
(equal? qux 5))))
(pass-if "lexical hygienic set! (bound)"
(let ((qux 20))
(let-syntax ((baz (identifier-syntax
(id qux)
((set! id expr) (set! qux expr)))))
(set! baz 50)
(equal? (+ baz qux)
100)))))