[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: psyntax: Honor source properties for things other
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] 03/04: psyntax: Honor source properties for things other than syntax objects. |
|
Date: |
Mon, 7 Mar 2022 04:57:11 -0500 (EST) |
civodul pushed a commit to branch main
in repository guile.
commit 347321ece9fc85ddf74af3c798230b7b187fbce9
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 7 10:29:27 2022 +0100
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.
---
NEWS | 2 +
module/ice-9/psyntax-pp.scm | 155 +++++++++++++++++++++--------------------
module/ice-9/psyntax.scm | 15 +++-
test-suite/tests/compiler.test | 26 ++++++-
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"