wingo pushed a commit to branch master
in repository guile.
commit 18c09f0492069314a3ff954f907bd4e030c67f59
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Thu Feb 25 16:06:43 2021 +0100
Psyntax uses sourcev internally
* 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.
---
module/ice-9/psyntax-pp.scm | 255 ++++++++++++++++++++++++++------------------
module/ice-9/psyntax.scm | 115 +++++++++++---------
2 files changed, 220 insertions(+), 150 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 05d7cdb..1e30a98 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -5,7 +5,8 @@
(make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression))
(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*
((make-void
(lambda (src)
@@ -126,10 +127,23 @@
(session-id
(let ((v (module-variable (current-module) 'syntax-session-id)))
(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
(lambda (e s)
(if (and s (supports-source-properties? e))
- (set-source-properties! e s))
+ (set-source-properties! e (sourcev->alist s)))
e))
(maybe-name-value!
(lambda (name val)
@@ -137,19 +151,24 @@
(let ((meta (lambda-meta val)))
(if (not (assq '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
- (lambda (source fun-exp arg-exps)
- (make-call source fun-exp arg-exps)))
+ (lambda (sourcev fun-exp arg-exps)
+ (make-call (sourcev->alist sourcev) fun-exp arg-exps)))
(build-conditional
- (lambda (source test-exp then-exp else-exp)
- (make-conditional source test-exp then-exp else-exp)))
+ (lambda (sourcev test-exp then-exp else-exp)
+ (make-conditional
+ (sourcev->alist sourcev)
+ test-exp
+ then-exp
+ else-exp)))
(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
- (lambda (source name var exp)
+ (lambda (sourcev name var exp)
(maybe-name-value! name exp)
- (make-lexical-set source name var exp)))
+ (make-lexical-set (sourcev->alist sourcev) name var exp)))
(analyze-variable
(lambda (mod var modref-cont bare-cont)
(if (not mod)
@@ -171,49 +190,72 @@
(syntax-violation #f "primitive not in operator
position" var))
(else (syntax-violation #f "bad module kind" var
mod))))))))
(build-global-reference
- (lambda (source var mod)
+ (lambda (sourcev var mod)
(analyze-variable
mod
var
- (lambda (mod var public?) (make-module-ref source mod var public?))
- (lambda (mod var) (make-toplevel-ref source mod var)))))
+ (lambda (mod var public?)
+ (make-module-ref (sourcev->alist sourcev) mod var public?))
+ (lambda (mod var)
+ (make-toplevel-ref (sourcev->alist sourcev) mod var)))))
(build-global-assignment
- (lambda (source var exp mod)
+ (lambda (sourcev var exp mod)
(maybe-name-value! var exp)
(analyze-variable
mod
var
(lambda (mod var public?)
- (make-module-set source mod var public? exp))
- (lambda (mod var) (make-toplevel-set source mod var exp)))))
+ (make-module-set (sourcev->alist sourcev) mod var public? exp))
+ (lambda (mod var)
+ (make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
(build-global-definition
- (lambda (source mod var exp)
+ (lambda (sourcev mod 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
(lambda (src req rest vars meta exp)
(make-lambda
- src
+ (sourcev->alist src)
meta
(make-lambda-case src req #f rest #f '() vars exp #f))))
(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
(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
- (lambda (src name args) (make-primcall src name args)))
- (build-primref (lambda (src name) (make-primitive-ref src name)))
- (build-data (lambda (src exp) (make-const src exp)))
+ (lambda (src name args)
+ (make-primcall (sourcev->alist src) name args)))
+ (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
(lambda (src exps)
(if (null? (cdr 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
(lambda (src ids vars val-exps body-exp)
(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
(lambda (src ids vars val-exps body-exp)
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr
ids)))
@@ -221,7 +263,7 @@
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
(make-letrec
- src
+ (sourcev->alist src)
#f
(list f-name)
(list f)
@@ -233,12 +275,23 @@
body-exp
(begin
(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
- (lambda (x)
- (if (syntax? x)
- (syntax-source x)
- (let ((props (source-properties x))) (and (pair? props) props)))))
+ (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
(extend-env
(lambda (labels bindings r)
(if (null? labels)
@@ -529,13 +582,13 @@
(syntax-expression x)
w
(or (syntax-module x) defmod)
- (syntax-source x))))
+ (syntax-sourcev x))))
(source-wrap
(lambda (x w s defmod)
(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))
((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
(lambda (body r w s mod)
(build-sequence
@@ -990,11 +1043,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-db4 transformer-environment)
- (t-680b775fb37a463-db5 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-dd8 transformer-environment)
+ (t-680b775fb37a463-dd9 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-db4
- t-680b775fb37a463-db5
+ t-680b775fb37a463-dd8
+ t-680b775fb37a463-dd9
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1030,13 +1083,15 @@
(lp (cdr var-ids)
(cdr vars)
(cdr vals)
- (make-seq src ((car vals)) tail)))
+ (make-seq (sourcev->alist src) ((car vals))
tail)))
(else
(let ((var-ids
(map (lambda (id) (if id (syntax->datum
id) '_)) (reverse var-ids)))
(vars (map (lambda (var) (or var
(gen-label))) (reverse vars)))
(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 var-ids))))
(build-letrec src #t var-ids vars vals
tail)))))))
@@ -1561,9 +1616,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463
- (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda
(tmp-680b775fb37a463-104d
+
tmp-680b775fb37a463-104c
+
tmp-680b775fb37a463-104b)
+ (cons tmp-680b775fb37a463-104b
+ (cons
tmp-680b775fb37a463-104c tmp-680b775fb37a463-104d)))
e2*
e1*
args*)))
@@ -1578,17 +1635,12 @@
tmp))))))))
(strip (lambda (x)
(letrec*
- ((annotate
- (lambda (proc datum)
- (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))))
+ ((annotate (lambda (proc datum) (decorate-source datum (proc
x)))))
+ (cond ((syntax? x) (annotate syntax-sourcev (strip
(syntax-expression 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)
- (annotate source-properties (list->vector (strip
(vector->list x)))))
+ (annotate datum-sourcev (list->vector (strip
(vector->list x)))))
(else x)))))
(gen-var
(lambda (id)
@@ -1871,11 +1923,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-6a4
- tmp-680b775fb37a463-6a3
- tmp-680b775fb37a463-6a2)
- (cons tmp-680b775fb37a463-6a2
- (cons tmp-680b775fb37a463-6a3
tmp-680b775fb37a463-6a4)))
+ (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)))
@@ -1887,11 +1939,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-6ba
- tmp-680b775fb37a463-6b9
- tmp-680b775fb37a463-6b8)
- (cons tmp-680b775fb37a463-6b8
- (cons tmp-680b775fb37a463-6b9
tmp-680b775fb37a463-6ba)))
+ (map (lambda (tmp-680b775fb37a463-6c8
+ tmp-680b775fb37a463-6c7
+ tmp-680b775fb37a463-6c6)
+ (cons tmp-680b775fb37a463-6c6
+ (cons tmp-680b775fb37a463-6c7
tmp-680b775fb37a463-6c8)))
e2
e1
args)))
@@ -1914,11 +1966,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-66e
- tmp-680b775fb37a463-66d
- tmp-680b775fb37a463-66c)
- (cons tmp-680b775fb37a463-66c
- (cons tmp-680b775fb37a463-66d
tmp-680b775fb37a463-66e)))
+ (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)))
@@ -1951,7 +2003,7 @@
'#{ $sc-ellipsis }#
(syntax-wrap dots)
(syntax-module dots)
- (syntax-source dots)))))
+ (syntax-sourcev dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots
w s mod)))))
@@ -2134,7 +2186,7 @@
(remodulate (syntax-expression x) mod)
(syntax-wrap x)
mod
- (syntax-source x)))
+ (syntax-sourcev x)))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0))
@@ -2437,9 +2489,10 @@
datum
(if id (syntax-wrap 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)
- (else (syntax-source source))))))
+ ((and (vector? source) (= 3 (vector-length source))) source)
+ (else (syntax-sourcev source))))))
(set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries
(lambda (ls)
@@ -2862,9 +2915,9 @@
#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-1
tmp-680b775fb37a463 tmp-680b775fb37a463-117f)
+ (list (cons tmp-680b775fb37a463-117f
tmp-680b775fb37a463)
+ tmp-680b775fb37a463-1))
template
pattern
keyword)))
@@ -2879,11 +2932,9 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-117b
- tmp-680b775fb37a463-117a
- tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-117a)
- tmp-680b775fb37a463-117b))
+ (map (lambda (tmp-680b775fb37a463-119a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-119a))
template
pattern
keyword)))
@@ -2899,9 +2950,11 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-119a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-119a))
+ (map (lambda (tmp-680b775fb37a463-11b9
+ tmp-680b775fb37a463-11b8
+ tmp-680b775fb37a463-11b7)
+ (list (cons
tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8)
+ tmp-680b775fb37a463-11b9))
template
pattern
keyword)))
@@ -3049,8 +3102,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-124a)
- (list
"value" tmp-680b775fb37a463-124a))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list
"value" tmp-680b775fb37a463))
p)
(quasi q lev))
(quasicons
@@ -3073,8 +3126,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-124f)
- (list
"value" tmp-680b775fb37a463-124f))
+ (map (lambda
(tmp-680b775fb37a463-126e)
+ (list
"value" tmp-680b775fb37a463-126e))
p)
(quasi q lev))
(quasicons
@@ -3127,8 +3180,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-126a)
- (list "value"
tmp-680b775fb37a463-126a))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list "value"
tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
@@ -3218,8 +3271,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-12b3)
- (cons "vector"
t-680b775fb37a463-12b3))
+ (apply (lambda (t-680b775fb37a463-12d2)
+ (cons "vector"
t-680b775fb37a463-12d2))
tmp)
(syntax-violation
#f
@@ -3229,8 +3282,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-12bf)
- (list "quote"
tmp-680b775fb37a463-12bf))
+ (k (map (lambda (tmp-680b775fb37a463-12de)
+ (list "quote"
tmp-680b775fb37a463-12de))
y)))
tmp-1)
(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)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-12ce tmp))
- (list "list->vector"
t-680b775fb37a463-12ce)))))))))))))))))
+ (let ((t-680b775fb37a463-12ed tmp))
+ (list "list->vector"
t-680b775fb37a463-12ed)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3255,9 +3308,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12dd)
+ (apply (lambda
(t-680b775fb37a463-12fc)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12dd))
+
t-680b775fb37a463-12fc))
tmp)
(syntax-violation
#f
@@ -3273,10 +3326,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-12f1 t-680b775fb37a463-12f0)
+ (apply (lambda
(t-680b775fb37a463 t-680b775fb37a463-130f)
(list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-12f1
-
t-680b775fb37a463-12f0))
+
t-680b775fb37a463
+
t-680b775fb37a463-130f))
tmp)
(syntax-violation
#f
@@ -3289,9 +3342,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12fd)
+ (apply (lambda
(t-680b775fb37a463-131c)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12fd))
+
t-680b775fb37a463-131c))
tmp)
(syntax-violation
#f
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6962d62..57ac6a6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -142,7 +142,8 @@
(make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression))
(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
(lambda (x)
@@ -267,9 +268,19 @@
(lambda ()
((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)
- (if (and s (supports-source-properties? e))
- (set-source-properties! e s))
+ (when (and s (supports-source-properties? e))
+ (set-source-properties! e (sourcev->alist s)))
e)
(define (maybe-name-value! name val)
@@ -280,25 +291,25 @@
;; output constructors
(define build-void
- (lambda (source)
- (make-void source)))
+ (lambda (sourcev)
+ (make-void (sourcev->alist sourcev))))
(define build-call
- (lambda (source fun-exp arg-exps)
- (make-call source fun-exp arg-exps)))
+ (lambda (sourcev fun-exp arg-exps)
+ (make-call (sourcev->alist sourcev) fun-exp arg-exps)))
(define build-conditional
- (lambda (source test-exp then-exp else-exp)
- (make-conditional source test-exp then-exp else-exp)))
+ (lambda (sourcev test-exp then-exp else-exp)
+ (make-conditional (sourcev->alist sourcev) test-exp then-exp
else-exp)))
(define 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)))
(define build-lexical-assignment
- (lambda (source name var exp)
+ (lambda (sourcev name var 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)
(if (not mod)
@@ -320,32 +331,32 @@
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
- (lambda (source var mod)
+ (lambda (sourcev var mod)
(analyze-variable
mod var
(lambda (mod var public?)
- (make-module-ref source mod var public?))
+ (make-module-ref (sourcev->alist sourcev) mod var public?))
(lambda (mod var)
- (make-toplevel-ref source mod var)))))
+ (make-toplevel-ref (sourcev->alist sourcev) mod var)))))
(define build-global-assignment
- (lambda (source var exp mod)
+ (lambda (sourcev var exp mod)
(maybe-name-value! var exp)
(analyze-variable
mod var
(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)))))
+ (make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
(define build-global-definition
- (lambda (source mod var exp)
+ (lambda (sourcev mod 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
(lambda (src req rest vars meta exp)
- (make-lambda src
+ (make-lambda (sourcev->alist src)
meta
;; hah, a case in which kwargs would be nice.
(make-lambda-case
@@ -354,7 +365,7 @@
(define build-case-lambda
(lambda (src meta body)
- (make-lambda src meta body)))
+ (make-lambda (sourcev->alist src) meta body)))
(define build-lambda-case
;; req := (name ...)
@@ -368,31 +379,31 @@
;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f
(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
(lambda (src name args)
- (make-primcall src name args)))
+ (make-primcall (sourcev->alist src) name args)))
(define build-primref
(lambda (src name)
- (make-primitive-ref src name)))
+ (make-primitive-ref (sourcev->alist src) name)))
(define (build-data src exp)
- (make-const src exp))
+ (make-const (sourcev->alist src) exp))
(define build-sequence
(lambda (src exps)
(if (null? (cdr 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
(lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps)
(if (null? vars)
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
(lambda (src ids vars val-exps body-exp)
@@ -404,7 +415,7 @@
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
(make-letrec
- src #f
+ (sourcev->alist src) #f
(list f-name) (list f) (list proc)
(build-call src (build-lexical-reference 'fun src f-name f)
val-exps))))))
@@ -415,7 +426,7 @@
body-exp
(begin
(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)
@@ -425,12 +436,18 @@
(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
(lambda (x)
(if (syntax? x)
- (syntax-source x)
- (let ((props (source-properties x)))
- (and (pair? props) props)))))
+ (syntax-sourcev x)
+ (datum-sourcev x))))
(define-syntax-rule (arg-check pred? e who)
(let ((x e))
@@ -1016,7 +1033,7 @@
(make-syntax (syntax-expression x)
w
(or (syntax-module x) defmod)
- (syntax-source x)))
+ (syntax-sourcev x)))
(define (source-wrap x w s defmod)
(cond
((and (null? (wrap-marks w))
@@ -1026,7 +1043,7 @@
x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((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
@@ -1605,7 +1622,7 @@
((null? var-ids) tail)
((not (car var-ids))
(lp (cdr var-ids) (cdr vars) (cdr vals)
- (make-seq src ((car vals)) tail)))
+ (make-seq (sourcev->alist src) ((car vals)) tail)))
(else
(let ((var-ids (map (lambda (id)
(if id (syntax->datum id) '_))
@@ -1615,7 +1632,8 @@
(vals (map (lambda (expand-expr id)
(if id
(expand-expr)
- (make-seq src (expand-expr)
+ (make-seq (sourcev->alist src)
+ (expand-expr)
(build-void src))))
(reverse vals) (reverse var-ids))))
(build-letrec src #t var-ids vars vals tail)))))))
@@ -1978,17 +1996,14 @@
(define (strip x)
(define (annotate proc datum)
- (let ((src (proc x)))
- (when (and (pair? src) (supports-source-properties? datum))
- (set-source-properties! datum src))
- datum))
+ (decorate-source datum (proc x)))
(cond
((syntax? x)
- (annotate syntax-source (strip (syntax-expression x))))
+ (annotate syntax-sourcev (strip (syntax-expression 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)
- (annotate source-properties (list->vector (strip (vector->list x)))))
+ (annotate datum-sourcev (list->vector (strip (vector->list x)))))
(else x)))
;; lexical variables
@@ -2315,7 +2330,7 @@
(make-syntax '#{ $sc-ellipsis }#
(syntax-wrap #'dots)
(syntax-module #'dots)
- (syntax-source #'dots)))))
+ (syntax-sourcev #'dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (make-binding 'ellipsis
(source-wrap #'dots w s mod)))))
@@ -2473,7 +2488,7 @@
(syntax-wrap x)
;; hither the remodulation
mod
- (syntax-source x)))
+ (syntax-sourcev x)))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector
n)))
(do ((i 0 (fx+ i 1)))
@@ -2739,9 +2754,11 @@
(syntax-module id)
#f)
(cond
- ((not source) (source-properties datum))
+ ((not source) (datum-sourcev datum))
((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
;; accepts any object, since syntax objects may consist partially
