|
| From: | Andy Wingo |
| Subject: | [Guile-commits] 04/04: Adapt uses of make-syntax to preserve syntax |
| Date: | Sun, 21 Feb 2021 05:15:16 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 50d3dd83f0260f12f106ea6f4a4c95c917f420c1
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat Feb 20 21:16:42 2021 +0100
Adapt uses of make-syntax to preserve syntax
* module/ice-9/psyntax.scm (datum->syntax): Add an additional optional
argument, to allow callers to provide source annotation information.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 127 +++++++++++++++++++++++++-------------------
module/ice-9/psyntax.scm | 34 +++++++-----
2 files changed, 93 insertions(+), 68 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e444679..1a3dcb1 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -747,7 +747,7 @@
((memv key '(global))
(if (equal? fmod '(primitive))
(values 'primitive-call fval e e w s mod)
- (values 'global-call (make-syntax fval w
fmod) e e w s mod)))
+ (values 'global-call (make-syntax fval w fmod
fs) e e w s mod)))
((memv key '(macro))
(syntax-type
(expand-macro fval e r w s rib mod)
@@ -968,12 +968,14 @@
(make-syntax
(syntax-expression x)
(cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr
ss)))
- (syntax-module x))
+ (syntax-module x)
+ (syntax-source x))
(make-syntax
(decorate-source (syntax-expression x) s)
(cons (cons m ms)
(if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
- (syntax-module x))))))
+ (syntax-module x)
+ (syntax-source x))))))
((vector? x)
(let* ((n (vector-length x)) (v (decorate-source
(make-vector n) s)))
(let loop ((i 0))
@@ -989,11 +991,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-d72 transformer-environment)
- (t-680b775fb37a463-d73 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-d74 transformer-environment)
+ (t-680b775fb37a463-d75 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-d72
- t-680b775fb37a463-d73
+ t-680b775fb37a463-d74
+ t-680b775fb37a463-d75
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1183,7 +1185,11 @@
(call-with-values
(lambda ()
(resolve-identifier
- (make-syntax '#{ $sc-ellipsis }# (syntax-wrap e)
(syntax-module e))
+ (make-syntax
+ '#{ $sc-ellipsis }#
+ (syntax-wrap e)
+ (syntax-module e)
+ #f)
'(())
r
mod
@@ -1556,11 +1562,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-fe3
- tmp-680b775fb37a463-fe2
-
tmp-680b775fb37a463-fe1)
- (cons tmp-680b775fb37a463-fe1
- (cons
tmp-680b775fb37a463-fe2 tmp-680b775fb37a463-fe3)))
+ (map (lambda (tmp-680b775fb37a463-fe5
+ tmp-680b775fb37a463-fe4
+
tmp-680b775fb37a463-fe3)
+ (cons tmp-680b775fb37a463-fe3
+ (cons
tmp-680b775fb37a463-fe4 tmp-680b775fb37a463-fe5)))
e2*
e1*
args*)))
@@ -1858,9 +1864,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-69a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463
- (cons tmp-680b775fb37a463-1
tmp-680b775fb37a463-69a)))
+ (map (lambda (tmp-680b775fb37a463-69c
+ tmp-680b775fb37a463-69b
+ tmp-680b775fb37a463-69a)
+ (cons tmp-680b775fb37a463-69a
+ (cons tmp-680b775fb37a463-69b
tmp-680b775fb37a463-69c)))
e2
e1
args)))
@@ -1872,11 +1880,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-6b0
- tmp-680b775fb37a463-6af
- tmp-680b775fb37a463-6ae)
- (cons tmp-680b775fb37a463-6ae
- (cons tmp-680b775fb37a463-6af
tmp-680b775fb37a463-6b0)))
+ (map (lambda (tmp-680b775fb37a463-6b2
+ tmp-680b775fb37a463-6b1
+ tmp-680b775fb37a463-6b0)
+ (cons tmp-680b775fb37a463-6b0
+ (cons tmp-680b775fb37a463-6b1
tmp-680b775fb37a463-6b2)))
e2
e1
args)))
@@ -1913,9 +1921,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-67a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463
- (cons tmp-680b775fb37a463-1
tmp-680b775fb37a463-67a)))
+ (map (lambda (tmp-680b775fb37a463-67c
+ tmp-680b775fb37a463-67b
+ tmp-680b775fb37a463-67a)
+ (cons tmp-680b775fb37a463-67a
+ (cons tmp-680b775fb37a463-67b
tmp-680b775fb37a463-67c)))
e2
e1
args)))
@@ -1933,7 +1943,8 @@
(make-syntax
'#{ $sc-ellipsis }#
(syntax-wrap dots)
- (syntax-module dots)))))
+ (syntax-module dots)
+ (syntax-source dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots
w s mod)))))
@@ -2115,7 +2126,8 @@
(make-syntax
(remodulate (syntax-expression x) mod)
(syntax-wrap x)
- mod))
+ mod
+ (syntax-source x)))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0))
@@ -2411,8 +2423,12 @@
(cons 'hygiene (module-name (current-module))))))
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
- (lambda (id datum)
- (make-syntax datum (syntax-wrap id) (syntax-module id))))
+ (lambda* (id datum #:optional (srcloc #f))
+ (make-syntax
+ datum
+ (syntax-wrap id)
+ (syntax-module id)
+ (if srcloc (syntax-source srcloc) (source-properties datum)))))
(set! syntax->datum (lambda (x) (strip x '(()))))
(set! generate-temporaries
(lambda (ls)
@@ -2502,7 +2518,8 @@
(make-syntax
(syntax-expression value)
(anti-mark (syntax-wrap value))
- (syntax-module value))))
+ (syntax-module value)
+ (syntax-source value))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
@@ -2820,11 +2837,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463
- tmp-680b775fb37a463-110f
- tmp-680b775fb37a463-110e)
- (list (cons tmp-680b775fb37a463-110e
tmp-680b775fb37a463-110f)
- tmp-680b775fb37a463))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
template
pattern
keyword)))
@@ -2840,9 +2855,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ (map (lambda (tmp-680b775fb37a463-112b
+ tmp-680b775fb37a463-112a
+ tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-112a)
+ tmp-680b775fb37a463-112b))
template
pattern
keyword)))
@@ -2875,9 +2892,9 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
- (list (cons
tmp-680b775fb37a463-115f tmp-680b775fb37a463)
- tmp-680b775fb37a463-1))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
template
pattern
keyword)))
@@ -3084,8 +3101,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-122c)
- (list "value"
tmp-680b775fb37a463-122c))
+ (map (lambda
(tmp-680b775fb37a463-122e)
+ (list "value"
tmp-680b775fb37a463-122e))
p)
(vquasi q lev))
(quasicons
@@ -3195,8 +3212,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-127a)
- (cons "vector"
t-680b775fb37a463-127a))
+ (apply (lambda (t-680b775fb37a463-127c)
+ (cons "vector"
t-680b775fb37a463-127c))
tmp)
(syntax-violation
#f
@@ -3231,9 +3248,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12a4)
+ (apply (lambda
(t-680b775fb37a463-12a6)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12a4))
+
t-680b775fb37a463-12a6))
tmp)
(syntax-violation
#f
@@ -3249,10 +3266,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-12b8 t-680b775fb37a463-12b7)
+ (apply (lambda
(t-680b775fb37a463-12ba t-680b775fb37a463-12b9)
(list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-12b8
-
t-680b775fb37a463-12b7))
+
t-680b775fb37a463-12ba
+
t-680b775fb37a463-12b9))
tmp)
(syntax-violation
#f
@@ -3265,9 +3282,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12c4)
+ (apply (lambda
(t-680b775fb37a463-12c6)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12c4))
+
t-680b775fb37a463-12c6))
tmp)
(syntax-violation
#f
@@ -3280,9 +3297,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12d0)
+ (apply (lambda
(t-680b775fb37a463-12d2)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12d0))
+
t-680b775fb37a463-12d2))
tmp)
(syntax-violation
#f
@@ -3293,9 +3310,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-12dc tmp))
+ (let
((t-680b775fb37a463-12de tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12dc))))
+
t-680b775fb37a463-12de))))
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 1616c73..f0c1f03 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1347,7 +1347,7 @@
;; need to make sure the fmod information is
;; propagated back correctly -- hence this
;; consing.
- (values 'global-call (make-syntax fval w fmod)
+ (values 'global-call (make-syntax fval w fmod fs)
e e w s mod)))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
@@ -1538,7 +1538,8 @@
(make-syntax
(syntax-expression x)
(make-wrap (cdr ms) (if rib (cons rib (cdr ss))
(cdr ss)))
- (syntax-module x))
+ (syntax-module x)
+ (syntax-source x))
;; output introduced by macro
(make-syntax
(decorate-source (syntax-expression x) s)
@@ -1546,7 +1547,8 @@
(if rib
(cons rib (cons 'shift ss))
(cons 'shift ss)))
- (syntax-module x))))))
+ (syntax-module x)
+ (syntax-source x))))))
((vector? x)
(let* ((n (vector-length x))
@@ -1780,8 +1782,9 @@
(call-with-values
(lambda () (resolve-identifier
(make-syntax '#{ $sc-ellipsis }#
- (syntax-wrap e)
- (syntax-module e))
+ (syntax-wrap e)
+ (syntax-module e)
+ #f)
empty-wrap r mod #f))
(lambda (type value mod)
(if (eq? type 'ellipsis)
@@ -2343,8 +2346,9 @@
(let ((id (if (symbol? #'dots)
'#{ $sc-ellipsis }#
(make-syntax '#{ $sc-ellipsis }#
- (syntax-wrap #'dots)
- (syntax-module
#'dots)))))
+ (syntax-wrap #'dots)
+ (syntax-module #'dots)
+ (syntax-source #'dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (make-binding 'ellipsis
(source-wrap #'dots w s mod)))))
@@ -2501,7 +2505,8 @@
(remodulate (syntax-expression x) mod)
(syntax-wrap x)
;; hither the remodulation
- mod))
+ mod
+ (syntax-source x)))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector
n)))
(do ((i 0 (fx+ i 1)))
@@ -2758,9 +2763,11 @@
(nonsymbol-id? x)))
(set! datum->syntax
- (lambda (id datum)
- (make-syntax datum (syntax-wrap id)
- (syntax-module id))))
+ (lambda* (id datum #:optional srcloc)
+ (make-syntax datum (syntax-wrap id) (syntax-module id)
+ (if srcloc
+ (syntax-source srcloc)
+ (source-properties datum)))))
(set! syntax->datum
;; accepts any object, since syntax objects may consist partially
@@ -2838,8 +2845,9 @@
((ellipsis)
(values 'ellipsis
(make-syntax (syntax-expression value)
- (anti-mark (syntax-wrap value))
- (syntax-module value))))
+ (anti-mark (syntax-wrap value))
+ (syntax-module value)
+ (syntax-source value))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
| [Prev in Thread] | Current Thread | [Next in Thread] |