mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Remove top-marked? optimization from psyntax

Browse source 
* module/ice-9/psyntax.scm (strip): It used to be that terms in the
source program could have a "top" mark, and when stripping marks we'd
stop recursing when we see an expression with the top mark.  This had
the good effect that source programs could contain quoted syntax
objects, or quoted objects with shared structure -- in theory anyway.
In practice the compiler didn't support objects with shared structure.
Anyway when we switch to "read-syntax", quoted expressions can contain
syntax objects introduced by the reader, which naturally we would want
to strip away in a (quote FOO) form.  Therefore we remove the
top-marked? optimization.
This commit is contained in:
Andy Wingo 2021-02-24 16:01:02 +01:00
parent 1711608f15
commit e054504fd4
2 changed files with 134 additions and 191 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -523,15 +523,17 @@
(and (not (null? list)) (and (not (null? list))
(or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
(wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
(wrap-syntax
(lambda (x w)
(make-syntax
(syntax-expression x)
w
(syntax-module x)
(syntax-source x))))
(source-wrap (source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(cond ((and (null? (car w)) (null? (cdr w)) (not s)) x) (cond ((and (null? (car w)) (null? (cdr w)) (not s)) x)
((syntax? x) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
(make-syntax
(syntax-expression x)
(join-wraps w (syntax-wrap x))
(syntax-module x)
(syntax-source x)))
((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 (source-properties x)))))))
(expand-sequence (expand-sequence
@ -712,7 +714,7 @@
e))))) e)))))
(parse-when-list (parse-when-list
(lambda (e when-list) (lambda (e when-list)
(let ((result (strip when-list '(())))) (let ((result (strip when-list)))
(let lp ((l result)) (let lp ((l result))
(cond ((null? l) result) (cond ((null? l) result)
((memq (car l) '(compile load eval expand)) (lp (cdr l))) ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
@ -885,8 +887,7 @@
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1)))) tmp-1))))
((memv key '(constant)) ((memv key '(constant)) (build-data s (strip e)))
(build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod)) ((memv key '(global)) (build-global-reference s value mod))
((memv key '(call)) ((memv key '(call))
(expand-call (expand (car e) r w mod) e r w s mod)) (expand-call (expand (car e) r w mod) e r w s mod))
@ -965,17 +966,11 @@
(let ((w (syntax-wrap x))) (let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w))) (let ((ms (car w)) (ss (cdr w)))
(if (and (pair? ms) (eq? (car ms) #f)) (if (and (pair? ms) (eq? (car ms) #f))
(make-syntax (wrap-syntax x (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))))
(syntax-expression x) (wrap-syntax
(cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) x
(syntax-module x)
(syntax-source x))
(make-syntax
(decorate-source (syntax-expression x) s)
(cons (cons m ms) (cons (cons m ms)
(if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))))))))
(syntax-module x)
(syntax-source x))))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
(let loop ((i 0)) (let loop ((i 0))
@ -991,11 +986,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-d88 transformer-environment) (let* ((t-680b775fb37a463-d7b transformer-environment)
(t-680b775fb37a463-d89 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-d7c (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-d88 t-680b775fb37a463-d7b
t-680b775fb37a463-d89 t-680b775fb37a463-d7c
(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))
@ -1562,11 +1557,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-ff9 (map (lambda (tmp-680b775fb37a463-fec
tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-feb
tmp-680b775fb37a463-ff7) tmp-680b775fb37a463-fea)
(cons tmp-680b775fb37a463-ff7 (cons tmp-680b775fb37a463-fea
(cons tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-ff9))) (cons tmp-680b775fb37a463-feb tmp-680b775fb37a463-fec)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1579,21 +1574,20 @@
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp)))))))) tmp))))))))
(strip (lambda (x w) (strip (lambda (x)
(if (memq 'top (car w)) (letrec*
x ((annotate
(let f ((x x)) (lambda (proc datum)
(cond ((syntax? x) (strip (syntax-expression x) (syntax-wrap x))) (let ((src (proc x)))
((pair? x) (if (and (pair? src) (supports-source-properties? datum))
(let ((a (f (car x))) (d (f (cdr x)))) (set-source-properties! datum src))
(if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d)))) datum))))
((vector? x) (cond ((syntax? x) (annotate syntax-source (strip (syntax-expression x))))
(let* ((old (vector->list x)) (new (map f old))) ((pair? x)
(let lp ((l1 old) (l2 new)) (annotate source-properties (cons (strip (car x)) (strip (cdr x)))))
(cond ((null? l1) x) ((vector? x)
((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) (annotate source-properties (list->vector (strip (vector->list x)))))
(else (list->vector new)))))) (else x)))))
(else x))))))
(gen-var (gen-var
(lambda (id) (lambda (id)
(let ((id (if (syntax? id) (syntax-expression id) id))) (let ((id (if (syntax? id) (syntax-expression id) id)))
@ -1659,7 +1653,7 @@
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
(if tmp (if tmp
(apply (lambda (e) (build-data s (strip e w))) tmp) (apply (lambda (e) (build-data s (strip e))) tmp)
(syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
(global-extend (global-extend
'core 'core
@ -1872,11 +1866,9 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6a0 (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-68f)
tmp-680b775fb37a463-69f (cons tmp-680b775fb37a463-68f
tmp-680b775fb37a463-69e) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
(cons tmp-680b775fb37a463-69e
(cons tmp-680b775fb37a463-69f tmp-680b775fb37a463-6a0)))
e2 e2
e1 e1
args))) args)))
@ -1888,11 +1880,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-6b6 (map (lambda (tmp-680b775fb37a463-6a7
tmp-680b775fb37a463-6b5 tmp-680b775fb37a463-6a6
tmp-680b775fb37a463-6b4) tmp-680b775fb37a463-6a5)
(cons tmp-680b775fb37a463-6b4 (cons tmp-680b775fb37a463-6a5
(cons tmp-680b775fb37a463-6b5 tmp-680b775fb37a463-6b6))) (cons tmp-680b775fb37a463-6a6 tmp-680b775fb37a463-6a7)))
e2 e2
e1 e1
args))) args)))
@ -1915,9 +1907,9 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-66a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-65b tmp-680b775fb37a463-65a tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-66a))) (cons tmp-680b775fb37a463-65a tmp-680b775fb37a463-65b)))
e2 e2
e1 e1
args))) args)))
@ -1929,9 +1921,9 @@
(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 tmp-680b775fb37a463-67f tmp-680b775fb37a463-67e) (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-66f)
(cons tmp-680b775fb37a463-67e (cons tmp-680b775fb37a463-66f
(cons tmp-680b775fb37a463-67f tmp-680b775fb37a463))) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2 e2
e1 e1
args))) args)))
@ -2285,7 +2277,7 @@
(lambda () (cvt x n ids)) (lambda () (cvt x n ids))
(lambda (p ids) (values (vector 'vector p) ids)))) (lambda (p ids) (values (vector 'vector p) ids))))
tmp-1) tmp-1)
(let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) (let ((x tmp)) (values (vector 'atom (strip p)) ids))))))))))))))))
(cvt pattern 0 '())))) (cvt pattern 0 '()))))
(build-dispatch-call (build-dispatch-call
(lambda (pvars exp y r mod) (lambda (pvars exp y r mod)
@ -2439,7 +2431,7 @@
(cond ((not source) (source-properties datum)) (cond ((not source) (source-properties datum))
((and (list? source) (and-map pair? source)) source) ((and (list? source) (and-map pair? source)) source)
(else (syntax-source source)))))) (else (syntax-source 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)
(let ((x ls)) (let ((x ls))
@ -2477,8 +2469,8 @@
who who
message message
(or (source-annotation subform) (source-annotation form)) (or (source-annotation subform) (source-annotation form))
(strip form '(())) (strip form)
(and subform (strip subform '(())))))) (strip subform))))
(letrec* (letrec*
((%syntax-module ((%syntax-module
(lambda (id) (lambda (id)
@ -2525,11 +2517,7 @@
((memv key '(ellipsis)) ((memv key '(ellipsis))
(values (values
'ellipsis 'ellipsis
(make-syntax (wrap-syntax value (anti-mark (syntax-wrap value)))))
(syntax-expression value)
(anti-mark (syntax-wrap value))
(syntax-module value)
(syntax-source value))))
(else (values 'other #f))))))))))) (else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers (syntax-locally-bound-identifiers
(lambda (id) (lambda (id)
@ -2644,7 +2632,7 @@
(if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
((memv key '(free-id)) ((memv key '(free-id))
(and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r))
((memv key '(vector)) ((memv key '(vector))
(and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
(match (lambda (e p w r mod) (match (lambda (e p w r mod)
@ -2847,9 +2835,11 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-110c
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-110b
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-110a)
(list (cons tmp-680b775fb37a463-110a tmp-680b775fb37a463-110b)
tmp-680b775fb37a463-110c))
template template
pattern pattern
keyword))) keyword)))
@ -2865,11 +2855,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-113f (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-113e (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-113d) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e)
tmp-680b775fb37a463-113f))
template template
pattern pattern
keyword))) keyword)))
@ -2884,9 +2872,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-113e
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-113d
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-113c)
(list (cons tmp-680b775fb37a463-113c tmp-680b775fb37a463-113d)
tmp-680b775fb37a463-113e))
template template
pattern pattern
keyword))) keyword)))
@ -2902,9 +2892,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-115d
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-115c
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-115b)
(list (cons tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c)
tmp-680b775fb37a463-115d))
template template
pattern pattern
keyword))) keyword)))
@ -3052,8 +3044,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-120d)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-120d))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3076,8 +3068,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-122c) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-122c)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3130,8 +3122,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-122d)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-122d))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3231,8 +3223,7 @@
(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-129c) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-129c))
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))))
@ -3243,8 +3234,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-12ab tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-12ab))))))))))))))))) (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))))
@ -3257,9 +3248,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-12ba) (apply (lambda (t-680b775fb37a463-12a0)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12ba)) t-680b775fb37a463-12a0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3275,10 +3266,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-12ce t-680b775fb37a463-12cd) (apply (lambda (t-680b775fb37a463-12b4 t-680b775fb37a463-12b3)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12ce t-680b775fb37a463-12b4
t-680b775fb37a463-12cd)) t-680b775fb37a463-12b3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3291,9 +3282,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-12da) (apply (lambda (t-680b775fb37a463-12c0)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12da)) t-680b775fb37a463-12c0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3306,9 +3297,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-12e6) (apply (lambda (t-680b775fb37a463-12cc)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12e6)) t-680b775fb37a463-12cc))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3319,9 +3310,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12f2 tmp)) (let ((t-680b775fb37a463-12d8 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12f2)))) t-680b775fb37a463-12d8))))
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

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

