Fix bug for read-syntax on ( . args)

* module/ice-9/boot-9.scm: Capture syntax?.
* module/ice-9/read.scm (read-syntax): Avoid re-annotating objects.
* test-suite/tests/reader.test ("read-syntax"): Add test.

3 files changed, 25 insertions, 7 deletions

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 251fedaa4..944061707 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4656,8 +4656,11 @@ R7RS."
 ;;;
 
 (call-with-values (lambda ()
-                    (include-from-path "ice-9/read.scm")
-                    (values read read-syntax))
+                    ;; Capture syntax? binding, later removed from root
+                    ;; module.
+                    (let ((syntax? syntax?))
+                      (include-from-path "ice-9/read.scm")
+                      (values read read-syntax)))
   (lambda (read* read-syntax*)
     (set! read read*)
     (set! read-syntax read-syntax*)))
diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm
index ccf8e3cea..ac407739f 100644
--- a/module/ice-9/read.scm
+++ b/module/ice-9/read.scm
@@ -877,7 +877,17 @@
 (define* (read-syntax #:optional (port (current-input-port)))
   (define filename (port-filename port))
   (define (annotate line column datum)
-    (datum->syntax #f ; No lexical context.
-                   datum
-                   #:source (vector filename line (1- column))))
+    ;; Usually when reading compound expressions consisting of multiple
+    ;; syntax objects, like lists, the "leaves" of the expression are
+    ;; annotated but the "root" isn't.  Like in (A . B), A and B will be
+    ;; annotated but the pair won't.  Therefore the usually correct
+    ;; thing to do is to just annotate the result.  However in the case
+    ;; of reading ( . C), the result is the already annotated C, which
+    ;; we don't want to re-annotate.  Therefore we avoid re-annotating
+    ;; already annotated objects.
+    (if (syntax? datum)
+        datum
+        (datum->syntax #f ; No lexical context.
+                       datum
+                       #:source (vector filename line (1- column)))))
   (%read port annotate syntax->datum))
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 231e69553..1481a0a5d 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -20,8 +20,9 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite reader)
-  :use-module (srfi srfi-1)
-  :use-module (test-suite lib))
+  #:use-module (srfi srfi-1)
+  #:use-module (test-suite lib)
+  #:use-module (system syntax internal))
 
 
 (define exception:eof
@@ -546,6 +547,10 @@
  (with-test-prefix "deprecated #{}# escapes"
    (pass-if (equal? (read-string "#{a\\ b}#") '#{a b}#))))
 
+(with-test-prefix "read-syntax"
+  (pass-if-equal "annotations" 'args
+    (syntax-expression (call-with-input-string "( . args)" read-syntax))))
+
 ;;; Local Variables:
 ;;; eval: (put 'with-read-options 'scheme-indent-function 1)
 ;;; End: