[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/13: Remove top-marked? optimization from psyntax
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/13: Remove top-marked? optimization from psyntax |
|
Date: |
Thu, 25 Feb 2021 15:39:07 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit e054504fd4c29b996d0ec8dbc63a57018a7d76a3
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Feb 24 16:01:02 2021 +0100
Remove top-marked? optimization from psyntax
* 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.
---
module/ice-9/psyntax-pp.scm | 199 +++++++++++++++++++++-----------------------
module/ice-9/psyntax.scm | 128 +++++++++-------------------
2 files changed, 135 insertions(+), 192 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index b23572a..8efd082 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -523,15 +523,17 @@
(and (not (null? 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-syntax
+ (lambda (x w)
+ (make-syntax
+ (syntax-expression x)
+ w
+ (syntax-module x)
+ (syntax-source x))))
(source-wrap
(lambda (x w s defmod)
(cond ((and (null? (car w)) (null? (cdr w)) (not s)) x)
- ((syntax? x)
- (make-syntax
- (syntax-expression x)
- (join-wraps w (syntax-wrap x))
- (syntax-module x)
- (syntax-source x)))
+ ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
((null? x) x)
(else (make-syntax x w defmod (or s (source-properties x)))))))
(expand-sequence
@@ -712,7 +714,7 @@
e)))))
(parse-when-list
(lambda (e when-list)
- (let ((result (strip when-list '(()))))
+ (let ((result (strip when-list)))
(let lp ((l result))
(cond ((null? l) result)
((memq (car l) '(compile load eval expand)) (lp (cdr l)))
@@ -885,8 +887,7 @@
#f
"source expression failed to match any pattern"
tmp-1))))
- ((memv key '(constant))
- (build-data s (strip (source-wrap e w s mod) '(()))))
+ ((memv key '(constant)) (build-data s (strip e)))
((memv key '(global)) (build-global-reference s value mod))
((memv key '(call))
(expand-call (expand (car e) r w mod) e r w s mod))
@@ -965,17 +966,11 @@
(let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w)))
(if (and (pair? ms) (eq? (car ms) #f))
- (make-syntax
- (syntax-expression x)
- (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr
ss)))
- (syntax-module x)
- (syntax-source x))
- (make-syntax
- (decorate-source (syntax-expression x) s)
+ (wrap-syntax x (cons (cdr ms) (if rib (cons rib
(cdr ss)) (cdr ss))))
+ (wrap-syntax
+ x
(cons (cons m ms)
- (if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
- (syntax-module x)
- (syntax-source x))))))
+ (if rib (cons rib (cons 'shift ss)) (cons
'shift ss))))))))
((vector? x)
(let* ((n (vector-length x)) (v (decorate-source
(make-vector n) s)))
(let loop ((i 0))
@@ -991,11 +986,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-d88 transformer-environment)
- (t-680b775fb37a463-d89 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-d7b transformer-environment)
+ (t-680b775fb37a463-d7c (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-d88
- t-680b775fb37a463-d89
+ t-680b775fb37a463-d7b
+ t-680b775fb37a463-d7c
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1562,11 +1557,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-ff9
- tmp-680b775fb37a463-ff8
-
tmp-680b775fb37a463-ff7)
- (cons tmp-680b775fb37a463-ff7
- (cons
tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-ff9)))
+ (map (lambda (tmp-680b775fb37a463-fec
+ tmp-680b775fb37a463-feb
+
tmp-680b775fb37a463-fea)
+ (cons tmp-680b775fb37a463-fea
+ (cons
tmp-680b775fb37a463-feb tmp-680b775fb37a463-fec)))
e2*
e1*
args*)))
@@ -1579,21 +1574,20 @@
#f
"source expression failed to match any pattern"
tmp))))))))
- (strip (lambda (x w)
- (if (memq 'top (car w))
- x
- (let f ((x x))
- (cond ((syntax? x) (strip (syntax-expression x) (syntax-wrap
x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a
d))))
- ((vector? x)
- (let* ((old (vector->list x)) (new (map f old)))
- (let lp ((l1 old) (l2 new))
- (cond ((null? l1) x)
- ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr
l2)))
- (else (list->vector new))))))
- (else x))))))
+ (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))))
+ ((pair? x)
+ (annotate source-properties (cons (strip (car x))
(strip (cdr x)))))
+ ((vector? x)
+ (annotate source-properties (list->vector (strip
(vector->list x)))))
+ (else x)))))
(gen-var
(lambda (id)
(let ((id (if (syntax? id) (syntax-expression id) id)))
@@ -1659,7 +1653,7 @@
(lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
(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))))))
(global-extend
'core
@@ -1872,11 +1866,9 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-6a0
- tmp-680b775fb37a463-69f
- tmp-680b775fb37a463-69e)
- (cons tmp-680b775fb37a463-69e
- (cons tmp-680b775fb37a463-69f
tmp-680b775fb37a463-6a0)))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-68f)
+ (cons tmp-680b775fb37a463-68f
+ (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)))
e2
e1
args)))
@@ -1888,11 +1880,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-6b6
- tmp-680b775fb37a463-6b5
- tmp-680b775fb37a463-6b4)
- (cons tmp-680b775fb37a463-6b4
- (cons tmp-680b775fb37a463-6b5
tmp-680b775fb37a463-6b6)))
+ (map (lambda (tmp-680b775fb37a463-6a7
+ tmp-680b775fb37a463-6a6
+ tmp-680b775fb37a463-6a5)
+ (cons tmp-680b775fb37a463-6a5
+ (cons tmp-680b775fb37a463-6a6
tmp-680b775fb37a463-6a7)))
e2
e1
args)))
@@ -1915,9 +1907,9 @@
(apply (lambda (args e1 e2)
(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-1
tmp-680b775fb37a463-66a)))
+ (cons tmp-680b775fb37a463-65a
tmp-680b775fb37a463-65b)))
e2
e1
args)))
@@ -1929,9 +1921,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463
tmp-680b775fb37a463-67f tmp-680b775fb37a463-67e)
- (cons tmp-680b775fb37a463-67e
- (cons tmp-680b775fb37a463-67f
tmp-680b775fb37a463)))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-66f)
+ (cons tmp-680b775fb37a463-66f
+ (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)))
e2
e1
args)))
@@ -2285,7 +2277,7 @@
(lambda () (cvt x n
ids))
(lambda (p ids)
(values (vector 'vector p) ids))))
tmp-1)
- (let ((x tmp)) (values (vector
'atom (strip p '(()))) ids))))))))))))))))
+ (let ((x tmp)) (values (vector
'atom (strip p)) ids))))))))))))))))
(cvt pattern 0 '()))))
(build-dispatch-call
(lambda (pvars exp y r mod)
@@ -2439,7 +2431,7 @@
(cond ((not source) (source-properties datum))
((and (list? source) (and-map pair? source)) source)
(else (syntax-source source))))))
- (set! syntax->datum (lambda (x) (strip x '(()))))
+ (set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries
(lambda (ls)
(let ((x ls))
@@ -2477,8 +2469,8 @@
who
message
(or (source-annotation subform) (source-annotation form))
- (strip form '(()))
- (and subform (strip subform '(()))))))
+ (strip form)
+ (strip subform))))
(letrec*
((%syntax-module
(lambda (id)
@@ -2525,11 +2517,7 @@
((memv key '(ellipsis))
(values
'ellipsis
- (make-syntax
- (syntax-expression value)
- (anti-mark (syntax-wrap value))
- (syntax-module value)
- (syntax-source value))))
+ (wrap-syntax value (anti-mark (syntax-wrap
value)))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
@@ -2644,7 +2632,7 @@
(if (null? xr*) (match-empty (vector-ref p
1) r) (combine xr* r))))))
((memv key '(free-id))
(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))
(and (vector? e) (match (vector->list e)
(vector-ref p 1) w r mod)))))))))
(match (lambda (e p w r mod)
@@ -2847,9 +2835,11 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ (map (lambda (tmp-680b775fb37a463-110c
+ tmp-680b775fb37a463-110b
+ tmp-680b775fb37a463-110a)
+ (list (cons tmp-680b775fb37a463-110a
tmp-680b775fb37a463-110b)
+ tmp-680b775fb37a463-110c))
template
pattern
keyword)))
@@ -2865,11 +2855,9 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-113f
- tmp-680b775fb37a463-113e
- tmp-680b775fb37a463-113d)
- (list (cons tmp-680b775fb37a463-113d
tmp-680b775fb37a463-113e)
- tmp-680b775fb37a463-113f))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
template
pattern
keyword)))
@@ -2884,9 +2872,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ (map (lambda (tmp-680b775fb37a463-113e
+ tmp-680b775fb37a463-113d
+ tmp-680b775fb37a463-113c)
+ (list (cons tmp-680b775fb37a463-113c
tmp-680b775fb37a463-113d)
+ tmp-680b775fb37a463-113e))
template
pattern
keyword)))
@@ -2902,9 +2892,11 @@
dots
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-115d
+ tmp-680b775fb37a463-115c
+ tmp-680b775fb37a463-115b)
+ (list (cons
tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c)
+ tmp-680b775fb37a463-115d))
template
pattern
keyword)))
@@ -3052,8 +3044,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463)
- (list
"value" tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-120d)
+ (list
"value" tmp-680b775fb37a463-120d))
p)
(quasi q lev))
(quasicons
@@ -3076,8 +3068,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-122c)
- (list
"value" tmp-680b775fb37a463-122c))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list
"value" tmp-680b775fb37a463))
p)
(quasi q lev))
(quasicons
@@ -3130,8 +3122,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463)
- (list "value"
tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-122d)
+ (list "value"
tmp-680b775fb37a463-122d))
p)
(vquasi q lev))
(quasicons
@@ -3231,8 +3223,7 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-129c)
- (list "quote"
tmp-680b775fb37a463-129c))
+ (k (map (lambda (tmp-680b775fb37a463)
(list "quote" tmp-680b775fb37a463))
y)))
tmp-1)
(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)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-12ab tmp))
- (list "list->vector"
t-680b775fb37a463-12ab)))))))))))))))))
+ (let ((t-680b775fb37a463 tmp))
+ (list "list->vector"
t-680b775fb37a463)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3257,9 +3248,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12ba)
+ (apply (lambda
(t-680b775fb37a463-12a0)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12ba))
+
t-680b775fb37a463-12a0))
tmp)
(syntax-violation
#f
@@ -3275,10 +3266,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-12ce t-680b775fb37a463-12cd)
+ (apply (lambda
(t-680b775fb37a463-12b4 t-680b775fb37a463-12b3)
(list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-12ce
-
t-680b775fb37a463-12cd))
+
t-680b775fb37a463-12b4
+
t-680b775fb37a463-12b3))
tmp)
(syntax-violation
#f
@@ -3291,9 +3282,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12da)
+ (apply (lambda
(t-680b775fb37a463-12c0)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12da))
+
t-680b775fb37a463-12c0))
tmp)
(syntax-violation
#f
@@ -3306,9 +3297,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12e6)
+ (apply (lambda
(t-680b775fb37a463-12cc)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12e6))
+
t-680b775fb37a463-12cc))
tmp)
(syntax-violation
#f
@@ -3319,9 +3310,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-12f2 tmp))
+ (let
((t-680b775fb37a463-12d8 tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12f2))))
+
t-680b775fb37a463-12d8))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp
'(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 430ba31..aa13215 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -98,33 +98,6 @@
;;; compiled. In this way, psyntax bootstraps off of an expanded
;;; 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:
@@ -626,12 +599,8 @@
(define-structure (ribcage symnames marks labels))
(define-syntax empty-wrap (identifier-syntax '(())))
-
(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
;; the symbol top. We do not use integers so that marks will remain
;; unique even across file compiles.
@@ -1043,15 +1012,16 @@
(lambda (x w 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
(lambda (x w s defmod)
(cond
((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not s)) x)
- ((syntax? x)
- (make-syntax (syntax-expression x)
- (join-wraps w (syntax-wrap x))
- (syntax-module x)
- (syntax-source x)))
+ ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
((null? x) 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
;; eval, load, expand, and compile, which is totally unintended.
;; So do a symbolic match instead.
- (let ((result (strip when-list empty-wrap)))
+ (let ((result (strip when-list)))
(let lp ((l result))
(if (null? l)
result
@@ -1451,7 +1421,7 @@
value
(map (lambda (e) (expand e r w mod))
#'(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))
((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
@@ -1535,20 +1505,19 @@
(let ((ms (wrap-marks w)) (ss (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
;; output is from original text
- (make-syntax
- (syntax-expression x)
- (make-wrap (cdr ms) (if rib (cons rib (cdr ss))
(cdr ss)))
- (syntax-module x)
- (syntax-source x))
+ (wrap-syntax
+ x
+ (make-wrap (cdr ms)
+ (if rib
+ (cons rib (cdr ss))
+ (cdr ss))))
;; output introduced by macro
- (make-syntax
- (decorate-source (syntax-expression x) s)
+ (wrap-syntax
+ x
(make-wrap (cons m ms)
(if rib
(cons rib (cons 'shift ss))
- (cons 'shift ss)))
- (syntax-module x)
- (syntax-source x))))))
+ (cons 'shift ss))))))))
((vector? x)
(let* ((n (vector-length x))
@@ -2000,36 +1969,22 @@
;; data
- ;; strips syntax objects down to top-wrap
- ;;
- ;; 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
- (lambda (x w)
- (if (top-marked? w)
- x
- (let f ((x x))
- (cond
- ((syntax? x)
- (strip (syntax-expression x) (syntax-wrap x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? 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))))))
+ ;; strips syntax objects, recursively.
+
+ (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))
+ (cond
+ ((syntax? x)
+ (annotate syntax-source (strip (syntax-expression x))))
+ ((pair? x)
+ (annotate source-properties (cons (strip (car x)) (strip (cdr x)))))
+ ((vector? x)
+ (annotate source-properties (list->vector (strip (vector->list x)))))
+ (else x)))
;; lexical variables
@@ -2102,7 +2057,7 @@
(global-extend 'core 'quote
(lambda (e r w s mod)
(syntax-case e ()
- ((_ e) (build-data s (strip #'e w)))
+ ((_ e) (build-data s (strip #'e)))
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
@@ -2641,7 +2596,7 @@
(call-with-values
(lambda () (cvt (syntax (x ...)) n
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 '())))
(define build-dispatch-call
@@ -2786,7 +2741,7 @@
;; accepts any object, since syntax objects may consist partially
;; or entirely of unwrapped, nonsymbolic data
(lambda (x)
- (strip x empty-wrap)))
+ (strip x)))
(set! generate-temporaries
(lambda (ls)
@@ -2816,8 +2771,8 @@
(throw 'syntax-error who message
(or (source-annotation subform)
(source-annotation form))
- (strip form empty-wrap)
- (and subform (strip subform empty-wrap)))))
+ (strip form)
+ (strip subform))))
(let ()
(define (%syntax-module id)
@@ -2857,10 +2812,7 @@
(values 'global (cons value (cdr mod)))))
((ellipsis)
(values 'ellipsis
- (make-syntax (syntax-expression value)
- (anti-mark (syntax-wrap value))
- (syntax-module value)
- (syntax-source value))))
+ (wrap-syntax value (anti-mark (syntax-wrap value)))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
@@ -3010,7 +2962,7 @@
(match-empty (vector-ref p 1) r)
(combine xr* 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)
(and (vector? e)
(match (vector->list e) (vector-ref p 1) w r mod))))))))
- [Guile-commits] branch master updated (a04a024 -> 697f2b3), Andy Wingo, 2021/02/25
- [Guile-commits] 02/13: Remove top-marked? optimization from psyntax,
Andy Wingo <=
- [Guile-commits] 09/13: Add syntax-sourcev, Andy Wingo, 2021/02/25
- [Guile-commits] 04/13: Ensure that (syntax ()) results in (), Andy Wingo, 2021/02/25
- [Guile-commits] 03/13: Fix module scoping for datum->syntax with no identifier, Andy Wingo, 2021/02/25
- [Guile-commits] 07/13: Commit updates from newest autoconf, Andy Wingo, 2021/02/25
- [Guile-commits] 11/13: Psyntax uses sourcev internally, Andy Wingo, 2021/02/25
- [Guile-commits] 06/13: Read Scheme via read-syntax, Andy Wingo, 2021/02/25
- [Guile-commits] 01/13: Add quote-syntax, Andy Wingo, 2021/02/25
- [Guile-commits] 10/13: Assembler writes vector source properties, Andy Wingo, 2021/02/25
- [Guile-commits] 13/13: Shunt syntax-sourcev to (system syntax internal), Andy Wingo, 2021/02/25
- [Guile-commits] 12/13: read-syntax uses vector source representation, Andy Wingo, 2021/02/25