wingo pushed a commit to branch main in repository guile. commit 9e0f03c5fd36764827c8bb03887f14640c883b70 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Tue Feb 20 13:36:14 2024 +0100
Macro-introduced top-level vars scope to their module even if unbound
* 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.
---
module/ice-9/psyntax-pp.scm | 92 +++++++++++++++++++++-----------------------
module/ice-9/psyntax.scm | 10 ++---
test-suite/tests/syntax.test | 12 ++++++
3 files changed, 58 insertions(+), 56 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 58c9c403a..bd90b37b4 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -80,14 +80,9 @@
(let ((key kind))
(cond
((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)))
((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))
(else (syntax-violation #f "bad module kind" var
mod))))))))
(build-global-reference
@@ -801,11 +796,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-e04 transformer-environment)
- (t-680b775fb37a463-e05 (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-e02 transformer-environment)
+ (t-680b775fb37a463-e03 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-e04
- t-680b775fb37a463-e05
+ t-680b775fb37a463-e02
+ t-680b775fb37a463-e03
(lambda () (rebuild-macro-output (p (source-wrap e
(anti-mark w) s mod)) (module-gensym "m"))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1335,11 +1330,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-2
-
tmp-680b775fb37a463-1
-
tmp-680b775fb37a463)
- (cons
tmp-680b775fb37a463
- (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda
(tmp-680b775fb37a463-1
+
tmp-680b775fb37a463
+
tmp-680b775fb37a463-107f)
+ (cons
tmp-680b775fb37a463-107f
+ (cons
tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2*
e1*
args*)))
@@ -2435,9 +2430,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-11a3
tmp-680b775fb37a463-11a2 tmp-680b775fb37a463-11a1)
- (list (cons tmp-680b775fb37a463-11a1
tmp-680b775fb37a463-11a2)
- tmp-680b775fb37a463-11a3))
+ (map (lambda (tmp-680b775fb37a463-11a1
tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-119f)
+ (list (cons tmp-680b775fb37a463-119f
tmp-680b775fb37a463-11a0)
+ tmp-680b775fb37a463-11a1))
template
pattern
keyword)))
@@ -2452,11 +2447,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-11bc
- tmp-680b775fb37a463-11bb
- tmp-680b775fb37a463-11ba)
- (list (cons tmp-680b775fb37a463-11ba
tmp-680b775fb37a463-11bb)
- tmp-680b775fb37a463-11bc))
+ (map (lambda (tmp-680b775fb37a463-11ba
+ tmp-680b775fb37a463-11b9
+ tmp-680b775fb37a463-11b8)
+ (list (cons tmp-680b775fb37a463-11b8
tmp-680b775fb37a463-11b9)
+ tmp-680b775fb37a463-11ba))
template
pattern
keyword)))
@@ -2468,11 +2463,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-11d5
- tmp-680b775fb37a463-11d4
- tmp-680b775fb37a463-11d3)
- (list (cons
tmp-680b775fb37a463-11d3 tmp-680b775fb37a463-11d4)
- tmp-680b775fb37a463-11d5))
+ (map (lambda (tmp-680b775fb37a463-11d3
+ tmp-680b775fb37a463-11d2
+ tmp-680b775fb37a463-11d1)
+ (list (cons
tmp-680b775fb37a463-11d1 tmp-680b775fb37a463-11d2)
+ tmp-680b775fb37a463-11d3))
template
pattern
keyword)))
@@ -2488,11 +2483,11 @@
dots
k
(list docstring)
- (map (lambda
(tmp-680b775fb37a463-11f4
-
tmp-680b775fb37a463-11f3
-
tmp-680b775fb37a463-11f2)
- (list (cons
tmp-680b775fb37a463-11f2 tmp-680b775fb37a463-11f3)
-
tmp-680b775fb37a463-11f4))
+ (map (lambda
(tmp-680b775fb37a463-11f2
+
tmp-680b775fb37a463-11f1
+
tmp-680b775fb37a463-11f0)
+ (list (cons
tmp-680b775fb37a463-11f0 tmp-680b775fb37a463-11f1)
+
tmp-680b775fb37a463-11f2))
template
pattern
keyword)))
@@ -2620,9 +2615,9 @@
(apply (lambda (p)
(if (=
lev 0)
(quasilist*
-
(map (lambda (tmp-680b775fb37a463-12a4)
+
(map (lambda (tmp-680b775fb37a463-12a2)
(list "value"
-
tmp-680b775fb37a463-12a4))
+
tmp-680b775fb37a463-12a2))
p)
(quasi q lev))
(quasicons
@@ -2648,9 +2643,9 @@
(apply
(lambda (p)
(if (= lev 0)
(quasiappend
-
(map (lambda (tmp-680b775fb37a463-12a9)
+
(map (lambda (tmp-680b775fb37a463-12a7)
(list "value"
-
tmp-680b775fb37a463-12a9))
+
tmp-680b775fb37a463-12a7))
p)
(quasi q lev))
(quasicons
@@ -2686,8 +2681,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-12bf)
- (list "value"
tmp-680b775fb37a463-12bf))
+ (map (lambda
(tmp-680b775fb37a463-12bd)
+ (list "value"
tmp-680b775fb37a463-12bd))
p)
(vquasi q lev))
(quasicons
@@ -2707,8 +2702,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-12c4)
- (list
"value" tmp-680b775fb37a463-12c4))
+ (map (lambda
(tmp-680b775fb37a463-12c2)
+ (list
"value" tmp-680b775fb37a463-12c2))
p)
(vquasi q lev))
(quasicons
@@ -2790,8 +2785,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-130d)
- (cons "vector"
t-680b775fb37a463-130d))
+ (apply (lambda
(t-680b775fb37a463-130b)
+ (cons "vector"
t-680b775fb37a463-130b))
tmp)
(syntax-violation
#f
@@ -2843,14 +2838,13 @@
(let ((tmp-1 (list
(emit (car x*)) (f (cdr x*)))))
(let ((tmp
($sc-dispatch tmp-1 '(any any))))
(if tmp
- (apply
(lambda (t-680b775fb37a463-134b
-
t-680b775fb37a463-134a)
+ (apply
(lambda (t-680b775fb37a463-1 t-680b775fb37a463)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-134b
-
t-680b775fb37a463-134a))
+
t-680b775fb37a463-1
+
t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -2897,12 +2891,12 @@
(if tmp-1
(apply (lambda (x)
(let
((tmp (emit x)))
- (let
((t-680b775fb37a463-136f tmp))
+ (let
((t-680b775fb37a463-136d tmp))
(list (make-syntax
'list->vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463-136f))))
+
t-680b775fb37a463-136d))))
tmp-1)
(let ((tmp-1
($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 374a3c4b3..3e80446bd 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -313,14 +313,10 @@
(mod (cdr mod)))
(case kind
((public) (modref-cont mod var #t))
- ((private) (if (equal? mod (module-name (current-module)))
- (bare-cont mod var)
- (modref-cont mod var #f)))
+ ((private hygiene) (if (equal? mod (module-name
(current-module)))
+ (bare-cont mod var)
+ (modref-cont mod var #f)))
((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)
(syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 82c99f65e..4872866ab 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1709,6 +1709,18 @@
(defconst b 69)
(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:
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
