psyntax: Honor source properties for things other than syntax objects.

Commit 54bbe0b2846c5b1aa366c91d679ba724869c8cda inadvertently led
psyntax to dismiss source location info for data returned by read hash
extensions, because read hash extensions return plain data with
associated source properties, even when called from 'read-syntax'.

This change reverts part of this commit to restore that behavior.

Fixes <https://issues.guix.gnu.org/54003>.

* module/ice-9/psyntax.scm (datum-sourcev): New procedure.
(source-annotation): Fall back to 'datum-sourcev'.
* module/ice-9/psyntax-pp.scm: Regenerate.
* test-suite/tests/compiler.test ("psyntax")["syntax-source with
read-hash-extend"]: New test.

4 files changed, 119 insertions, 79 deletions

diff --git a/NEWS b/NEWS
index c7733aa4f..0c77f8dd7 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,8 @@ Changes in 3.0.9 (since 3.0.8)
 
 ** Type sizes are correctly determined when cross-compiling
    (https://bugs.gnu.org/54198)
+** psyntax honors source properties coming from read hash extensions
+   (https://bugs.gnu.org/54003)
 
 
 Changes in 3.0.8 (since 3.0.7)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index a6b7fd1c4..bc1719ad3 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -243,7 +243,16 @@
            (begin
              (for-each maybe-name-value! ids val-exps)
              (make-letrec src in-order? ids vars val-exps body-exp)))))
-     (source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x))))
+     (datum-sourcev
+       (lambda (datum)
+         (let ((props (source-properties datum)))
+           (and (pair? props)
+                (vector
+                  (assq-ref props 'filename)
+                  (assq-ref props 'line)
+                  (assq-ref props 'column))))))
+     (source-annotation
+       (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
      (extend-env
        (lambda (labels bindings r)
          (if (null? labels)
@@ -1001,11 +1010,11 @@
                          (source-wrap e w (cdr w) mod)
                          x))
                       (else (decorate-source x))))))
-           (let* ((t-680b775fb37a463-de2 transformer-environment)
-                  (t-680b775fb37a463-de3 (lambda (k) (k e r w s rib mod))))
+           (let* ((t-680b775fb37a463-de8 transformer-environment)
+                  (t-680b775fb37a463-de9 (lambda (k) (k e r w s rib mod))))
              (with-fluid*
-               t-680b775fb37a463-de2
-               t-680b775fb37a463-de3
+               t-680b775fb37a463-de8
+               t-680b775fb37a463-de9
                (lambda ()
                  (rebuild-macro-output
                    (p (source-wrap e (anti-mark w) s mod))
@@ -1572,11 +1581,9 @@
                                           s
                                           mod
                                           get-formals
-                                          (map (lambda (tmp-680b775fb37a463-1061
-                                                        tmp-680b775fb37a463-1060
-                                                        tmp-680b775fb37a463-105f)
-                                                 (cons tmp-680b775fb37a463-105f
-                                                       (cons tmp-680b775fb37a463-1060 tmp-680b775fb37a463-1061)))
+                                          (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                                 (cons tmp-680b775fb37a463
+                                                       (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
                                                e2*
                                                e1*
                                                args*)))
@@ -1885,11 +1892,11 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-6c1
-                                       tmp-680b775fb37a463-6c0
-                                       tmp-680b775fb37a463-6bf)
-                                (cons tmp-680b775fb37a463-6bf
-                                      (cons tmp-680b775fb37a463-6c0 tmp-680b775fb37a463-6c1)))
+                         (map (lambda (tmp-680b775fb37a463-6c3
+                                       tmp-680b775fb37a463-6c2
+                                       tmp-680b775fb37a463-6c1)
+                                (cons tmp-680b775fb37a463-6c1
+                                      (cons tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c3)))
                               e2
                               e1
                               args)))
@@ -1901,11 +1908,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-6d7
-                                           tmp-680b775fb37a463-6d6
-                                           tmp-680b775fb37a463-6d5)
-                                    (cons tmp-680b775fb37a463-6d5
-                                          (cons tmp-680b775fb37a463-6d6 tmp-680b775fb37a463-6d7)))
+                             (map (lambda (tmp-680b775fb37a463-6d9
+                                           tmp-680b775fb37a463-6d8
+                                           tmp-680b775fb37a463-6d7)
+                                    (cons tmp-680b775fb37a463-6d7
+                                          (cons tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d9)))
                                   e2
                                   e1
                                   args)))
@@ -1928,11 +1935,11 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-68b
-                                       tmp-680b775fb37a463-68a
-                                       tmp-680b775fb37a463-689)
-                                (cons tmp-680b775fb37a463-689
-                                      (cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b)))
+                         (map (lambda (tmp-680b775fb37a463-68d
+                                       tmp-680b775fb37a463-68c
+                                       tmp-680b775fb37a463-68b)
+                                (cons tmp-680b775fb37a463-68b
+                                      (cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d)))
                               e2
                               e1
                               args)))
@@ -1944,11 +1951,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-6a1
-                                           tmp-680b775fb37a463-6a0
-                                           tmp-680b775fb37a463-69f)
-                                    (cons tmp-680b775fb37a463-69f
-                                          (cons tmp-680b775fb37a463-6a0 tmp-680b775fb37a463-6a1)))
+                             (map (lambda (tmp-680b775fb37a463-6a3
+                                           tmp-680b775fb37a463-6a2
+                                           tmp-680b775fb37a463-6a1)
+                                    (cons tmp-680b775fb37a463-6a1
+                                          (cons tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a3)))
                                   e2
                                   e1
                                   args)))
