psyntax: Preserve source location information for top-level references.

Fixes <https://bugs.gnu.org/38388>.

* module/ice-9/psyntax.scm (expand-expr): In 'build-global-reference'
call, pass S when (source-annotation (car e)) returns #f.
* module/ice-9/psyntax-pp.scm: Regenerate.

2 files changed, 46 insertions, 43 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index b19ed77ed..95758255a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -865,7 +865,7 @@
                  ((memv key '(global-call))
                   (expand-call
                     (build-global-reference
-                      (source-annotation (car e))
+                      (or (source-annotation (car e)) s)
                       (if (syntax? value) (syntax-expression value) value)
                       (if (syntax? value) (syntax-module value) mod))
                     e
@@ -987,11 +987,11 @@
                          (source-wrap e w (cdr w) mod)
                          x))
                       (else (decorate-source x s))))))
-           (let* ((t-680b775fb37a463-d6b transformer-environment)
-                  (t-680b775fb37a463-d6c (lambda (k) (k e r w s rib mod))))
+           (let* ((t-680b775fb37a463-d6f transformer-environment)
+                  (t-680b775fb37a463-d70 (lambda (k) (k e r w s rib mod))))
              (with-fluid*
-               t-680b775fb37a463-d6b
-               t-680b775fb37a463-d6c
+               t-680b775fb37a463-d6f
+               t-680b775fb37a463-d70
                (lambda ()
                  (rebuild-macro-output
                    (p (source-wrap e (anti-mark w) s mod))
@@ -1554,11 +1554,11 @@
                                           s
                                           mod
                                           get-formals
-                                          (map (lambda (tmp-680b775fb37a463-fdc
-                                                        tmp-680b775fb37a463-fdb
-                                                        tmp-680b775fb37a463-fda)
-                                                 (cons tmp-680b775fb37a463-fda
-                                                       (cons tmp-680b775fb37a463-fdb tmp-680b775fb37a463-fdc)))
+                                          (map (lambda (tmp-680b775fb37a463-fe0
+                                                        tmp-680b775fb37a463-fdf
+                                                        tmp-680b775fb37a463-fde)
+                                                 (cons tmp-680b775fb37a463-fde
+                                                       (cons tmp-680b775fb37a463-fdf tmp-680b775fb37a463-fe0)))
                                                e2*
                                                e1*
                                                args*)))
@@ -2823,9 +2823,11 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                  (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                        tmp-680b775fb37a463-2))
+                           (map (lambda (tmp-680b775fb37a463-110d
+                                         tmp-680b775fb37a463-110c
+                                         tmp-680b775fb37a463-110b)
+                                  (list (cons tmp-680b775fb37a463-110b tmp-680b775fb37a463-110c)
+                                        tmp-680b775fb37a463-110d))
                                 template
                                 pattern
                                 keyword)))
@@ -2858,11 +2860,11 @@
                                    dots
                                    k
                                    '()
-                                   (map (lambda (tmp-680b775fb37a463-113b
-                                                 tmp-680b775fb37a463-113a
-                                                 tmp-680b775fb37a463)
-                                          (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-113a)
-                                                tmp-680b775fb37a463-113b))
+                                   (map (lambda (tmp-680b775fb37a463-113f
+                                                 tmp-680b775fb37a463-113e
+                                                 tmp-680b775fb37a463-113d)
+                                          (list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e)
+                                                tmp-680b775fb37a463-113f))
                                         template
                                         pattern
                                         keyword)))
@@ -2878,9 +2880,11 @@
                                        dots
                                        k
                                        (list docstring)
-                                       (map (lambda (tmp-680b775fb37a463-115a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                              (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                                    tmp-680b775fb37a463-115a))
+                                       (map (lambda (tmp-680b775fb37a463-115e
+                                                     tmp-680b775fb37a463-115d
+                                                     tmp-680b775fb37a463-115c)
+                                              (list (cons tmp-680b775fb37a463-115c tmp-680b775fb37a463-115d)
+                                                    tmp-680b775fb37a463-115e))
                                             template
                                             pattern
                                             keyword)))
