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

psyntax: Preserve source location information for top-level references.

Browse source 
Fixes <https://bugs.gnu.org/38388>.

* module/ice-9/psyntax.scm (expand-expr): In 'build-global-reference'
call, pass S when (source-annotation (car e)) returns #f.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Ludovic Courtès 2020-03-07 15:50:13 +01:00
parent 076276c4f5
commit d3a775ff10
2 changed files with 46 additions and 43 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -865,7 +865,7 @@
((memv key '(global-call)) ((memv key '(global-call))
(expand-call (expand-call
(build-global-reference (build-global-reference
(source-annotation (car e)) (or (source-annotation (car e)) s)
(if (syntax? value) (syntax-expression value) value) (if (syntax? value) (syntax-expression value) value)
(if (syntax? value) (syntax-module value) mod)) (if (syntax? value) (syntax-module value) mod))
e e
@ -987,11 +987,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-d6b transformer-environment) (let* ((t-680b775fb37a463-d6f transformer-environment)
(t-680b775fb37a463-d6c (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-d70 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-d6b t-680b775fb37a463-d6f
t-680b775fb37a463-d6c t-680b775fb37a463-d70
(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))
@ -1554,11 +1554,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-fdc (map (lambda (tmp-680b775fb37a463-fe0
tmp-680b775fb37a463-fdb tmp-680b775fb37a463-fdf
tmp-680b775fb37a463-fda) tmp-680b775fb37a463-fde)
(cons tmp-680b775fb37a463-fda (cons tmp-680b775fb37a463-fde
(cons tmp-680b775fb37a463-fdb tmp-680b775fb37a463-fdc))) (cons tmp-680b775fb37a463-fdf tmp-680b775fb37a463-fe0)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2823,9 +2823,11 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-110d
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-110c
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-110b)
(list (cons tmp-680b775fb37a463-110b tmp-680b775fb37a463-110c)
tmp-680b775fb37a463-110d))
template template
pattern pattern
keyword))) keyword)))
@ -2858,11 +2860,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-113b (map (lambda (tmp-680b775fb37a463-113f
tmp-680b775fb37a463-113a tmp-680b775fb37a463-113e
tmp-680b775fb37a463) tmp-680b775fb37a463-113d)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-113a) (list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e)
tmp-680b775fb37a463-113b)) tmp-680b775fb37a463-113f))
template template
pattern pattern
keyword))) keyword)))
@ -2878,9 +2880,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-115a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-115e
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-115d
tmp-680b775fb37a463-115a)) tmp-680b775fb37a463-115c)
(list (cons tmp-680b775fb37a463-115c tmp-680b775fb37a463-115d)
tmp-680b775fb37a463-115e))
template template
pattern pattern
keyword))) keyword)))
@ -3028,8 +3032,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-120a) (map (lambda (tmp-680b775fb37a463-120e)
(list "value" tmp-680b775fb37a463-120a)) (list "value" tmp-680b775fb37a463-120e))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3052,8 +3056,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-120f) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-120f)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3106,8 +3110,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-122a) (map (lambda (tmp-680b775fb37a463-122e)
(list "value" tmp-680b775fb37a463-122a)) (list "value" tmp-680b775fb37a463-122e))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3207,8 +3211,7 @@
(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-127f) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-127f))
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))))
@ -3219,8 +3222,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-128e tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-128e))))))))))))))))) (list "list->vector" t-680b775fb37a463)))))))))))))))))
(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))))
@ -3233,9 +3236,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-129d) (apply (lambda (t-680b775fb37a463-12a1)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-129d)) t-680b775fb37a463-12a1))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3251,10 +3254,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-12b1 t-680b775fb37a463-12b0) (apply (lambda (t-680b775fb37a463-12b5 t-680b775fb37a463-12b4)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12b1 t-680b775fb37a463-12b5
t-680b775fb37a463-12b0)) t-680b775fb37a463-12b4))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3267,9 +3270,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-12bd) (apply (lambda (t-680b775fb37a463-12c1)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12bd)) t-680b775fb37a463-12c1))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3282,9 +3285,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-12c9) (apply (lambda (t-680b775fb37a463-12cd)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12c9)) t-680b775fb37a463-12cd))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3295,9 +3298,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12d5 tmp)) (let ((t-680b775fb37a463-12d9 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d5)))) t-680b775fb37a463-12d9))))
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

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

@ -1437,7 +1437,7 @@
e r w s mod)) e r w s mod))
((global-call) ((global-call)
(expand-call (expand-call
(build-global-reference (source-annotation (car e)) (build-global-reference (or (source-annotation (car e)) s)
(if (syntax? value) (if (syntax? value)
(syntax-expression value) (syntax-expression value)
value) value)