@@ -2884,11 +2891,9 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-1181
-                                         tmp-680b775fb37a463-1180
-                                         tmp-680b775fb37a463-117f)
-                                  (list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463-1180)
-                                        tmp-680b775fb37a463-1181))
+                           (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                  (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                        tmp-680b775fb37a463-2))
                                 template
                                 pattern
                                 keyword)))
@@ -2904,11 +2909,11 @@
                                #f
                                k
                                (list docstring)
-                               (map (lambda (tmp-680b775fb37a463-119a
-                                             tmp-680b775fb37a463-1199
-                                             tmp-680b775fb37a463-1198)
-                                      (list (cons tmp-680b775fb37a463-1198 tmp-680b775fb37a463-1199)
-                                            tmp-680b775fb37a463-119a))
+                               (map (lambda (tmp-680b775fb37a463-11a0
+                                             tmp-680b775fb37a463-119f
+                                             tmp-680b775fb37a463-119e)
+                                      (list (cons tmp-680b775fb37a463-119e tmp-680b775fb37a463-119f)
+                                            tmp-680b775fb37a463-11a0))
                                     template
                                     pattern
                                     keyword)))
@@ -2923,11 +2928,11 @@
                                    dots
                                    k
                                    '()
-                                   (map (lambda (tmp-680b775fb37a463-11b3
-                                                 tmp-680b775fb37a463-11b2
-                                                 tmp-680b775fb37a463-11b1)
-                                          (list (cons tmp-680b775fb37a463-11b1 tmp-680b775fb37a463-11b2)
-                                                tmp-680b775fb37a463-11b3))
+                                   (map (lambda (tmp-680b775fb37a463-11b9
+                                                 tmp-680b775fb37a463-11b8
+                                                 tmp-680b775fb37a463-11b7)
+                                          (list (cons tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8)
+                                                tmp-680b775fb37a463-11b9))
                                         template
                                         pattern
                                         keyword)))
@@ -2943,11 +2948,11 @@
                                        dots
                                        k
                                        (list docstring)
-                                       (map (lambda (tmp-680b775fb37a463-11d2
-                                                     tmp-680b775fb37a463-11d1
-                                                     tmp-680b775fb37a463-11d0)
-                                              (list (cons tmp-680b775fb37a463-11d0 tmp-680b775fb37a463-11d1)
-                                                    tmp-680b775fb37a463-11d2))
+                                       (map (lambda (tmp-680b775fb37a463-11d8
+                                                     tmp-680b775fb37a463-11d7
+                                                     tmp-680b775fb37a463-11d6)
+                                              (list (cons tmp-680b775fb37a463-11d6 tmp-680b775fb37a463-11d7)
+                                                    tmp-680b775fb37a463-11d8))
                                             template
                                             pattern
                                             keyword)))
