mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Macro-introduced top-level vars scope to their module even if unbound

Browse source 
* module/ice-9/psyntax.scm (analyze-variable): Previously, a reference
to a top-level variable in a module other than the current module would
be silently rewritten to reference the current module, if the variable
was unbound in its original module.  This was a hack from the early days
of when we extended psyntax to know about the module system.  Fix to
properly use the scope of the introduced binding instead of the scope of
the macro use site.
* test-suite/tests/syntax.test ("macro-introduced cross-module unbound
identifiers"): Add test.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-02-20 13:36:14 +01:00
parent 2717773bb1
commit 9e0f03c5fd
3 changed files with 58 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -80,14 +80,9 @@
(let ((key kind)) (let ((key kind))
(cond (cond
((memv key '(public)) (modref-cont mod var #t)) ((memv key '(public)) (modref-cont mod var #t))
((memv key '(private)) ((memv key '(private hygiene))
(if (equal? mod (module-name (current-module))) (bare-cont mod var) (modref-cont mod var #f))) (if (equal? mod (module-name (current-module))) (bare-cont mod var) (modref-cont mod var #f)))
((memv key '(bare)) (bare-cont var)) ((memv key '(bare)) (bare-cont var))
((memv key '(hygiene))
(if (and (not (equal? mod (module-name (current-module))))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont mod var)))
((memv key '(primitive)) (syntax-violation #f "primitive not in operator position" var)) ((memv key '(primitive)) (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod)))))))) (else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference (build-global-reference
@ -801,11 +796,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-e04 transformer-environment) (let* ((t-680b775fb37a463-e02 transformer-environment)
(t-680b775fb37a463-e05 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-e03 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-e04 t-680b775fb37a463-e02
t-680b775fb37a463-e05 t-680b775fb37a463-e03
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m")))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m"))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1335,11 +1330,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463-1 tmp-680b775fb37a463
tmp-680b775fb37a463) tmp-680b775fb37a463-107f)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-107f
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2435,9 +2430,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11a3 tmp-680b775fb37a463-11a2 tmp-680b775fb37a463-11a1) (map (lambda (tmp-680b775fb37a463-11a1 tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-119f)
(list (cons tmp-680b775fb37a463-11a1 tmp-680b775fb37a463-11a2) (list (cons tmp-680b775fb37a463-119f tmp-680b775fb37a463-11a0)
tmp-680b775fb37a463-11a3)) tmp-680b775fb37a463-11a1))
template template
pattern pattern
keyword))) keyword)))
@ -2452,11 +2447,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11bc (map (lambda (tmp-680b775fb37a463-11ba
tmp-680b775fb37a463-11bb tmp-680b775fb37a463-11b9
tmp-680b775fb37a463-11ba) tmp-680b775fb37a463-11b8)
(list (cons tmp-680b775fb37a463-11ba tmp-680b775fb37a463-11bb) (list (cons tmp-680b775fb37a463-11b8 tmp-680b775fb37a463-11b9)
tmp-680b775fb37a463-11bc)) tmp-680b775fb37a463-11ba))
template template
pattern pattern
keyword))) keyword)))
@ -2468,11 +2463,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11d5 (map (lambda (tmp-680b775fb37a463-11d3
tmp-680b775fb37a463-11d4 tmp-680b775fb37a463-11d2
tmp-680b775fb37a463-11d3) tmp-680b775fb37a463-11d1)
(list (cons tmp-680b775fb37a463-11d3 tmp-680b775fb37a463-11d4) (list (cons tmp-680b775fb37a463-11d1 tmp-680b775fb37a463-11d2)
tmp-680b775fb37a463-11d5)) tmp-680b775fb37a463-11d3))
template template
pattern pattern
keyword))) keyword)))
@ -2488,11 +2483,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11f4 (map (lambda (tmp-680b775fb37a463-11f2
tmp-680b775fb37a463-11f3 tmp-680b775fb37a463-11f1
tmp-680b775fb37a463-11f2) tmp-680b775fb37a463-11f0)
(list (cons tmp-680b775fb37a463-11f2 tmp-680b775fb37a463-11f3) (list (cons tmp-680b775fb37a463-11f0 tmp-680b775fb37a463-11f1)
tmp-680b775fb37a463-11f4)) tmp-680b775fb37a463-11f2))
template template
pattern pattern
keyword))) keyword)))
@ -2620,9 +2615,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12a4) (map (lambda (tmp-680b775fb37a463-12a2)
(list "value" (list "value"
tmp-680b775fb37a463-12a4)) tmp-680b775fb37a463-12a2))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2648,9 +2643,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12a9) (map (lambda (tmp-680b775fb37a463-12a7)
(list "value" (list "value"
tmp-680b775fb37a463-12a9)) tmp-680b775fb37a463-12a7))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2686,8 +2681,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12bf) (map (lambda (tmp-680b775fb37a463-12bd)
(list "value" tmp-680b775fb37a463-12bf)) (list "value" tmp-680b775fb37a463-12bd))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2707,8 +2702,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12c4) (map (lambda (tmp-680b775fb37a463-12c2)
(list "value" tmp-680b775fb37a463-12c4)) (list "value" tmp-680b775fb37a463-12c2))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2790,8 +2785,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-130d) (apply (lambda (t-680b775fb37a463-130b)
(cons "vector" t-680b775fb37a463-130d)) (cons "vector" t-680b775fb37a463-130b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2843,14 +2838,13 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-134b (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
t-680b775fb37a463-134a)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-134b t-680b775fb37a463-1
t-680b775fb37a463-134a)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2897,12 +2891,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-136f tmp)) (let ((t-680b775fb37a463-136d tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-136f)))) t-680b775fb37a463-136d))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -313,14 +313,10 @@
(mod (cdr mod))) (mod (cdr mod)))
(case kind (case kind
((public) (modref-cont mod var #t)) ((public) (modref-cont mod var #t))
((private) (if (equal? mod (module-name (current-module))) ((private hygiene) (if (equal? mod (module-name (current-module)))
(bare-cont mod var) (bare-cont mod var)
(modref-cont mod var #f))) (modref-cont mod var #f)))
((bare) (bare-cont var)) ((bare) (bare-cont var))
((hygiene) (if (and (not (equal? mod (module-name (current-module))))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont mod var)))
((primitive) ((primitive)
(syntax-violation #f "primitive not in operator position" var)) (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod)))))) (else (syntax-violation #f "bad module kind" var mod))))))

12
test-suite/tests/syntax.test
View file

@ -1709,6 +1709,18 @@
(defconst b 69) (defconst b 69)
(list (a) (b))))))) (list (a) (b)))))))
(pass-if-exception "macro-introduced cross-module unbound identifiers"
exception:unbound-var
(eval
'(begin
(define-module (foo) #:export (introduce-unbound))
(define-syntax-rule (introduce-unbound)
variable-bound-in-bar)
(define-module (bar) #:use-module (foo))
(define variable-bound-in-bar 42)
(introduce-unbound))
(interaction-environment)))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)