summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax-pp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax-pp.scm')
-rw-r--r--module/ice-9/psyntax-pp.scm153
1 files changed, 61 insertions, 92 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index d5b428d8c..687d1f6cf 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -5,8 +5,7 @@
(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-sourcev (module-ref (current-module) 'syntax-sourcev)))
+ (syntax-module (module-ref (current-module) 'syntax-module)))
(letrec* ((make-void (lambda (src) (make-struct/simple (vector-ref %expanded-vtables 0) src)))
(make-const (lambda (src exp) (make-struct/simple (vector-ref %expanded-vtables 1) src exp)))
(make-primitive-ref (lambda (src name) (make-struct/simple (vector-ref %expanded-vtables 2) src name)))
@@ -177,11 +176,7 @@
(if (null? v) body-exp (fk)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(no-source #f)
- (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-sourcev x) (datum-sourcev x))))
+ (source-annotation (lambda (x) (and (syntax? x) (syntax-source x))))
(binding-type (lambda (x) (car x)))
(binding-value (lambda (x) (cdr x)))
(null-env '())
@@ -667,8 +662,7 @@
(if (null? v) #f (fk)))))
(wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
(wrap-syntax
- (lambda (x w defmod)
- (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-sourcev x))))
+ (lambda (x w defmod) (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-source x))))
(source-wrap
(lambda (x w s defmod)
(cond
@@ -1141,11 +1135,11 @@
(source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-c45 transformer-environment)
- (t-680b775fb37a463-c46 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-c30 transformer-environment)
+ (t-680b775fb37a463-c31 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-c45
- t-680b775fb37a463-c46
+ t-680b775fb37a463-c30
+ t-680b775fb37a463-c31
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1676,11 +1670,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-ece
- tmp-680b775fb37a463-ecd
- tmp-680b775fb37a463-ecc)
- (cons tmp-680b775fb37a463-ecc
- (cons tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece)))
+ (map (lambda (tmp-680b775fb37a463-eb9
+ tmp-680b775fb37a463-eb8
+ tmp-680b775fb37a463-eb7)
+ (cons tmp-680b775fb37a463-eb7
+ (cons tmp-680b775fb37a463-eb8 tmp-680b775fb37a463-eb9)))
e2*
e1*
args*)))
@@ -1691,17 +1685,11 @@
tmp-1)
(syntax-violation #f "source expression failed to match any pattern" tmp))))))))
(strip (lambda (x)
- (letrec* ((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))))
- ((pair? x) (cons (strip (car x)) (strip (cdr x))))
- ((vector? x) (list->vector (strip (vector->list x))))
- (else x)))))
+ (cond
+ ((syntax? x) (strip (syntax-expression x)))
+ ((pair? x) (cons (strip (car x)) (strip (cdr x))))
+ ((vector? x) (list->vector (strip (vector->list x))))
+ (else x))))
(gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id))))
(lambda-var-list
(lambda (vars)
@@ -1995,11 +1983,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-117f
- tmp-680b775fb37a463-117e
- tmp-680b775fb37a463-117d)
- (cons tmp-680b775fb37a463-117d
- (cons tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f)))
+ (map (lambda (tmp-680b775fb37a463-115f
+ tmp-680b775fb37a463-115e
+ tmp-680b775fb37a463-115d)
+ (cons tmp-680b775fb37a463-115d
+ (cons tmp-680b775fb37a463-115e tmp-680b775fb37a463-115f)))
e2
e1
args)))
@@ -2016,7 +2004,7 @@
'#{ $sc-ellipsis }#
(syntax-wrap dots)
(syntax-module dots)
- (syntax-sourcev dots)))))
+ (syntax-source dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
@@ -2166,7 +2154,7 @@
(remodulate (syntax-expression x) mod)
(syntax-wrap x)
mod
- (syntax-sourcev x)))
+ (syntax-source x)))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0))
@@ -2449,27 +2437,7 @@
(global-extend 'core 'syntax-case expand-syntax-case)
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (letrec* ((unstrip
- (lambda (x)
- (letrec* ((annotate
- (lambda (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)))))))
+ (expand-top-sequence (list x) null-env top-wrap #f m esew (cons 'hygiene (module-name (current-module))))))
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
(lambda* (id datum #:key (source #f #:source))
@@ -2482,10 +2450,10 @@
(if id (syntax-wrap id) empty-wrap)
(and id (syntax-module id))
(cond
- ((not source) (props->sourcev (source-properties datum)))
+ ((not source) #f)
((and (list? source) (and-map pair? source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) source)
- (else (syntax-sourcev source)))))))
+ (else (syntax-source source)))))))
(set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries
(lambda (ls)
@@ -2822,9 +2790,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-145d tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b)
- (list (cons tmp-680b775fb37a463-145b tmp-680b775fb37a463-145c)
- tmp-680b775fb37a463-145d))
+ (map (lambda (tmp-680b775fb37a463-143d tmp-680b775fb37a463-143c tmp-680b775fb37a463-143b)
+ (list (cons tmp-680b775fb37a463-143b tmp-680b775fb37a463-143c)
+ tmp-680b775fb37a463-143d))
template
pattern
keyword)))
@@ -2852,11 +2820,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-148f
- tmp-680b775fb37a463-148e
- tmp-680b775fb37a463-148d)
- (list (cons tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e)
- tmp-680b775fb37a463-148f))
+ (map (lambda (tmp-680b775fb37a463-146f
+ tmp-680b775fb37a463-146e
+ tmp-680b775fb37a463-146d)
+ (list (cons tmp-680b775fb37a463-146d tmp-680b775fb37a463-146e)
+ tmp-680b775fb37a463-146f))
template
pattern
keyword)))
@@ -2872,11 +2840,11 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-14ae
- tmp-680b775fb37a463-14ad
- tmp-680b775fb37a463-14ac)
- (list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad)
- tmp-680b775fb37a463-14ae))
+ (map (lambda (tmp-680b775fb37a463-148e
+ tmp-680b775fb37a463-148d
+ tmp-680b775fb37a463-148c)
+ (list (cons tmp-680b775fb37a463-148c tmp-680b775fb37a463-148d)
+ tmp-680b775fb37a463-148e))
template
pattern
keyword)))
@@ -3004,9 +2972,9 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda (tmp-680b775fb37a463-155b)
+ (map (lambda (tmp-680b775fb37a463-153b)
(list "value"
- tmp-680b775fb37a463-155b))
+ tmp-680b775fb37a463-153b))
p)
(quasi q lev))
(quasicons
@@ -3091,8 +3059,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda (tmp-680b775fb37a463-157b)
- (list "value" tmp-680b775fb37a463-157b))
+ (map (lambda (tmp-680b775fb37a463-155b)
+ (list "value" tmp-680b775fb37a463-155b))
p)
(vquasi q lev))
(quasicons
@@ -3174,8 +3142,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-15c4)
- (cons "vector" t-680b775fb37a463-15c4))
+ (apply (lambda (t-680b775fb37a463-15a4)
+ (cons "vector" t-680b775fb37a463-15a4))
tmp)
(syntax-violation
#f
@@ -3185,8 +3153,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-15d0)
- (list "quote" tmp-680b775fb37a463-15d0))
+ (k (map (lambda (tmp-680b775fb37a463-15b0)
+ (list "quote" tmp-680b775fb37a463-15b0))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@@ -3197,8 +3165,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-15df tmp))
- (list "list->vector" t-680b775fb37a463-15df)))))))))))))))))
+ (let ((t-680b775fb37a463-15bf tmp))
+ (list "list->vector" t-680b775fb37a463-15bf)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3210,9 +3178,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-15ee)
+ (apply (lambda (t-680b775fb37a463-15ce)
(cons (make-syntax 'list '((top)) '(hygiene guile))
- t-680b775fb37a463-15ee))
+ t-680b775fb37a463-15ce))
tmp)
(syntax-violation
#f
@@ -3228,13 +3196,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp
- (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
+ (apply (lambda (t-680b775fb37a463-15e2
+ t-680b775fb37a463-15e1)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
- t-680b775fb37a463-1
- t-680b775fb37a463))
+ t-680b775fb37a463-15e2
+ t-680b775fb37a463-15e1))
tmp)
(syntax-violation
#f
@@ -3247,12 +3216,12 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-160e)
+ (apply (lambda (t-680b775fb37a463-15ee)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
- t-680b775fb37a463-160e))
+ t-680b775fb37a463-15ee))
tmp)
(syntax-violation
#f
@@ -3265,12 +3234,12 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-161a)
+ (apply (lambda (t-680b775fb37a463-15fa)
(cons (make-syntax
'vector
'((top))
'(hygiene guile))
- t-680b775fb37a463-161a))
+ t-680b775fb37a463-15fa))
tmp)
(syntax-violation
#f
@@ -3305,7 +3274,7 @@
(define call-with-include-port
(let ((syntax-dirname
(lambda (stx)
- (letrec* ((src (syntax-source stx)) (filename (if src (assq-ref src 'filename) #f)))
+ (letrec* ((src (syntax-source stx)) (filename (if src (vector-ref src 0) #f)))
(if (string? filename) (dirname filename) #f)))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname))
"Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory. Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames."