Adapt uses of make-syntax to preserve syntax

* module/ice-9/psyntax.scm (datum->syntax): Add an additional optional
  argument, to allow callers to provide source annotation information.
* module/ice-9/psyntax-pp.scm: Regenerate.

2 files changed, 93 insertions, 68 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e44467960..1a3dcb135 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -747,7 +747,7 @@
                               ((memv key '(global))
                                (if (equal? fmod '(primitive))
                                  (values 'primitive-call fval e e w s mod)
-                                 (values 'global-call (make-syntax fval w fmod) e e w s mod)))
+                                 (values 'global-call (make-syntax fval w fmod fs) e e w s mod)))
                               ((memv key '(macro))
                                (syntax-type
                                  (expand-macro fval e r w s rib mod)
@@ -968,12 +968,14 @@
                              (make-syntax
                                (syntax-expression x)
                                (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
-                               (syntax-module x))
+                               (syntax-module x)
+                               (syntax-source x))
                              (make-syntax
                                (decorate-source (syntax-expression x) s)
                                (cons (cons m ms)
                                      (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
-                               (syntax-module x))))))
+                               (syntax-module x)
+                               (syntax-source x))))))
                       ((vector? x)
                        (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
                          (let loop ((i 0))
@@ -989,11 +991,11 @@
                          (source-wrap e w (cdr w) mod)
                          x))
                       (else (decorate-source x s))))))
-           (let* ((t-680b775fb37a463-d72 transformer-environment)
-                  (t-680b775fb37a463-d73 (lambda (k) (k e r w s rib mod))))
+           (let* ((t-680b775fb37a463-d74 transformer-environment)
+                  (t-680b775fb37a463-d75 (lambda (k) (k e r w s rib mod))))
              (with-fluid*
-               t-680b775fb37a463-d72
-               t-680b775fb37a463-d73
+               t-680b775fb37a463-d74
+               t-680b775fb37a463-d75
                (lambda ()
                  (rebuild-macro-output
                    (p (source-wrap e (anti-mark w) s mod))
@@ -1183,7 +1185,11 @@
               (call-with-values
                 (lambda ()
                   (resolve-identifier
-                    (make-syntax '#{ $sc-ellipsis }# (syntax-wrap e) (syntax-module e))
+                    (make-syntax
+                      '#{ $sc-ellipsis }#
+                      (syntax-wrap e)
+                      (syntax-module e)
+                      #f)
                     '(())
                     r
                     mod
@@ -1556,11 +1562,11 @@
                                           s
                                           mod
                                           get-formals
-                                          (map (lambda (tmp-680b775fb37a463-fe3
-                                                        tmp-680b775fb37a463-fe2
-                                                        tmp-680b775fb37a463-fe1)
-                                                 (cons tmp-680b775fb37a463-fe1
-                                                       (cons tmp-680b775fb37a463-fe2 tmp-680b775fb37a463-fe3)))
+                                          (map (lambda (tmp-680b775fb37a463-fe5
+                                                        tmp-680b775fb37a463-fe4
+                                                        tmp-680b775fb37a463-fe3)
+                                                 (cons tmp-680b775fb37a463-fe3
+                                                       (cons tmp-680b775fb37a463-fe4 tmp-680b775fb37a463-fe5)))
                                                e2*
                                                e1*
                                                args*)))
@@ -1858,9 +1864,11 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-69a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                (cons tmp-680b775fb37a463
-                                      (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-69a)))
+                         (map (lambda (tmp-680b775fb37a463-69c
+                                       tmp-680b775fb37a463-69b
+                                       tmp-680b775fb37a463-69a)
+                                (cons tmp-680b775fb37a463-69a
+                                      (cons tmp-680b775fb37a463-69b tmp-680b775fb37a463-69c)))
                               e2
                               e1
                               args)))
@@ -1872,11 +1880,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-6b0
-                                           tmp-680b775fb37a463-6af
-                                           tmp-680b775fb37a463-6ae)
-                                    (cons tmp-680b775fb37a463-6ae
-                                          (cons tmp-680b775fb37a463-6af tmp-680b775fb37a463-6b0)))
+                             (map (lambda (tmp-680b775fb37a463-6b2
+                                           tmp-680b775fb37a463-6b1
+                                           tmp-680b775fb37a463-6b0)
+                                    (cons tmp-680b775fb37a463-6b0
+                                          (cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2)))
                                   e2
                                   e1
                                   args)))
@@ -1913,9 +1921,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-67a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                    (cons tmp-680b775fb37a463
-                                          (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-67a)))
+                             (map (lambda (tmp-680b775fb37a463-67c
+                                           tmp-680b775fb37a463-67b
+                                           tmp-680b775fb37a463-67a)
+                                    (cons tmp-680b775fb37a463-67a
+                                          (cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c)))
                                   e2
                                   e1
                                   args)))
@@ -1933,7 +1943,8 @@
                                  (make-syntax
                                    '#{ $sc-ellipsis }#
                                    (syntax-wrap dots)
-                                   (syntax-module dots)))))
+                                   (syntax-module dots)
+                                   (syntax-source dots)))))
                        (let ((ids (list id))
                              (labels (list (gen-label)))
                              (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
@@ -2115,7 +2126,8 @@
                       (make-syntax
                         (remodulate (syntax-expression x) mod)
                         (syntax-wrap x)
-                        mod))
+                        mod
+                        (syntax-source x)))
                      ((vector? x)
                       (let* ((n (vector-length x)) (v (make-vector n)))
                         (let loop ((i 0))
@@ -2411,8 +2423,12 @@
           (cons 'hygiene (module-name (current-module))))))
     (set! identifier? (lambda (x) (nonsymbol-id? x)))
     (set! datum->syntax
-      (lambda (id datum)
-        (make-syntax datum (syntax-wrap id) (syntax-module id))))
+      (lambda* (id datum #:optional (srcloc #f))
+        (make-syntax
+          datum
+          (syntax-wrap id)
+          (syntax-module id)
+          (if srcloc (syntax-source srcloc) (source-properties datum)))))
     (set! syntax->datum (lambda (x) (strip x '(()))))
     (set! generate-temporaries
       (lambda (ls)
@@ -2502,7 +2518,8 @@
                                 (make-syntax
                                   (syntax-expression value)
                                   (anti-mark (syntax-wrap value))
-                                  (syntax-module value))))
+                                  (syntax-module value)
+                                  (syntax-source value))))
                              (else (values 'other #f)))))))))))
        (syntax-locally-bound-identifiers
          (lambda (id)
@@ -2820,11 +2837,9 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463
-                                         tmp-680b775fb37a463-110f
-                                         tmp-680b775fb37a463-110e)
-                                  (list (cons tmp-680b775fb37a463-110e tmp-680b775fb37a463-110f)
-                                        tmp-680b775fb37a463))
+                           (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                  (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                        tmp-680b775fb37a463-2))
                                 template
                                 pattern
                                 keyword)))
@@ -2840,9 +2855,11 @@
                                #f
                                k
                                (list docstring)
-                               (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                      (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                            tmp-680b775fb37a463-2))
+                               (map (lambda (tmp-680b775fb37a463-112b
+                                             tmp-680b775fb37a463-112a
+                                             tmp-680b775fb37a463)
+                                      (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-112a)
+                                            tmp-680b775fb37a463-112b))
                                     template
                                     pattern
                                     keyword)))
@@ -2875,9 +2892,9 @@
                                        dots
                                        k
                                        (list docstring)
-                                       (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
-                                              (list (cons tmp-680b775fb37a463-115f tmp-680b775fb37a463)
-                                                    tmp-680b775fb37a463-1))
+                                       (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                              (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                                    tmp-680b775fb37a463-2))
                                             template
                                             pattern
                                             keyword)))