@ -98,33 +98,6 @@
;;; compiled. In this way, psyntax bootstraps off of an expanded ;;; compiled. In this way, psyntax bootstraps off of an expanded
;;; version of itself. ;;; version of itself.
;;; This implementation of the expander sometimes uses syntactic
;;; abstractions when procedural abstractions would suffice. For
;;; example, we define top-wrap and top-marked? as
;;;
;;; (define-syntax top-wrap (identifier-syntax '((top))))
;;; (define-syntax top-marked?
;;; (syntax-rules ()
;;; ((_ w) (memq 'top (wrap-marks w)))))
;;;
;;; rather than
;;;
;;; (define top-wrap '((top)))
;;; (define top-marked?
;;; (lambda (w) (memq 'top (wrap-marks w))))
;;;
;;; On the other hand, we don't do this consistently; we define
;;; make-wrap, wrap-marks, and wrap-subst simply as
;;;
;;; (define make-wrap cons)
;;; (define wrap-marks car)
;;; (define wrap-subst cdr)
;;;
;;; In Chez Scheme, the syntactic and procedural forms of these
;;; abstractions are equivalent, since the optimizer consistently
;;; integrates constants and small procedures. This will be true of
;;; Guile as well, once we implement a proper inliner.
;;; Implementation notes: ;;; Implementation notes:
@ -626,12 +599,8 @@
(define-structure (ribcage symnames marks labels)) (define-structure (ribcage symnames marks labels))
(define-syntax empty-wrap (identifier-syntax '(()))) (define-syntax empty-wrap (identifier-syntax '(())))
(define-syntax top-wrap (identifier-syntax '((top)))) (define-syntax top-wrap (identifier-syntax '((top))))
(define-syntax-rule (top-marked? w)
(memq 'top (wrap-marks w)))
;; Marks must be comparable with "eq?" and distinct from pairs and ;; Marks must be comparable with "eq?" and distinct from pairs and
;; the symbol top. We do not use integers so that marks will remain ;; the symbol top. We do not use integers so that marks will remain
;; unique even across file compiles. ;; unique even across file compiles.
@ -1043,15 +1012,16 @@
(lambda (x w defmod) (lambda (x w defmod)
(source-wrap x w #f defmod))) (source-wrap x w #f defmod)))
(define (wrap-syntax x w)
(make-syntax (syntax-expression x)
w
(syntax-module x)
(syntax-source x)))
(define source-wrap (define source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(cond (cond
((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not s)) x) ((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not s)) x)
((syntax? x) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
(make-syntax (syntax-expression x)
(join-wraps w (syntax-wrap x))
(syntax-module x)
(syntax-source x)))
((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 (source-properties x)))))))
@ -1265,7 +1235,7 @@
;; we twingle the definition of eval-when to the bindings of ;; we twingle the definition of eval-when to the bindings of
;; eval, load, expand, and compile, which is totally unintended. ;; eval, load, expand, and compile, which is totally unintended.
;; So do a symbolic match instead. ;; So do a symbolic match instead.
(let ((result (strip when-list empty-wrap))) (let ((result (strip when-list)))
(let lp ((l result)) (let lp ((l result))
(if (null? l) (if (null? l)
result result
@ -1451,7 +1421,7 @@
value value
(map (lambda (e) (expand e r w mod)) (map (lambda (e) (expand e r w mod))
#'(e ...)))))) #'(e ...))))))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) ((constant) (build-data s (strip e)))
((global) (build-global-reference s value mod)) ((global) (build-global-reference s value mod))
((call) (expand-call (expand (car e) r w mod) e r w s mod)) ((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form) ((begin-form)
@ -1535,20 +1505,19 @@
(let ((ms (wrap-marks w)) (ss (wrap-subst w))) (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) the-anti-mark)) (if (and (pair? ms) (eq? (car ms) the-anti-mark))
;; output is from original text ;; output is from original text
(make-syntax (wrap-syntax
(syntax-expression x) x
(make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) (make-wrap (cdr ms)
(syntax-module x) (if rib
(syntax-source x)) (cons rib (cdr ss))
(cdr ss))))
;; output introduced by macro ;; output introduced by macro
(make-syntax (wrap-syntax
(decorate-source (syntax-expression x) s) x
(make-wrap (cons m ms) (make-wrap (cons m ms)
(if rib (if rib
(cons rib (cons 'shift ss)) (cons rib (cons 'shift ss))
(cons 'shift ss))) (cons 'shift ss))))))))
(syntax-module x)
(syntax-source x))))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (let* ((n (vector-length x))
@ -2000,36 +1969,22 @@
;; data ;; data
;; strips syntax objects down to top-wrap ;; strips syntax objects, recursively.
;;
;; since only the head of a list is annotated by the reader, not each pair
;; in the spine, we also check for pairs whose cars are annotated in case
;; we've been passed the cdr of an annotated list
(define strip (define (strip x)
(lambda (x w) (define (annotate proc datum)
(if (top-marked? w) (let ((src (proc x)))
x (when (and (pair? src) (supports-source-properties? datum))
(let f ((x x)) (set-source-properties! datum src))
(cond datum))
((syntax? x) (cond
(strip (syntax-expression x) (syntax-wrap x))) ((syntax? x)
((pair? x) (annotate syntax-source (strip (syntax-expression x))))
(let ((a (f (car x))) (d (f (cdr x)))) ((pair? x)
(if (and (eq? a (car x)) (eq? d (cdr x))) (annotate source-properties (cons (strip (car x)) (strip (cdr x)))))
x ((vector? x)
(cons a d)))) (annotate source-properties (list->vector (strip (vector->list x)))))
((vector? x) (else x)))
(let ((old (vector->list x)))
(let ((new (map f old)))
;; inlined and-map with two args
(let lp ((l1 old) (l2 new))
(if (null? l1)
x
(if (eq? (car l1) (car l2))
(lp (cdr l1) (cdr l2))
(list->vector new)))))))
(else x))))))
;; lexical variables ;; lexical variables
@ -2102,7 +2057,7 @@
(global-extend 'core 'quote (global-extend 'core 'quote
(lambda (e r w s mod) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ e) (build-data s (strip #'e w))) ((_ e) (build-data s (strip #'e)))
(_ (syntax-violation 'quote "bad syntax" (_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
@ -2641,7 +2596,7 @@
(call-with-values (call-with-values
(lambda () (cvt (syntax (x ...)) n ids)) (lambda () (cvt (syntax (x ...)) n ids))
(lambda (p ids) (values (vector 'vector p) ids)))) (lambda (p ids) (values (vector 'vector p) ids))))
(x (values (vector 'atom (strip p empty-wrap)) ids)))))) (x (values (vector 'atom (strip p)) ids))))))
(cvt pattern 0 '()))) (cvt pattern 0 '())))
(define build-dispatch-call (define build-dispatch-call
@ -2786,7 +2741,7 @@
;; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially
;; or entirely of unwrapped, nonsymbolic data ;; or entirely of unwrapped, nonsymbolic data
(lambda (x) (lambda (x)
(strip x empty-wrap))) (strip x)))
(set! generate-temporaries (set! generate-temporaries
(lambda (ls) (lambda (ls)
@ -2816,8 +2771,8 @@
(throw 'syntax-error who message (throw 'syntax-error who message
(or (source-annotation subform) (or (source-annotation subform)
(source-annotation form)) (source-annotation form))
(strip form empty-wrap) (strip form)
(and subform (strip subform empty-wrap))))) (strip subform))))
(let () (let ()
(define (%syntax-module id) (define (%syntax-module id)
@ -2857,10 +2812,7 @@
(values 'global (cons value (cdr mod))))) (values 'global (cons value (cdr mod)))))
((ellipsis) ((ellipsis)
(values 'ellipsis (values 'ellipsis
(make-syntax (syntax-expression value) (wrap-syntax value (anti-mark (syntax-wrap value)))))
(anti-mark (syntax-wrap value))
(syntax-module value)
(syntax-source value))))
(else (values 'other #f)))))))) (else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id) (define (syntax-locally-bound-identifiers id)
@ -3010,7 +2962,7 @@
(match-empty (vector-ref p 1) r) (match-empty (vector-ref p 1) r)
(combine xr* r)))))) (combine xr* r))))))
((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) ((atom) (and (equal? (vector-ref p 1) (strip e)) r))
((vector) ((vector)
(and (vector? e) (and (vector? e)
(match (vector->list e) (vector-ref p 1) w r mod)))))))) (match (vector->list e) (vector-ref p 1) w r mod))))))))