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

* 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.

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)