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

Psyntax uses sourcev internally

Browse source 
* module/ice-9/psyntax.scm: Use the vector representation of source
properties internally.  We have to convert to alists when going to
Tree-IL, but this will be in harmony with syntax objects once the reader
switches to vectors too.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2021-02-25 16:06:43 +01:00
parent 7e01042337
commit 18c09f0492
2 changed files with 220 additions and 150 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -5,7 +5,8 @@
(make-syntax (module-ref (current-module) 'make-syntax)) (make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap)) (syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module))) (syntax-module (module-ref (current-module) 'syntax-module))
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
(letrec* (letrec*
((make-void ((make-void
(lambda (src) (lambda (src)
@ -126,10 +127,23 @@
(session-id (session-id
(let ((v (module-variable (current-module) 'syntax-session-id))) (let ((v (module-variable (current-module) 'syntax-session-id)))
(lambda () ((variable-ref v))))) (lambda () ((variable-ref v)))))
(sourcev-filename (lambda (s) (vector-ref s 0)))
(sourcev-line (lambda (s) (vector-ref s 1)))
(sourcev-column (lambda (s) (vector-ref s 2)))
(sourcev->alist
(lambda (sourcev)
(letrec*
((maybe-acons (lambda (k v tail) (if v (acons k v tail) tail))))
(and sourcev
(maybe-acons
'filename
(sourcev-filename sourcev)
(list (cons 'line (sourcev-line sourcev))
(cons 'column (sourcev-column sourcev))))))))
(decorate-source (decorate-source
(lambda (e s) (lambda (e s)
(if (and s (supports-source-properties? e)) (if (and s (supports-source-properties? e))
(set-source-properties! e s)) (set-source-properties! e (sourcev->alist s)))
e)) e))
(maybe-name-value! (maybe-name-value!
(lambda (name val) (lambda (name val)
@ -137,19 +151,24 @@
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
(if (not (assq 'name meta)) (if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta))))))) (set-lambda-meta! val (acons 'name name meta)))))))
(build-void (lambda (source) (make-void source))) (build-void (lambda (sourcev) (make-void (sourcev->alist sourcev))))
(build-call (build-call
(lambda (source fun-exp arg-exps) (lambda (sourcev fun-exp arg-exps)
(make-call source fun-exp arg-exps))) (make-call (sourcev->alist sourcev) fun-exp arg-exps)))
(build-conditional (build-conditional
(lambda (source test-exp then-exp else-exp) (lambda (sourcev test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp))) (make-conditional
(sourcev->alist sourcev)
test-exp
then-exp
else-exp)))
(build-lexical-reference (build-lexical-reference
(lambda (type source name var) (make-lexical-ref source name var))) (lambda (type sourcev name var)
(make-lexical-ref (sourcev->alist sourcev) name var)))
(build-lexical-assignment (build-lexical-assignment
(lambda (source name var exp) (lambda (sourcev name var exp)
(maybe-name-value! name exp) (maybe-name-value! name exp)
(make-lexical-set source name var exp))) (make-lexical-set (sourcev->alist sourcev) name var exp)))
(analyze-variable (analyze-variable
(lambda (mod var modref-cont bare-cont) (lambda (mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -171,49 +190,72 @@
(syntax-violation #f "primitive not in operator position" var)) (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod)))))))) (else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference (build-global-reference
(lambda (source var mod) (lambda (sourcev var mod)
(analyze-variable (analyze-variable
mod mod
var var
(lambda (mod var public?) (make-module-ref source mod var public?)) (lambda (mod var public?)
(lambda (mod var) (make-toplevel-ref source mod var))))) (make-module-ref (sourcev->alist sourcev) mod var public?))
(lambda (mod var)
(make-toplevel-ref (sourcev->alist sourcev) mod var)))))
(build-global-assignment (build-global-assignment
(lambda (source var exp mod) (lambda (sourcev var exp mod)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(analyze-variable (analyze-variable
mod mod
var var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-set source mod var public? exp)) (make-module-set (sourcev->alist sourcev) mod var public? exp))
(lambda (mod var) (make-toplevel-set source mod var exp))))) (lambda (mod var)
(make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
(build-global-definition (build-global-definition
(lambda (source mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(make-toplevel-define source (and mod (cdr mod)) var exp))) (make-toplevel-define
(sourcev->alist sourcev)
(and mod (cdr mod))
var
exp)))
(build-simple-lambda (build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda (make-lambda
src (sourcev->alist src)
meta meta
(make-lambda-case src req #f rest #f '() vars exp #f)))) (make-lambda-case src req #f rest #f '() vars exp #f))))
(build-case-lambda (build-case-lambda
(lambda (src meta body) (make-lambda src meta body))) (lambda (src meta body) (make-lambda (sourcev->alist src) meta body)))
(build-lambda-case (build-lambda-case
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case))) (make-lambda-case
(sourcev->alist src)
req
opt
rest
kw
inits
vars
body
else-case)))
(build-primcall (build-primcall
(lambda (src name args) (make-primcall src name args))) (lambda (src name args)
(build-primref (lambda (src name) (make-primitive-ref src name))) (make-primcall (sourcev->alist src) name args)))
(build-data (lambda (src exp) (make-const src exp))) (build-primref
(lambda (src name) (make-primitive-ref (sourcev->alist src) name)))
(build-data (lambda (src exp) (make-const (sourcev->alist src) exp)))
(build-sequence (build-sequence
(lambda (src exps) (lambda (src exps)
(if (null? (cdr exps)) (if (null? (cdr exps))
(car exps) (car exps)
(make-seq src (car exps) (build-sequence #f (cdr exps)))))) (make-seq
(sourcev->alist src)
(car exps)
(build-sequence #f (cdr exps))))))
(build-let (build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) (if (null? vars)
body-exp
(make-let (sourcev->alist src) ids vars val-exps body-exp))))
(build-named-let (build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
@ -221,7 +263,7 @@
(maybe-name-value! f-name proc) (maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
src (sourcev->alist src)
#f #f
(list f-name) (list f-name)
(list f) (list f)
@ -233,12 +275,23 @@
body-exp body-exp
(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
(sourcev->alist src)
in-order?
ids
vars
val-exps
body-exp)))))
(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 (source-annotation
(lambda (x) (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
(if (syntax? x)
(syntax-source x)
(let ((props (source-properties x))) (and (pair? props) props)))))
(extend-env (extend-env
(lambda (labels bindings r) (lambda (labels bindings r)
(if (null? labels) (if (null? labels)
@ -529,13 +582,13 @@
(syntax-expression x) (syntax-expression x)
w w
(or (syntax-module x) defmod) (or (syntax-module x) defmod)
(syntax-source x)))) (syntax-sourcev x))))
(source-wrap (source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(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 (source-properties x))))))) (else (make-syntax x w defmod (or s (datum-sourcev x)))))))
(expand-sequence (expand-sequence
(lambda (body r w s mod) (lambda (body r w s mod)
(build-sequence (build-sequence
@ -990,11 +1043,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-db4 transformer-environment) (let* ((t-680b775fb37a463-dd8 transformer-environment)
(t-680b775fb37a463-db5 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-dd9 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-db4 t-680b775fb37a463-dd8
t-680b775fb37a463-db5 t-680b775fb37a463-dd9
(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))
@ -1030,13 +1083,15 @@
(lp (cdr var-ids) (lp (cdr var-ids)
(cdr vars) (cdr vars)
(cdr vals) (cdr vals)
(make-seq src ((car vals)) tail))) (make-seq (sourcev->alist src) ((car vals)) tail)))
(else (else
(let ((var-ids (let ((var-ids
(map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids))) (map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids)))
(vars (map (lambda (var) (or var (gen-label))) (reverse vars))) (vars (map (lambda (var) (or var (gen-label))) (reverse vars)))
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (expand-expr) (make-seq src (expand-expr) (build-void src)))) (if id
(expand-expr)
(make-seq (sourcev->alist src) (expand-expr) (build-void src))))
(reverse vals) (reverse vals)
(reverse var-ids)))) (reverse var-ids))))
(build-letrec src #t var-ids vars vals tail))))))) (build-letrec src #t var-ids vars vals tail)))))))
@ -1561,9 +1616,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-104d
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-104c
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-104b)
(cons tmp-680b775fb37a463-104b
(cons tmp-680b775fb37a463-104c tmp-680b775fb37a463-104d)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1578,17 +1635,12 @@
tmp)))))))) tmp))))))))
(strip (lambda (x) (strip (lambda (x)
(letrec* (letrec*
((annotate ((annotate (lambda (proc datum) (decorate-source datum (proc x)))))
(lambda (proc datum) (cond ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x))))
(let ((src (proc x)))
(if (and (pair? src) (supports-source-properties? datum))
(set-source-properties! datum src))
datum))))
(cond ((syntax? x) (annotate syntax-source (strip (syntax-expression x))))
((pair? x) ((pair? x)
(annotate source-properties (cons (strip (car x)) (strip (cdr x))))) (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x)))))
((vector? x) ((vector? x)
(annotate source-properties (list->vector (strip (vector->list x))))) (annotate datum-sourcev (list->vector (strip (vector->list x)))))
(else x))))) (else x)))))
(gen-var (gen-var
(lambda (id) (lambda (id)
@ -1871,11 +1923,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6a4 (map (lambda (tmp-680b775fb37a463-6b2
tmp-680b775fb37a463-6a3 tmp-680b775fb37a463-6b1
tmp-680b775fb37a463-6a2) tmp-680b775fb37a463-6b0)
(cons tmp-680b775fb37a463-6a2 (cons tmp-680b775fb37a463-6b0
(cons tmp-680b775fb37a463-6a3 tmp-680b775fb37a463-6a4))) (cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2)))
e2 e2
e1 e1
args))) args)))
@ -1887,11 +1939,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-6ba (map (lambda (tmp-680b775fb37a463-6c8
tmp-680b775fb37a463-6b9 tmp-680b775fb37a463-6c7
tmp-680b775fb37a463-6b8) tmp-680b775fb37a463-6c6)
(cons tmp-680b775fb37a463-6b8 (cons tmp-680b775fb37a463-6c6
(cons tmp-680b775fb37a463-6b9 tmp-680b775fb37a463-6ba))) (cons tmp-680b775fb37a463-6c7 tmp-680b775fb37a463-6c8)))
e2 e2
e1 e1
args))) args)))
@ -1914,11 +1966,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-66e (map (lambda (tmp-680b775fb37a463-67c
tmp-680b775fb37a463-66d tmp-680b775fb37a463-67b
tmp-680b775fb37a463-66c) tmp-680b775fb37a463-67a)
(cons tmp-680b775fb37a463-66c (cons tmp-680b775fb37a463-67a
(cons tmp-680b775fb37a463-66d tmp-680b775fb37a463-66e))) (cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c)))
e2 e2
e1 e1
args))) args)))
@ -1951,7 +2003,7 @@
'#{ $sc-ellipsis }# '#{ $sc-ellipsis }#
(syntax-wrap dots) (syntax-wrap dots)
(syntax-module dots) (syntax-module dots)
(syntax-source dots))))) (syntax-sourcev dots)))))
(let ((ids (list id)) (let ((ids (list id))
(labels (list (gen-label))) (labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
@ -2134,7 +2186,7 @@
(remodulate (syntax-expression x) mod) (remodulate (syntax-expression x) mod)
(syntax-wrap x) (syntax-wrap x)
mod mod
(syntax-source x))) (syntax-sourcev x)))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0)) (let loop ((i 0))
@ -2437,9 +2489,10 @@
datum datum
(if id (syntax-wrap id) '(())) (if id (syntax-wrap id) '(()))
(and id (syntax-module id)) (and id (syntax-module id))
(cond ((not source) (source-properties datum)) (cond ((not source) (datum-sourcev datum))
((and (list? source) (and-map pair? source)) source) ((and (list? source) (and-map pair? source)) source)
(else (syntax-source 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)
@ -2862,9 +2915,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-1))
template template
pattern pattern
keyword))) keyword)))
@ -2879,11 +2932,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-117b (map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-117a (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463) tmp-680b775fb37a463-119a))
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-117a)
tmp-680b775fb37a463-117b))
template template
pattern pattern
keyword))) keyword)))
@ -2899,9 +2950,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-11b9
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-11b8
tmp-680b775fb37a463-119a)) tmp-680b775fb37a463-11b7)
(list (cons tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8)
tmp-680b775fb37a463-11b9))
template template
pattern pattern
keyword))) keyword)))
@ -3049,8 +3102,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-124a) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-124a)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3073,8 +3126,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-124f) (map (lambda (tmp-680b775fb37a463-126e)
(list "value" tmp-680b775fb37a463-124f)) (list "value" tmp-680b775fb37a463-126e))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3127,8 +3180,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-126a) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-126a)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3218,8 +3271,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-12b3) (apply (lambda (t-680b775fb37a463-12d2)
(cons "vector" t-680b775fb37a463-12b3)) (cons "vector" t-680b775fb37a463-12d2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3229,8 +3282,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-12bf) (k (map (lambda (tmp-680b775fb37a463-12de)
(list "quote" tmp-680b775fb37a463-12bf)) (list "quote" tmp-680b775fb37a463-12de))
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))))
@ -3241,8 +3294,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-12ce tmp)) (let ((t-680b775fb37a463-12ed tmp))
(list "list->vector" t-680b775fb37a463-12ce))))))))))))))))) (list "list->vector" t-680b775fb37a463-12ed)))))))))))))))))
(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))))
@ -3255,9 +3308,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-12dd) (apply (lambda (t-680b775fb37a463-12fc)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12dd)) t-680b775fb37a463-12fc))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3273,10 +3326,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-12f1 t-680b775fb37a463-12f0) (apply (lambda (t-680b775fb37a463 t-680b775fb37a463-130f)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12f1 t-680b775fb37a463
t-680b775fb37a463-12f0)) t-680b775fb37a463-130f))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3289,9 +3342,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-12fd) (apply (lambda (t-680b775fb37a463-131c)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12fd)) t-680b775fb37a463-131c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -142,7 +142,8 @@
(make-syntax (module-ref (current-module) 'make-syntax)) (make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap)) (syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module))) (syntax-module (module-ref (current-module) 'syntax-module))
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
(define-syntax define-expansion-constructors (define-syntax define-expansion-constructors
(lambda (x) (lambda (x)
@ -267,9 +268,19 @@
(lambda () (lambda ()
((variable-ref v)))))) ((variable-ref v))))))
(define (sourcev-filename s) (vector-ref s 0))
(define (sourcev-line s) (vector-ref s 1))
(define (sourcev-column s) (vector-ref s 2))
(define (sourcev->alist sourcev)
(define (maybe-acons k v tail) (if v (acons k v tail) tail))
(and sourcev
(maybe-acons 'filename (sourcev-filename sourcev)
`((line . ,(sourcev-line sourcev))
(column . ,(sourcev-column sourcev))))))
(define (decorate-source e s) (define (decorate-source e s)
(if (and s (supports-source-properties? e)) (when (and s (supports-source-properties? e))
(set-source-properties! e s)) (set-source-properties! e (sourcev->alist s)))
e) e)
(define (maybe-name-value! name val) (define (maybe-name-value! name val)
@ -280,25 +291,25 @@
;; output constructors ;; output constructors
(define build-void (define build-void
(lambda (source) (lambda (sourcev)
(make-void source))) (make-void (sourcev->alist sourcev))))
(define build-call (define build-call
(lambda (source fun-exp arg-exps) (lambda (sourcev fun-exp arg-exps)
(make-call source fun-exp arg-exps))) (make-call (sourcev->alist sourcev) fun-exp arg-exps)))
(define build-conditional (define build-conditional
(lambda (source test-exp then-exp else-exp) (lambda (sourcev test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp))) (make-conditional (sourcev->alist sourcev) test-exp then-exp else-exp)))
(define build-lexical-reference (define build-lexical-reference
(lambda (type source name var) (lambda (type sourcev name var)
(make-lexical-ref source name var))) (make-lexical-ref (sourcev->alist sourcev) name var)))
(define build-lexical-assignment (define build-lexical-assignment
(lambda (source name var exp) (lambda (sourcev name var exp)
(maybe-name-value! name exp) (maybe-name-value! name exp)
(make-lexical-set source name var exp))) (make-lexical-set (sourcev->alist sourcev) name var exp)))
(define (analyze-variable mod var modref-cont bare-cont) (define (analyze-variable mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -320,32 +331,32 @@
(else (syntax-violation #f "bad module kind" var mod)))))) (else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference (define build-global-reference
(lambda (source var mod) (lambda (sourcev var mod)
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-ref source mod var public?)) (make-module-ref (sourcev->alist sourcev) mod var public?))
(lambda (mod var) (lambda (mod var)
(make-toplevel-ref source mod var))))) (make-toplevel-ref (sourcev->alist sourcev) mod var)))))
(define build-global-assignment (define build-global-assignment
(lambda (source var exp mod) (lambda (sourcev var exp mod)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-set source mod var public? exp)) (make-module-set (sourcev->alist sourcev) mod var public? exp))
(lambda (mod var) (lambda (mod var)
(make-toplevel-set source mod var exp))))) (make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
(define build-global-definition (define build-global-definition
(lambda (source mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(make-toplevel-define source (and mod (cdr mod)) var exp))) (make-toplevel-define (sourcev->alist sourcev) (and mod (cdr mod)) var exp)))
(define build-simple-lambda (define build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda src (make-lambda (sourcev->alist src)
meta meta
;; hah, a case in which kwargs would be nice. ;; hah, a case in which kwargs would be nice.
(make-lambda-case (make-lambda-case
@ -354,7 +365,7 @@
(define build-case-lambda (define build-case-lambda
(lambda (src meta body) (lambda (src meta body)
(make-lambda src meta body))) (make-lambda (sourcev->alist src) meta body)))
(define build-lambda-case (define build-lambda-case
;; req := (name ...) ;; req := (name ...)
@ -368,31 +379,31 @@
;; the body of a lambda: anything, already expanded ;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f ;; else: lambda-case | #f
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case))) (make-lambda-case (sourcev->alist src) req opt rest kw inits vars body else-case)))
(define build-primcall (define build-primcall
(lambda (src name args) (lambda (src name args)
(make-primcall src name args))) (make-primcall (sourcev->alist src) name args)))
(define build-primref (define build-primref
(lambda (src name) (lambda (src name)
(make-primitive-ref src name))) (make-primitive-ref (sourcev->alist src) name)))
(define (build-data src exp) (define (build-data src exp)
(make-const src exp)) (make-const (sourcev->alist src) exp))
(define build-sequence (define build-sequence
(lambda (src exps) (lambda (src exps)
(if (null? (cdr exps)) (if (null? (cdr exps))
(car exps) (car exps)
(make-seq src (car exps) (build-sequence #f (cdr exps)))))) (make-seq (sourcev->alist src) (car exps) (build-sequence #f (cdr exps))))))
(define build-let (define build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(if (null? vars) (if (null? vars)
body-exp body-exp
(make-let src ids vars val-exps body-exp)))) (make-let (sourcev->alist src) ids vars val-exps body-exp))))
(define build-named-let (define build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
@ -404,7 +415,7 @@
(maybe-name-value! f-name proc) (maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
src #f (sourcev->alist src) #f
(list f-name) (list f) (list proc) (list f-name) (list f) (list proc)
(build-call src (build-lexical-reference 'fun src f-name f) (build-call src (build-lexical-reference 'fun src f-name f)
val-exps)))))) val-exps))))))
@ -415,7 +426,7 @@
body-exp body-exp
(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 (sourcev->alist src) in-order? ids vars val-exps body-exp)))))
(define-syntax-rule (build-lexical-var src id) (define-syntax-rule (build-lexical-var src id)
@ -425,12 +436,18 @@
(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) (if (syntax? x)
(syntax-source x) (syntax-sourcev x)
(let ((props (source-properties x))) (datum-sourcev x))))
(and (pair? props) props)))))
(define-syntax-rule (arg-check pred? e who) (define-syntax-rule (arg-check pred? e who)
(let ((x e)) (let ((x e))
@ -1016,7 +1033,7 @@
(make-syntax (syntax-expression x) (make-syntax (syntax-expression x)
w w
(or (syntax-module x) defmod) (or (syntax-module x) defmod)
(syntax-source x))) (syntax-sourcev x)))
(define (source-wrap x w s defmod) (define (source-wrap x w s defmod)
(cond (cond
((and (null? (wrap-marks w)) ((and (null? (wrap-marks w))
@ -1026,7 +1043,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 (source-properties x)))))) (else (make-syntax x w defmod (or s (datum-sourcev x))))))
;; expanding ;; expanding
@ -1605,7 +1622,7 @@
((null? var-ids) tail) ((null? var-ids) tail)
((not (car var-ids)) ((not (car var-ids))
(lp (cdr var-ids) (cdr vars) (cdr vals) (lp (cdr var-ids) (cdr vars) (cdr vals)
(make-seq src ((car vals)) tail))) (make-seq (sourcev->alist src) ((car vals)) tail)))
(else (else
(let ((var-ids (map (lambda (id) (let ((var-ids (map (lambda (id)
(if id (syntax->datum id) '_)) (if id (syntax->datum id) '_))
@ -1615,7 +1632,8 @@
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (if id
(expand-expr) (expand-expr)
(make-seq src (expand-expr) (make-seq (sourcev->alist src)
(expand-expr)
(build-void src)))) (build-void src))))
(reverse vals) (reverse var-ids)))) (reverse vals) (reverse var-ids))))
(build-letrec src #t var-ids vars vals tail))))))) (build-letrec src #t var-ids vars vals tail)))))))
@ -1978,17 +1996,14 @@
(define (strip x) (define (strip x)
(define (annotate proc datum) (define (annotate proc datum)
(let ((src (proc x))) (decorate-source datum (proc x)))
(when (and (pair? src) (supports-source-properties? datum))
(set-source-properties! datum src))
datum))
(cond (cond
((syntax? x) ((syntax? x)
(annotate syntax-source (strip (syntax-expression x)))) (annotate syntax-sourcev (strip (syntax-expression x))))
((pair? x) ((pair? x)
(annotate source-properties (cons (strip (car x)) (strip (cdr x))))) (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x)))))
((vector? x) ((vector? x)
(annotate source-properties (list->vector (strip (vector->list x))))) (annotate datum-sourcev (list->vector (strip (vector->list x)))))
(else x))) (else x)))
;; lexical variables ;; lexical variables
@ -2315,7 +2330,7 @@
(make-syntax '#{ $sc-ellipsis }# (make-syntax '#{ $sc-ellipsis }#
(syntax-wrap #'dots) (syntax-wrap #'dots)
(syntax-module #'dots) (syntax-module #'dots)
(syntax-source #'dots))))) (syntax-sourcev #'dots)))))
(let ((ids (list id)) (let ((ids (list id))
(labels (list (gen-label))) (labels (list (gen-label)))
(bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
@ -2473,7 +2488,7 @@
(syntax-wrap x) (syntax-wrap x)
;; hither the remodulation ;; hither the remodulation
mod mod
(syntax-source x))) (syntax-sourcev x)))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1))) (do ((i 0 (fx+ i 1)))
@ -2739,9 +2754,11 @@
(syntax-module id) (syntax-module id)
#f) #f)
(cond (cond
((not source) (source-properties datum)) ((not source) (datum-sourcev datum))
((and (list? source) (and-map pair? source)) source) ((and (list? source) (and-map pair? source)) source)
(else (syntax-source source)))))) ((and (vector? source) (= 3 (vector-length source)))
source)
(else (syntax-sourcev source))))))
(set! syntax->datum (set! syntax->datum
;; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially