mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Avoid source properties in psyntax

Browse source 
* module/ice-9/psyntax.scm (source-annotation): Only return source
properties from syntax objects.
(source-wrap): Don't look for source properties.
(expand-macro): Rebuild source properties on macro output via
source-wrap, not source properties.  Only annotate head of a chain of
pairs.
(strip): Here's the only use of set-source-properties!: when stripping
a syntax object to a datum.
(macroexpand): If the input expression is not a syntax object, eagerly
extract its source properties.
(datum->syntax): Fix case in which source is given as an alist.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2022-02-01 16:25:03 +01:00
parent e933282f2b
commit 54bbe0b284
2 changed files with 170 additions and 136 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -140,11 +140,6 @@
(sourcev-filename sourcev) (sourcev-filename sourcev)
(list (cons 'line (sourcev-line sourcev)) (list (cons 'line (sourcev-line sourcev))
(cons 'column (sourcev-column sourcev)))))))) (cons 'column (sourcev-column sourcev))))))))
(decorate-source
(lambda (e s)
(if (and s (supports-source-properties? e))
(set-source-properties! e (sourcev->alist s)))
e))
(maybe-name-value! (maybe-name-value!
(lambda (name val) (lambda (name val)
(if (lambda? val) (if (lambda? val)
@ -282,16 +277,7 @@
vars vars
val-exps val-exps
body-exp))))) body-exp)))))
(datum-sourcev (source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x))))
(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)
@ -589,7 +575,7 @@
(cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x) (cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x) ((null? x) x)
(else (make-syntax x w defmod (or s (datum-sourcev x))))))) (else (make-syntax x w defmod s)))))
(expand-sequence (expand-sequence
(lambda (body r w s mod) (lambda (body r w s mod)
(build-sequence (build-sequence
@ -837,10 +823,12 @@
'define-form 'define-form
(wrap name w mod) (wrap name w mod)
(wrap e w mod) (wrap e w mod)
(decorate-source (source-wrap
(cons (make-syntax 'lambda '((top)) '(hygiene guile)) (cons (make-syntax 'lambda '((top)) '(hygiene guile))
(wrap (cons args (cons e1 e2)) w mod)) (wrap (cons args (cons e1 e2)) w mod))
s) '(())
s
#f)
'(()) '(())
s s
mod)) mod))
@ -1009,13 +997,15 @@
(expand-macro (expand-macro
(lambda (p e r w s rib mod) (lambda (p e r w s rib mod)
(letrec* (letrec*
((rebuild-macro-output ((decorate-source (lambda (x) (source-wrap x '(()) s #f)))
(map* (lambda (f x)
(cond ((null? x) x)
((pair? x) (cons (f (car x)) (map* f (cdr x))))
(else (f x)))))
(rebuild-macro-output
(lambda (x m) (lambda (x m)
(cond ((pair? x) (cond ((pair? x)
(decorate-source (decorate-source (map* (lambda (x) (rebuild-macro-output x m)) x)))
(cons (rebuild-macro-output (car x) m)
(rebuild-macro-output (cdr x) m))
s))
((syntax? x) ((syntax? x)
(let ((w (syntax-wrap x))) (let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w))) (let ((ms (car w)) (ss (cdr w)))
@ -1030,25 +1020,26 @@
(if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
mod))))) mod)))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) (let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0)) (let loop ((i 0))
(if (= i n) (if (= i n)
(begin (if #f #f) v) (begin (if #f #f) v)
(begin (begin
(vector-set! v i (rebuild-macro-output (vector-ref x i) m)) (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
(loop (+ i 1))))))) (loop (+ i 1)))))
(decorate-source v)))
((symbol? x) ((symbol? x)
(syntax-violation (syntax-violation
#f #f
"encountered raw symbol in macro output" "encountered raw symbol in macro output"
(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))))))
(let* ((t-680b775fb37a463-ddd transformer-environment) (let* ((t-680b775fb37a463-de2 transformer-environment)
(t-680b775fb37a463-dde (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-de3 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-ddd t-680b775fb37a463-de2
t-680b775fb37a463-dde t-680b775fb37a463-de3
(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))
@ -1617,9 +1608,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1
(cons tmp-680b775fb37a463 tmp-680b775fb37a463
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-105f)
(cons tmp-680b775fb37a463-105f
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1634,12 +1627,15 @@
tmp)))))))) tmp))))))))
(strip (lambda (x) (strip (lambda (x)
(letrec* (letrec*
((annotate (lambda (proc datum) (decorate-source datum (proc x))))) ((annotate
(lambda (proc datum)
(let ((s (proc x)))
(if (and s (supports-source-properties? datum))
(set-source-properties! datum (sourcev->alist s)))
datum))))
(cond ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x)))) (cond ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x))))
((pair? x) ((pair? x) (cons (strip (car x)) (strip (cdr x))))
(annotate datum-sourcev (cons (strip (car x)) (strip (cdr x))))) ((vector? x) (list->vector (strip (vector->list x))))
((vector? x)
(annotate datum-sourcev (list->vector (strip (vector->list x)))))
(else x))))) (else x)))))
(gen-var (gen-var
(lambda (id) (lambda (id)
@ -1925,11 +1921,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6b2 (map (lambda (tmp-680b775fb37a463-6c1
tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6c0
tmp-680b775fb37a463-6b0) tmp-680b775fb37a463-6bf)
(cons tmp-680b775fb37a463-6b0 (cons tmp-680b775fb37a463-6bf
(cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2))) (cons tmp-680b775fb37a463-6c0 tmp-680b775fb37a463-6c1)))
e2 e2
e1 e1
args))) args)))
@ -1941,11 +1937,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-6c8 (map (lambda (tmp-680b775fb37a463-6d7
tmp-680b775fb37a463-6c7 tmp-680b775fb37a463-6d6
tmp-680b775fb37a463-6c6) tmp-680b775fb37a463-6d5)
(cons tmp-680b775fb37a463-6c6 (cons tmp-680b775fb37a463-6d5
(cons tmp-680b775fb37a463-6c7 tmp-680b775fb37a463-6c8))) (cons tmp-680b775fb37a463-6d6 tmp-680b775fb37a463-6d7)))
e2 e2
e1 e1
args))) args)))
@ -1968,11 +1964,9 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-67c (map (lambda (tmp-680b775fb37a463-68b tmp-680b775fb37a463-68a tmp-680b775fb37a463)
tmp-680b775fb37a463-67b (cons tmp-680b775fb37a463
tmp-680b775fb37a463-67a) (cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b)))
(cons tmp-680b775fb37a463-67a
(cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c)))
e2 e2
e1 e1
args))) args)))
@ -1984,9 +1978,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-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-6a1
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-6a0
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-69f)
(cons tmp-680b775fb37a463-69f
(cons tmp-680b775fb37a463-6a0 tmp-680b775fb37a463-6a1)))
e2 e2
e1 e1
args))) args)))
@ -2476,25 +2472,47 @@
tmp-1)))))) tmp-1))))))
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(expand-top-sequence (letrec*
(list x) ((unstrip
'() (lambda (x)
'((top)) (letrec*
#f ((annotate
m (lambda (result)
esew (let ((props (source-properties x)))
(cons 'hygiene (module-name (current-module)))))) (if (pair? props) (datum->syntax #f result #:source props) result)))))
(cond ((pair? x) (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
((vector? x)
(let ((v (make-vector (vector-length x))))
(annotate (list->vector (map unstrip (vector->list x))))))
((syntax? x) x)
(else (annotate x)))))))
(expand-top-sequence
(list (unstrip x))
'()
'((top))
#f
m
esew
(cons 'hygiene (module-name (current-module)))))))
(set! identifier? (lambda (x) (nonsymbol-id? x))) (set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax (set! datum->syntax
(lambda* (id datum #:key (source #f #:source)) (lambda* (id datum #:key (source #f #:source))
(make-syntax (letrec*
datum ((props->sourcev
(if id (syntax-wrap id) '(())) (lambda (alist)
(and id (syntax-module id)) (and (pair? alist)
(cond ((not source) (datum-sourcev datum)) (vector
((and (list? source) (and-map pair? source)) source) (assq-ref alist 'filename)
((and (vector? source) (= 3 (vector-length source))) source) (assq-ref alist 'line)
(else (syntax-sourcev source)))))) (assq-ref alist 'column))))))
(make-syntax
datum
(if id (syntax-wrap id) '(()))
(and id (syntax-module id))
(cond ((not source) (props->sourcev (source-properties datum)))
((and (list? source) (and-map pair? source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) source)
(else (syntax-sourcev source)))))))
(set! syntax->datum (lambda (x) (strip x))) (set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries (set! generate-temporaries
(lambda (ls) (lambda (ls)
@ -2900,11 +2918,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-116d (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f)
tmp-680b775fb37a463-116c (list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463)
tmp-680b775fb37a463-116b) tmp-680b775fb37a463-1))
(list (cons tmp-680b775fb37a463-116b tmp-680b775fb37a463-116c)
tmp-680b775fb37a463-116d))
template template
pattern pattern
keyword))) keyword)))
@ -2920,9 +2936,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-119a))
template template
pattern pattern
keyword))) keyword)))
@ -2937,11 +2953,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-119f (map (lambda (tmp-680b775fb37a463-11b3
tmp-680b775fb37a463-119e tmp-680b775fb37a463-11b2
tmp-680b775fb37a463-119d) tmp-680b775fb37a463-11b1)
(list (cons tmp-680b775fb37a463-119d tmp-680b775fb37a463-119e) (list (cons tmp-680b775fb37a463-11b1 tmp-680b775fb37a463-11b2)
tmp-680b775fb37a463-119f)) tmp-680b775fb37a463-11b3))
template template
pattern pattern
keyword))) keyword)))
@ -2957,11 +2973,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11be (map (lambda (tmp-680b775fb37a463-11d2
tmp-680b775fb37a463-11bd tmp-680b775fb37a463-11d1
tmp-680b775fb37a463-11bc) tmp-680b775fb37a463-11d0)
(list (cons tmp-680b775fb37a463-11bc tmp-680b775fb37a463-11bd) (list (cons tmp-680b775fb37a463-11d0 tmp-680b775fb37a463-11d1)
tmp-680b775fb37a463-11be)) tmp-680b775fb37a463-11d2))
template template
pattern pattern
keyword))) keyword)))
@ -3109,8 +3125,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-126e) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-126e)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3168,7 +3184,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) (map (lambda (tmp-680b775fb37a463-129d)
(list "value" tmp-680b775fb37a463-129d))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3187,8 +3204,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-128e) (map (lambda (tmp-680b775fb37a463-12a2)
(list "value" tmp-680b775fb37a463-128e)) (list "value" tmp-680b775fb37a463-12a2))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3278,8 +3295,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-12d7) (apply (lambda (t-680b775fb37a463-12eb)
(cons "vector" t-680b775fb37a463-12d7)) (cons "vector" t-680b775fb37a463-12eb))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3289,8 +3306,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-12e3) (k (map (lambda (tmp-680b775fb37a463-12f7)
(list "quote" tmp-680b775fb37a463-12e3)) (list "quote" tmp-680b775fb37a463-12f7))
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))))
@ -3301,8 +3318,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-12f2 tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-12f2))))))))))))))))) (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))))
@ -3364,9 +3381,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-132d) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-132d)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3377,9 +3394,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-134d tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463)))) t-680b775fb37a463-134d))))
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

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

@ -1,6 +1,6 @@
;;;; -*-scheme-*- ;;;; -*-scheme-*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2021 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2022
;;;; Free Software Foundation, Inc. ;;;; 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
@ -278,11 +278,6 @@
`((line . ,(sourcev-line sourcev)) `((line . ,(sourcev-line sourcev))
(column . ,(sourcev-column sourcev)))))) (column . ,(sourcev-column sourcev))))))
(define (decorate-source e s)
(when (and s (supports-source-properties? e))
(set-source-properties! e (sourcev->alist s)))
e)
(define (maybe-name-value! name val) (define (maybe-name-value! name val)
(if (lambda? val) (if (lambda? val)
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
@ -436,18 +431,10 @@
(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)
(if (syntax? x) (and (syntax? x)
(syntax-sourcev 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))
@ -1044,7 +1031,7 @@
x) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x) ((null? x) x)
(else (make-syntax x w defmod (or s (datum-sourcev x)))))) (else (make-syntax x w defmod s))))
;; expanding ;; expanding
@ -1366,9 +1353,9 @@
;; need lambda here... ;; need lambda here...
(values 'define-form (wrap #'name w mod) (values 'define-form (wrap #'name w mod)
(wrap e w mod) (wrap e w mod)
(decorate-source (source-wrap
(cons #'lambda (wrap #'(args e1 e2 ...) w mod)) (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
s) empty-wrap s #f)
empty-wrap s mod)) empty-wrap s mod))
((_ name) ((_ name)
(id? #'name) (id? #'name)
@ -1514,13 +1501,18 @@
;; possible. ;; possible.
(define expand-macro (define expand-macro
(lambda (p e r w s rib mod) (lambda (p e r w s rib mod)
(define (decorate-source x)
(source-wrap x empty-wrap s #f))
(define (map* f x)
(cond
((null? x) x)
((pair? x) (cons (f (car x)) (map* f (cdr x))))
(else (f x))))
(define rebuild-macro-output (define rebuild-macro-output
(lambda (x m) (lambda (x m)
(cond ((pair? x) (cond ((pair? x)
(decorate-source (decorate-source
(cons (rebuild-macro-output (car x) m) (map* (lambda (x) (rebuild-macro-output x m)) x)))
(rebuild-macro-output (cdr x) m))
s))
((syntax? x) ((syntax? x)
(let ((w (syntax-wrap x))) (let ((w (syntax-wrap x)))
(let ((ms (wrap-marks w)) (ss (wrap-subst w))) (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
@ -1544,15 +1536,16 @@
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (let* ((n (vector-length x))
(v (decorate-source (make-vector n) s))) (v (make-vector n)))
(do ((i 0 (fx+ i 1))) (do ((i 0 (fx+ i 1)))
((fx= i n) v) ((fx= i n) v)
(vector-set! v i (vector-set! v i
(rebuild-macro-output (vector-ref x i) m))))) (rebuild-macro-output (vector-ref x i) m)))
(decorate-source v)))
((symbol? x) ((symbol? x)
(syntax-violation #f "encountered raw symbol in macro output" (syntax-violation #f "encountered raw symbol in macro output"
(source-wrap e w (wrap-subst w) mod) x)) (source-wrap e w (wrap-subst w) mod) x))
(else (decorate-source x s))))) (else (decorate-source x)))))
(with-fluids ((transformer-environment (with-fluids ((transformer-environment
(lambda (k) (k e r w s rib mod)))) (lambda (k) (k e r w s rib mod))))
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
@ -1997,14 +1990,17 @@
(define (strip x) (define (strip x)
(define (annotate proc datum) (define (annotate proc datum)
(decorate-source datum (proc x))) (let ((s (proc x)))
(when (and s (supports-source-properties? datum))
(set-source-properties! datum (sourcev->alist s)))
datum))
(cond (cond
((syntax? x) ((syntax? x)
(annotate syntax-sourcev (strip (syntax-expression x)))) (annotate syntax-sourcev (strip (syntax-expression x))))
((pair? x) ((pair? x)
(annotate datum-sourcev (cons (strip (car x)) (strip (cdr x))))) (cons (strip (car x)) (strip (cdr x))))
((vector? x) ((vector? x)
(annotate datum-sourcev (list->vector (strip (vector->list x))))) (list->vector (strip (vector->list x))))
(else x))) (else x)))
;; lexical variables ;; lexical variables
@ -2739,7 +2735,21 @@
;; the object file if we are compiling a file. ;; the object file if we are compiling a file.
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(expand-top-sequence (list x) null-env top-wrap #f m esew (define (unstrip x)
(define (annotate result)
(let ((props (source-properties x)))
(if (pair? props)
(datum->syntax #f result #:source props)
result)))
(cond
((pair? x)
(annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
((vector? x)
(let ((v (make-vector (vector-length x))))
(annotate (list->vector (map unstrip (vector->list x))))))
((syntax? x) x)
(else (annotate x))))
(expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module)))))) (cons 'hygiene (module-name (current-module))))))
(set! identifier? (set! identifier?
@ -2748,6 +2758,11 @@
(set! datum->syntax (set! datum->syntax
(lambda* (id datum #:key source) (lambda* (id datum #:key source)
(define (props->sourcev alist)
(and (pair? alist)
(vector (assq-ref alist 'filename)
(assq-ref alist 'line)
(assq-ref alist 'column))))
(make-syntax datum (make-syntax datum
(if id (if id
(syntax-wrap id) (syntax-wrap id)
@ -2756,8 +2771,10 @@
(syntax-module id) (syntax-module id)
#f) #f)
(cond (cond
((not source) (datum-sourcev datum)) ((not source)
((and (list? source) (and-map pair? source)) source) (props->sourcev (source-properties datum)))
((and (list? source) (and-map pair? source))
(props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) ((and (vector? source) (= 3 (vector-length source)))
source) source)
(else (syntax-sourcev source)))))) (else (syntax-sourcev source))))))