@@ -3028,8 +3032,8 @@
                                                (apply (lambda (p)
                                                         (if (= lev 0)
                                                           (quasilist*
-                                                            (map (lambda (tmp-680b775fb37a463-120a)
-                                                                   (list "value" tmp-680b775fb37a463-120a))
+                                                            (map (lambda (tmp-680b775fb37a463-120e)
+                                                                   (list "value" tmp-680b775fb37a463-120e))
                                                                  p)
                                                             (quasi q lev))
                                                           (quasicons
@@ -3052,8 +3056,8 @@
                                                    (apply (lambda (p)
                                                             (if (= lev 0)
                                                               (quasiappend
-                                                                (map (lambda (tmp-680b775fb37a463-120f)
-                                                                       (list "value" tmp-680b775fb37a463-120f))
+                                                                (map (lambda (tmp-680b775fb37a463)
+                                                                       (list "value" tmp-680b775fb37a463))
                                                                      p)
                                                                 (quasi q lev))
                                                               (quasicons
@@ -3106,8 +3110,8 @@
                                       (apply (lambda (p)
                                                (if (= lev 0)
                                                  (quasiappend
-                                                   (map (lambda (tmp-680b775fb37a463-122a)
-                                                          (list "value" tmp-680b775fb37a463-122a))
+                                                   (map (lambda (tmp-680b775fb37a463-122e)
+                                                          (list "value" tmp-680b775fb37a463-122e))
                                                         p)
                                                    (vquasi q lev))
                                                  (quasicons
@@ -3207,8 +3211,7 @@
                        (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
                          (if tmp-1
                            (apply (lambda (y)
-                                    (k (map (lambda (tmp-680b775fb37a463-127f)
-                                              (list "quote" tmp-680b775fb37a463-127f))
+                                    (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
                                             y)))
                                   tmp-1)
                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@@ -3219,8 +3222,8 @@
                                    (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
                                    (let ((else tmp))
                                      (let ((tmp x))
-                                       (let ((t-680b775fb37a463-128e tmp))
-                                         (list "list->vector" t-680b775fb37a463-128e)))))))))))))))))
+                                       (let ((t-680b775fb37a463 tmp))
+                                         (list "list->vector" t-680b775fb37a463)))))))))))))))))
          (emit (lambda (x)
                  (let ((tmp x))
                    (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3233,9 +3236,9 @@
                                     (let ((tmp-1 (map emit x)))
                                       (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                         (if tmp
-                                          (apply (lambda (t-680b775fb37a463-129d)
+                                          (apply (lambda (t-680b775fb37a463-12a1)
                                                    (cons (make-syntax 'list '((top)) '(hygiene guile))
-                                                         t-680b775fb37a463-129d))
+                                                         t-680b775fb37a463-12a1))
                                                  tmp)
                                           (syntax-violation
                                             #f
@@ -3251,10 +3254,10 @@
                                             (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
                                               (let ((tmp ($sc-dispatch tmp-1 '(any any))))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-12b1 t-680b775fb37a463-12b0)
+                                                  (apply (lambda (t-680b775fb37a463-12b5 t-680b775fb37a463-12b4)
                                                            (list (make-syntax 'cons '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12b1
-                                                                 t-680b775fb37a463-12b0))
+                                                                 t-680b775fb37a463-12b5
+                                                                 t-680b775fb37a463-12b4))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3267,9 +3270,9 @@
                                             (let ((tmp-1 (map emit x)))
                                               (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-12bd)
+                                                  (apply (lambda (t-680b775fb37a463-12c1)
                                                            (cons (make-syntax 'append '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12bd))
+                                                                 t-680b775fb37a463-12c1))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3282,9 +3285,9 @@
                                                 (let ((tmp-1 (map emit x)))
                                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                     (if tmp
-                                                      (apply (lambda (t-680b775fb37a463-12c9)
+                                                      (apply (lambda (t-680b775fb37a463-12cd)
                                                                (cons (make-syntax 'vector '((top)) '(hygiene guile))
-                                                                     t-680b775fb37a463-12c9))
+                                                                     t-680b775fb37a463-12cd))
                                                              tmp)
                                                       (syntax-violation
                                                         #f
@@ -3295,9 +3298,9 @@
                                          (if tmp-1
                                            (apply (lambda (x)
                                                     (let ((tmp (emit x)))
-                                                      (let ((t-680b775fb37a463-12d5 tmp))
+                                                      (let ((t-680b775fb37a463-12d9 tmp))
                                                         (list (make-syntax 'list->vector '((top)) '(hygiene guile))
-                                                              t-680b775fb37a463-12d5))))
+                                                              t-680b775fb37a463-12d9))))
                                                   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 b97911d87..b11771aa0 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1437,7 +1437,7 @@
             e r w s mod))
           ((global-call)
            (expand-call
-            (build-global-reference (source-annotation (car e))
+            (build-global-reference (or (source-annotation (car e)) s)
                                     (if (syntax? value)
                                         (syntax-expression value)
                                         value)