@@ -3095,8 +3100,8 @@
                                                (apply (lambda (p)
                                                         (if (= lev 0)
                                                           (quasilist*
-                                                            (map (lambda (tmp-680b775fb37a463-1282)
-                                                                   (list "value" tmp-680b775fb37a463-1282))
+                                                            (map (lambda (tmp-680b775fb37a463)
+                                                                   (list "value" tmp-680b775fb37a463))
                                                                  p)
                                                             (quasi q lev))
                                                           (quasicons
@@ -3119,8 +3124,8 @@
                                                    (apply (lambda (p)
                                                             (if (= lev 0)
                                                               (quasiappend
-                                                                (map (lambda (tmp-680b775fb37a463-1287)
-                                                                       (list "value" tmp-680b775fb37a463-1287))
+                                                                (map (lambda (tmp-680b775fb37a463-128d)
+                                                                       (list "value" tmp-680b775fb37a463-128d))
                                                                      p)
                                                                 (quasi q lev))
                                                               (quasicons
@@ -3154,8 +3159,8 @@
                                   (apply (lambda (p)
                                            (if (= lev 0)
                                              (quasilist*
-                                               (map (lambda (tmp-680b775fb37a463-129d)
-                                                      (list "value" tmp-680b775fb37a463-129d))
+                                               (map (lambda (tmp-680b775fb37a463-12a3)
+                                                      (list "value" tmp-680b775fb37a463-12a3))
                                                     p)
                                                (vquasi q lev))
                                              (quasicons
@@ -3174,8 +3179,8 @@
                                       (apply (lambda (p)
                                                (if (= lev 0)
                                                  (quasiappend
-                                                   (map (lambda (tmp-680b775fb37a463-12a2)
-                                                          (list "value" tmp-680b775fb37a463-12a2))
+                                                   (map (lambda (tmp-680b775fb37a463-12a8)
+                                                          (list "value" tmp-680b775fb37a463-12a8))
                                                         p)
                                                    (vquasi q lev))
                                                  (quasicons
@@ -3265,8 +3270,8 @@
                                 (let ((tmp-1 ls))
                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                     (if tmp
-                                      (apply (lambda (t-680b775fb37a463-12eb)
-                                               (cons "vector" t-680b775fb37a463-12eb))
+                                      (apply (lambda (t-680b775fb37a463-12f1)
+                                               (cons "vector" t-680b775fb37a463-12f1))
                                              tmp)
                                       (syntax-violation
                                         #f
@@ -3276,8 +3281,8 @@
                        (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
                          (if tmp-1
                            (apply (lambda (y)
-                                    (k (map (lambda (tmp-680b775fb37a463-12f7)
-                                              (list "quote" tmp-680b775fb37a463-12f7))
+                                    (k (map (lambda (tmp-680b775fb37a463-12fd)
+                                              (list "quote" tmp-680b775fb37a463-12fd))
                                             y)))
                                   tmp-1)
                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@@ -3288,8 +3293,8 @@
                                    (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
                                    (let ((else tmp))
                                      (let ((tmp x))
-                                       (let ((t-680b775fb37a463-1306 tmp))
-                                         (list "list->vector" t-680b775fb37a463-1306)))))))))))))))))
+                                       (let ((t-680b775fb37a463-130c tmp))
+                                         (list "list->vector" t-680b775fb37a463-130c)))))))))))))))))
          (emit (lambda (x)
                  (let ((tmp x))
                    (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3302,9 +3307,9 @@
                                     (let ((tmp-1 (map emit x)))
                                       (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                         (if tmp
-                                          (apply (lambda (t-680b775fb37a463-1315)
+                                          (apply (lambda (t-680b775fb37a463-131b)
                                                    (cons (make-syntax 'list '((top)) '(hygiene guile))
-                                                         t-680b775fb37a463-1315))
+                                                         t-680b775fb37a463-131b))
                                                  tmp)
                                           (syntax-violation
                                             #f
@@ -3320,10 +3325,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-1329 t-680b775fb37a463-1328)
+                                                  (apply (lambda (t-680b775fb37a463-132f t-680b775fb37a463-132e)
                                                            (list (make-syntax 'cons '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-1329
-                                                                 t-680b775fb37a463-1328))
+                                                                 t-680b775fb37a463-132f
+                                                                 t-680b775fb37a463-132e))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3336,9 +3341,9 @@
                                             (let ((tmp-1 (map emit x)))
                                               (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-1335)
+                                                  (apply (lambda (t-680b775fb37a463-133b)
                                                            (cons (make-syntax 'append '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-1335))
+                                                                 t-680b775fb37a463-133b))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3351,9 +3356,9 @@
                                                 (let ((tmp-1 (map emit x)))
                                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                     (if tmp
-                                                      (apply (lambda (t-680b775fb37a463-1341)
+                                                      (apply (lambda (t-680b775fb37a463)
                                                                (cons (make-syntax 'vector '((top)) '(hygiene guile))
-                                                                     t-680b775fb37a463-1341))
+                                                                     t-680b775fb37a463))
                                                              tmp)
                                                       (syntax-violation
                                                         #f
@@ -3364,9 +3369,9 @@
                                          (if tmp-1
                                            (apply (lambda (x)
                                                     (let ((tmp (emit x)))
-                                                      (let ((t-680b775fb37a463-134d tmp))
+                                                      (let ((t-680b775fb37a463 tmp))
                                                         (list (make-syntax 'list->vector '((top)) '(hygiene guile))
-                                                              t-680b775fb37a463-134d))))
+                                                              t-680b775fb37a463))))
                                                   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 3a885e507..7811f7118 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -431,10 +431,21 @@
 
     (define-syntax no-source (identifier-syntax #f))
 
+    (define (datum-sourcev datum)
+      (let ((props (source-properties datum)))
+        (and (pair? props)
+             (vector (assq-ref props 'filename)
+                     (assq-ref props 'line)
+                     (assq-ref props 'column)))))
+
     (define source-annotation
       (lambda (x)
-        (and (syntax? x)
-             (syntax-sourcev x))))
+        ;; Normally X is a syntax object.  However, if it comes from a
+        ;; read hash extension, X might be a plain sexp with source
+        ;; properties.
+        (if (syntax? x)
+            (syntax-sourcev x)
+            (datum-sourcev x))))
 
     (define-syntax-rule (arg-check pred? e who)
       (let ((x e))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 466f2b821..d60151c6f 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-2022 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,6 +19,8 @@
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
   #:use-module (system base compile)
+  #:use-module ((language tree-il)
+                #:select (tree-il-src call-args))
   #:use-module ((system vm loader) #:select (load-thunk-from-memory))
   #:use-module ((system vm program) #:select (program-sources source:addr)))
 
@@ -70,7 +72,27 @@
     (let ((m (make-module)))
       (beautify-user-module! m)
       (compile '(define round round) #:env m)
-      (eq? round (module-ref m 'round)))))
+      (eq? round (module-ref m 'round))))
+
+  (pass-if-equal "syntax-source with read-hash-extend"
+      '((filename . "sample.scm") (line . 2) (column . 5))
+    ;; In Guile 3.0.8, psyntax would dismiss source properties added by
+    ;; read hash extensions on data they return.
+    ;; See <https://issues.guix.gnu.org/54003>
+    (with-fluids ((%read-hash-procedures
+                   (fluid-ref %read-hash-procedures)))
+      (read-hash-extend #\~ (lambda (chr port)
+                              (list 'magic (read port))))
+      (tree-il-src
+       (car
+        (call-args
+         (call-with-input-string "\
+;; first line
+;; second line
+   #~(this is a magic expression)"
+           (lambda (port)
+             (set-port-filename! port "sample.scm")
+             (compile (read-syntax port) #:to 'tree-il)))))))))
 
 
 (with-test-prefix "current-reader"