mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

Browse source 
Commit 54bbe0b284 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.
This commit is contained in:
Ludovic Courtès 2022-03-07 10:29:27 +01:00
parent c572b11f3d
commit 347321ece9
4 changed files with 119 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

2
NEWS
View file

@ -11,6 +11,8 @@ Changes in 3.0.9 (since 3.0.8)
** Type sizes are correctly determined when cross-compiling ** Type sizes are correctly determined when cross-compiling
(https://bugs.gnu.org/54198) (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) Changes in 3.0.8 (since 3.0.7)

155
module/ice-9/psyntax-pp.scm
View file

@ -243,7 +243,16 @@
(begin (begin
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp))))) (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 (extend-env
(lambda (labels bindings r) (lambda (labels bindings r)
(if (null? labels) (if (null? labels)
@ -1001,11 +1010,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-de2 transformer-environment) (let* ((t-680b775fb37a463-de8 transformer-environment)
(t-680b775fb37a463-de3 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-de9 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-de2 t-680b775fb37a463-de8
t-680b775fb37a463-de3 t-680b775fb37a463-de9
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1572,11 +1581,9 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-1061 (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-1060 (cons tmp-680b775fb37a463
tmp-680b775fb37a463-105f) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-105f
(cons tmp-680b775fb37a463-1060 tmp-680b775fb37a463-1061)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1885,11 +1892,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6c1 (map (lambda (tmp-680b775fb37a463-6c3
tmp-680b775fb37a463-6c0 tmp-680b775fb37a463-6c2
tmp-680b775fb37a463-6bf) tmp-680b775fb37a463-6c1)
(cons tmp-680b775fb37a463-6bf (cons tmp-680b775fb37a463-6c1
(cons tmp-680b775fb37a463-6c0 tmp-680b775fb37a463-6c1))) (cons tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c3)))
e2 e2
e1 e1
args))) args)))
@ -1901,11 +1908,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6d7 (map (lambda (tmp-680b775fb37a463-6d9
tmp-680b775fb37a463-6d6 tmp-680b775fb37a463-6d8
tmp-680b775fb37a463-6d5) tmp-680b775fb37a463-6d7)
(cons tmp-680b775fb37a463-6d5 (cons tmp-680b775fb37a463-6d7
(cons tmp-680b775fb37a463-6d6 tmp-680b775fb37a463-6d7))) (cons tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d9)))
e2 e2
e1 e1
args))) args)))
@ -1928,11 +1935,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-68b (map (lambda (tmp-680b775fb37a463-68d
tmp-680b775fb37a463-68a tmp-680b775fb37a463-68c
tmp-680b775fb37a463-689) tmp-680b775fb37a463-68b)
(cons tmp-680b775fb37a463-689 (cons tmp-680b775fb37a463-68b
(cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b))) (cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d)))
e2 e2
e1 e1
args))) args)))
@ -1944,11 +1951,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6a1 (map (lambda (tmp-680b775fb37a463-6a3
tmp-680b775fb37a463-6a0 tmp-680b775fb37a463-6a2
tmp-680b775fb37a463-69f) tmp-680b775fb37a463-6a1)
(cons tmp-680b775fb37a463-69f (cons tmp-680b775fb37a463-6a1
(cons tmp-680b775fb37a463-6a0 tmp-680b775fb37a463-6a1))) (cons tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a3)))
e2 e2
e1 e1
args))) args)))
@ -2884,11 +2891,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-1181 (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-1180 (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-117f) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463-1180)
tmp-680b775fb37a463-1181))
template template
pattern pattern
keyword))) keyword)))
@ -2904,11 +2909,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-119a (map (lambda (tmp-680b775fb37a463-11a0
tmp-680b775fb37a463-1199 tmp-680b775fb37a463-119f
tmp-680b775fb37a463-1198) tmp-680b775fb37a463-119e)
(list (cons tmp-680b775fb37a463-1198 tmp-680b775fb37a463-1199) (list (cons tmp-680b775fb37a463-119e tmp-680b775fb37a463-119f)
tmp-680b775fb37a463-119a)) tmp-680b775fb37a463-11a0))
template template
pattern pattern
keyword))) keyword)))
@ -2923,11 +2928,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11b3 (map (lambda (tmp-680b775fb37a463-11b9
tmp-680b775fb37a463-11b2 tmp-680b775fb37a463-11b8
tmp-680b775fb37a463-11b1) tmp-680b775fb37a463-11b7)
(list (cons tmp-680b775fb37a463-11b1 tmp-680b775fb37a463-11b2) (list (cons tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8)
tmp-680b775fb37a463-11b3)) tmp-680b775fb37a463-11b9))
template template
pattern pattern
keyword))) keyword)))
@ -2943,11 +2948,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11d2 (map (lambda (tmp-680b775fb37a463-11d8
tmp-680b775fb37a463-11d1 tmp-680b775fb37a463-11d7
tmp-680b775fb37a463-11d0) tmp-680b775fb37a463-11d6)
(list (cons tmp-680b775fb37a463-11d0 tmp-680b775fb37a463-11d1) (list (cons tmp-680b775fb37a463-11d6 tmp-680b775fb37a463-11d7)
tmp-680b775fb37a463-11d2)) tmp-680b775fb37a463-11d8))
template template
pattern pattern
keyword))) keyword)))
@ -3095,8 +3100,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-1282) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-1282)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3119,8 +3124,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-1287) (map (lambda (tmp-680b775fb37a463-128d)
(list "value" tmp-680b775fb37a463-1287)) (list "value" tmp-680b775fb37a463-128d))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3154,8 +3159,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-129d) (map (lambda (tmp-680b775fb37a463-12a3)
(list "value" tmp-680b775fb37a463-129d)) (list "value" tmp-680b775fb37a463-12a3))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3174,8 +3179,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12a2) (map (lambda (tmp-680b775fb37a463-12a8)
(list "value" tmp-680b775fb37a463-12a2)) (list "value" tmp-680b775fb37a463-12a8))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3265,8 +3270,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12eb) (apply (lambda (t-680b775fb37a463-12f1)
(cons "vector" t-680b775fb37a463-12eb)) (cons "vector" t-680b775fb37a463-12f1))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3276,8 +3281,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-12f7) (k (map (lambda (tmp-680b775fb37a463-12fd)
(list "quote" tmp-680b775fb37a463-12f7)) (list "quote" tmp-680b775fb37a463-12fd))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (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) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-1306 tmp)) (let ((t-680b775fb37a463-130c tmp))
(list "list->vector" t-680b775fb37a463-1306))))))))))))))))) (list "list->vector" t-680b775fb37a463-130c)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3302,9 +3307,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-1315) (apply (lambda (t-680b775fb37a463-131b)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-1315)) t-680b775fb37a463-131b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3320,10 +3325,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (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)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-1329 t-680b775fb37a463-132f
t-680b775fb37a463-1328)) t-680b775fb37a463-132e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3336,9 +3341,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-1335) (apply (lambda (t-680b775fb37a463-133b)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-1335)) t-680b775fb37a463-133b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3351,9 +3356,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-1341) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-1341)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3364,9 +3369,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-134d tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-134d)))) t-680b775fb37a463))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

15
module/ice-9/psyntax.scm
View file

@ -431,10 +431,21 @@
(define-syntax no-source (identifier-syntax #f)) (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 (define source-annotation
(lambda (x) (lambda (x)
(and (syntax? x) ;; Normally X is a syntax object. However, if it comes from a
(syntax-sourcev x)))) ;; 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) (define-syntax-rule (arg-check pred? e who)
(let ((x e)) (let ((x e))

26
test-suite/tests/compiler.test
View file

@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -19,6 +19,8 @@
#:use-module (test-suite lib) #:use-module (test-suite lib)
#:use-module (test-suite guile-test) #:use-module (test-suite guile-test)
#:use-module (system base compile) #: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 loader) #:select (load-thunk-from-memory))
#:use-module ((system vm program) #:select (program-sources source:addr))) #:use-module ((system vm program) #:select (program-sources source:addr)))
@ -70,7 +72,27 @@
(let ((m (make-module))) (let ((m (make-module)))
(beautify-user-module! m) (beautify-user-module! m)
(compile '(define round round) #:env 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" (with-test-prefix "current-reader"