@@ -3084,8 +3101,8 @@
                                   (apply (lambda (p)
                                            (if (= lev 0)
                                              (quasilist*
-                                               (map (lambda (tmp-680b775fb37a463-122c)
-                                                      (list "value" tmp-680b775fb37a463-122c))
+                                               (map (lambda (tmp-680b775fb37a463-122e)
+                                                      (list "value" tmp-680b775fb37a463-122e))
                                                     p)
                                                (vquasi q lev))
                                              (quasicons
@@ -3195,8 +3212,8 @@
                                 (let ((tmp-1 ls))
                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                     (if tmp
-                                      (apply (lambda (t-680b775fb37a463-127a)
-                                               (cons "vector" t-680b775fb37a463-127a))
+                                      (apply (lambda (t-680b775fb37a463-127c)
+                                               (cons "vector" t-680b775fb37a463-127c))
                                              tmp)
                                       (syntax-violation
                                         #f
@@ -3231,9 +3248,9 @@
                                     (let ((tmp-1 (map emit x)))
                                       (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                         (if tmp
-                                          (apply (lambda (t-680b775fb37a463-12a4)
+                                          (apply (lambda (t-680b775fb37a463-12a6)
                                                    (cons (make-syntax 'list '((top)) '(hygiene guile))
-                                                         t-680b775fb37a463-12a4))
+                                                         t-680b775fb37a463-12a6))
                                                  tmp)
                                           (syntax-violation
                                             #f
@@ -3249,10 +3266,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-12b8 t-680b775fb37a463-12b7)
+                                                  (apply (lambda (t-680b775fb37a463-12ba t-680b775fb37a463-12b9)
                                                            (list (make-syntax 'cons '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12b8
-                                                                 t-680b775fb37a463-12b7))
+                                                                 t-680b775fb37a463-12ba
+                                                                 t-680b775fb37a463-12b9))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3265,9 +3282,9 @@
                                             (let ((tmp-1 (map emit x)))
                                               (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-12c4)
+                                                  (apply (lambda (t-680b775fb37a463-12c6)
                                                            (cons (make-syntax 'append '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12c4))
+                                                                 t-680b775fb37a463-12c6))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3280,9 +3297,9 @@
                                                 (let ((tmp-1 (map emit x)))
                                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                     (if tmp
-                                                      (apply (lambda (t-680b775fb37a463-12d0)
+                                                      (apply (lambda (t-680b775fb37a463-12d2)
                                                                (cons (make-syntax 'vector '((top)) '(hygiene guile))
-                                                                     t-680b775fb37a463-12d0))
+                                                                     t-680b775fb37a463-12d2))
                                                              tmp)
                                                       (syntax-violation
                                                         #f
@@ -3293,9 +3310,9 @@
                                          (if tmp-1
                                            (apply (lambda (x)
                                                     (let ((tmp (emit x)))
-                                                      (let ((t-680b775fb37a463-12dc tmp))
+                                                      (let ((t-680b775fb37a463-12de tmp))
                                                         (list (make-syntax 'list->vector '((top)) '(hygiene guile))
-                                                              t-680b775fb37a463-12dc))))
+                                                              t-680b775fb37a463-12de))))
                                                   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 1616c7318..f0c1f03bb 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1347,7 +1347,7 @@
                        ;; need to make sure the fmod information is
                        ;; propagated back correctly -- hence this
                        ;; consing.
-                       (values 'global-call (make-syntax fval w fmod)
+                       (values 'global-call (make-syntax fval w fmod fs)
                                e e w s mod)))
                   ((macro)
                    (syntax-type (expand-macro fval e r w s rib mod)
@@ -1538,7 +1538,8 @@
                            (make-syntax
                             (syntax-expression x)
                             (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
-                            (syntax-module x))
+                            (syntax-module x)
+                            (syntax-source x))
                            ;; output introduced by macro
                            (make-syntax
                             (decorate-source (syntax-expression x) s)
@@ -1546,7 +1547,8 @@
                                        (if rib
                                            (cons rib (cons 'shift ss))
                                            (cons 'shift ss)))
-                            (syntax-module x))))))
+                            (syntax-module x)
+                            (syntax-source x))))))
                 
                   ((vector? x)
                    (let* ((n (vector-length x))
@@ -1780,8 +1782,9 @@
              (call-with-values
                  (lambda () (resolve-identifier
                              (make-syntax '#{ $sc-ellipsis }#
-                                                 (syntax-wrap e)
-                                                 (syntax-module e))
+                                          (syntax-wrap e)
+                                          (syntax-module e)
+                                          #f)
                              empty-wrap r mod #f))
                (lambda (type value mod)
                  (if (eq? type 'ellipsis)
@@ -2343,8 +2346,9 @@
                         (let ((id (if (symbol? #'dots)
                                       '#{ $sc-ellipsis }#
                                       (make-syntax '#{ $sc-ellipsis }#
-                                                          (syntax-wrap #'dots)
-                                                          (syntax-module #'dots)))))
+                                                   (syntax-wrap #'dots)
+                                                   (syntax-module #'dots)
+                                                   (syntax-source #'dots)))))
                           (let ((ids (list id))
                                 (labels (list (gen-label)))
                                 (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
@@ -2501,7 +2505,8 @@
                                  (remodulate (syntax-expression x) mod)
                                  (syntax-wrap x)
                                  ;; hither the remodulation
-                                 mod))
+                                 mod
+                                 (syntax-source x)))
                                ((vector? x)
                                 (let* ((n (vector-length x)) (v (make-vector n)))
                                   (do ((i 0 (fx+ i 1)))
@@ -2758,9 +2763,11 @@
             (nonsymbol-id? x)))
 
     (set! datum->syntax
-          (lambda (id datum)
-            (make-syntax datum (syntax-wrap id)
-                                (syntax-module id))))
+          (lambda* (id datum #:optional srcloc)
+            (make-syntax datum (syntax-wrap id) (syntax-module id)
+                         (if srcloc
+                             (syntax-source srcloc)
+                             (source-properties datum)))))
 
     (set! syntax->datum
           ;; accepts any object, since syntax objects may consist partially
@@ -2838,8 +2845,9 @@
                  ((ellipsis)
                   (values 'ellipsis
                           (make-syntax (syntax-expression value)
-                                              (anti-mark (syntax-wrap value))
-                                              (syntax-module value))))
+                                       (anti-mark (syntax-wrap value))
+                                       (syntax-module value)
+                                       (syntax-source value))))
                  (else (values 'other #f))))))))
 
       (define (syntax-locally-bound-identifiers id)