fix bug in tracking paren shapes; fix Scribble binding search code; add syntax/template library
svn: r14661
This commit is contained in:
Matthew Flatt
parent
1ce0c8c307
commit
224f9fa3a7
|
|
@ -2,10 +2,10 @@
|
|||
|
||||
(require (for-syntax scheme/base)
|
||||
r6rs/private/qq-gen
|
||||
scheme/stxparam
|
||||
scheme/mpair
|
||||
r6rs/private/exns
|
||||
(for-syntax r6rs/private/check-pattern))
|
||||
(for-syntax syntax/template
|
||||
r6rs/private/check-pattern))
|
||||
|
||||
(provide make-variable-transformer
|
||||
(rename-out [r6rs:syntax-case syntax-case]
|
||||
|
|
@ -138,35 +138,6 @@
|
|||
;; Also, R6RS doesn't have (... <tmpl>) quoting in patterns --- only
|
||||
;; in templates. <<<< FIXME
|
||||
|
||||
(define-syntax-parameter pattern-vars null)
|
||||
|
||||
(provide pattern-vars)
|
||||
|
||||
(define-for-syntax (add-pattern-vars ids)
|
||||
(append (syntax->list ids)
|
||||
(syntax-parameter-value (quote-syntax pattern-vars))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-for-syntax (extract-pattern-ids stx lits)
|
||||
(syntax-case stx ()
|
||||
[(a . b) (append (extract-pattern-ids #'a lits)
|
||||
(extract-pattern-ids #'b lits))]
|
||||
[#(a ...) (apply append
|
||||
(map (lambda (a)
|
||||
(extract-pattern-ids a lits))
|
||||
(syntax->list #'(a ...))))]
|
||||
[a
|
||||
(identifier? #'a)
|
||||
(if (or (ormap (lambda (lit)
|
||||
(free-identifier=? lit #'a))
|
||||
lits)
|
||||
(free-identifier=? #'a #'(... ...))
|
||||
(free-identifier=? #'a #'_))
|
||||
null
|
||||
(list #'a))]
|
||||
[_ null]))
|
||||
|
||||
(define-syntax (r6rs:syntax-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr (lit ...) clause ...)
|
||||
|
|
@ -194,186 +165,58 @@
|
|||
. #,(map (lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(pat val)
|
||||
(with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
|
||||
(begin
|
||||
((check-pat-ellipses stx) #'pat)
|
||||
#`(pat (syntax-parameterize ([pattern-vars
|
||||
(add-pattern-vars #'pat-ids)])
|
||||
val)))]
|
||||
#`(pat val))]
|
||||
[(pat fender val)
|
||||
(with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
|
||||
(begin
|
||||
((check-pat-ellipses stx) #'pat)
|
||||
#`(pat (syntax-parameterize ([pattern-vars
|
||||
(add-pattern-vars #'pat-ids)])
|
||||
fender)
|
||||
(syntax-parameterize ([pattern-vars
|
||||
(add-pattern-vars #'pat-ids)])
|
||||
val)))]
|
||||
#`(pat fender val))]
|
||||
[else clause]))
|
||||
(syntax->list #'(clause ...))))))]
|
||||
[(_ . rest) (syntax/loc stx (syntax-case . rest))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-for-syntax (make-unwrap-map tmpl pattern-vars)
|
||||
(let loop ([tmpl tmpl]
|
||||
[in-ellipses? #f]
|
||||
[counting? #f])
|
||||
(syntax-case tmpl ()
|
||||
[(ellipses expr)
|
||||
(and (not in-ellipses?)
|
||||
(identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
(loop #'expr #t #f)]
|
||||
[(expr ellipses . rest)
|
||||
(and (not in-ellipses?)
|
||||
(identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
(box (cons (loop #'expr #f #f)
|
||||
(let rloop ([rest #'rest])
|
||||
(syntax-case rest ()
|
||||
[(ellipses . rest)
|
||||
(and (identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
;; keep going:
|
||||
(rloop #'rest)]
|
||||
[else (loop rest #f #t)]))))]
|
||||
[(a . b) (let ([a (loop #'a in-ellipses? #f)]
|
||||
[b (loop #'b in-ellipses? counting?)])
|
||||
(if (or a b counting?)
|
||||
(cons a b)
|
||||
#f))]
|
||||
[#(a ...) (let ([as (loop (syntax->list #'(a ...))
|
||||
in-ellipses?
|
||||
#f)])
|
||||
(and as (vector as)))]
|
||||
[a
|
||||
(identifier? #'a)
|
||||
(ormap (lambda (pat-var)
|
||||
(free-identifier=? #'a pat-var))
|
||||
pattern-vars)]
|
||||
[_ #f])))
|
||||
(define (unwrap-reconstructed data stx datum)
|
||||
datum)
|
||||
|
||||
(define-for-syntax (group-ellipses tmpl umap)
|
||||
(define (stx-cdr s) (if (syntax? s) (cdr (syntax-e s)) (cdr s)))
|
||||
(let loop ([tmpl tmpl][umap umap])
|
||||
(if (not umap)
|
||||
tmpl
|
||||
(syntax-case tmpl ()
|
||||
[(ellipses expr)
|
||||
(and (identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
tmpl]
|
||||
[(expr ellipses . rest)
|
||||
(and (identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
(let rloop ([rest (stx-cdr (stx-cdr tmpl))]
|
||||
[accum (list #'ellipses (loop #'expr
|
||||
(car (unbox umap))))])
|
||||
(syntax-case rest ()
|
||||
[(ellipses . _)
|
||||
(and (identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
;; keep going:
|
||||
(rloop (stx-cdr rest) (cons #'ellipses accum))]
|
||||
[_ (cons (datum->syntax #f (reverse accum))
|
||||
(loop rest (cdr (unbox umap))))]))]
|
||||
[(a . b) (let ([n (cons (loop #'a (car umap))
|
||||
(loop (cdr (if (syntax? tmpl)
|
||||
(syntax-e tmpl)
|
||||
tmpl))
|
||||
(cdr umap)))])
|
||||
(if (syntax? tmpl)
|
||||
(datum->syntax tmpl n tmpl tmpl tmpl)
|
||||
n))]
|
||||
[#(a ...) (datum->syntax
|
||||
tmpl
|
||||
(list->vector (loop (syntax->list #'(a ...))
|
||||
(vector-ref umap 0)))
|
||||
tmpl
|
||||
tmpl
|
||||
tmpl)]
|
||||
[_ tmpl]))))
|
||||
(define (unwrap-pvar data stx)
|
||||
;; unwrap based on srcloc:
|
||||
(let loop ([v stx])
|
||||
(cond
|
||||
[(syntax? v)
|
||||
(if (eq? (syntax-source v) unwrapped-tag)
|
||||
(loop (syntax-e v))
|
||||
v)]
|
||||
[(pair? v) (mcons (loop (car v))
|
||||
(loop (cdr v)))]
|
||||
[(vector? v) (list->vector
|
||||
(map loop (vector->list v)))]
|
||||
[else v])))
|
||||
|
||||
(define (unwrap stx mapping)
|
||||
(cond
|
||||
[(not mapping)
|
||||
;; In case stx is a pair, explicitly convert
|
||||
(datum->syntax #f (convert-mpairs stx))]
|
||||
[(eq? mapping #t)
|
||||
;; was a pattern var; unwrap based on srcloc:
|
||||
(let loop ([v stx])
|
||||
(cond
|
||||
[(syntax? v)
|
||||
(if (eq? (syntax-source v) unwrapped-tag)
|
||||
(loop (syntax-e v))
|
||||
v)]
|
||||
[(pair? v) (mcons (loop (car v))
|
||||
(loop (cdr v)))]
|
||||
[(vector? v) (list->vector
|
||||
(map loop (vector->list v)))]
|
||||
[else v]))]
|
||||
[(pair? mapping)
|
||||
(let ([p (if (syntax? stx)
|
||||
(syntax-e stx)
|
||||
stx)])
|
||||
(mcons (unwrap (car p) (car mapping))
|
||||
(unwrap (cdr p) (cdr mapping))))]
|
||||
[(vector? mapping)
|
||||
(list->vector (let loop ([v (unwrap (vector->list (syntax-e stx))
|
||||
(vector-ref mapping 0))])
|
||||
(cond
|
||||
[(null? v) null]
|
||||
[(mpair? v) (cons (mcar v) (loop (mcdr v)))]
|
||||
[(syntax? v) (syntax->list v)])))]
|
||||
[(null? mapping) null]
|
||||
[(box? mapping)
|
||||
;; ellipses
|
||||
(let* ([mapping (unbox mapping)]
|
||||
[rest-mapping (cdr mapping)]
|
||||
[p (if (syntax? stx) (syntax-e stx) stx)]
|
||||
[repeat-stx (car p)]
|
||||
[rest-stx (cdr p)])
|
||||
(let ([repeats (list->mlist
|
||||
(map (lambda (rep)
|
||||
(unwrap rep (car mapping)))
|
||||
(syntax->list repeat-stx)))]
|
||||
[rest-mapping
|
||||
;; collapse #fs to single #f:
|
||||
(if (let loop ([rest-mapping rest-mapping])
|
||||
(if (pair? rest-mapping)
|
||||
(if (not (car rest-mapping))
|
||||
(loop (cdr rest-mapping))
|
||||
#f)
|
||||
(not rest-mapping)))
|
||||
#f
|
||||
rest-mapping)])
|
||||
|
||||
(if (and (not rest-mapping)
|
||||
(or (null? rest-stx)
|
||||
(and (syntax? rest-stx)
|
||||
(null? (syntax-e rest-stx)))))
|
||||
repeats
|
||||
(mappend repeats
|
||||
(unwrap rest-stx rest-mapping)))))]
|
||||
[else (error 'unwrap "strange unwrap mapping: ~e" mapping)]))
|
||||
(define (leaf-to-syntax datum)
|
||||
(datum->syntax #f datum))
|
||||
|
||||
(define (ellipses-end stx)
|
||||
;; R6RS says that (x ...) must be a list, so we need a special rule
|
||||
(if (and (syntax? stx) (null? (syntax-e stx)))
|
||||
null
|
||||
stx))
|
||||
|
||||
(define-for-syntax (no-data x) #f)
|
||||
|
||||
(define-syntax (r6rs:syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ tmpl)
|
||||
(let ([umap (make-unwrap-map #'tmpl
|
||||
(syntax-parameter-value #'pattern-vars))])
|
||||
(quasisyntax/loc stx
|
||||
(unwrap (if #f
|
||||
;; Process tmpl first, so that syntax errors are reported
|
||||
;; usinf the original source.
|
||||
#,(syntax/loc stx (syntax tmpl))
|
||||
;; Convert tmpl to group ...-created repetitions together,
|
||||
;; so that `unwrap' can tell which result came from which
|
||||
;; template:
|
||||
#,(with-syntax ([tmpl (group-ellipses #'tmpl umap)])
|
||||
(syntax/loc stx (syntax tmpl))))
|
||||
'#,umap)))]
|
||||
[(_ . rest) (syntax/loc stx (syntax . rest))]))
|
||||
[(_ template)
|
||||
(transform-template #'template
|
||||
#:constant-as-leaf? #t
|
||||
#:save (lambda (x) #f)
|
||||
#:restore-stx #'unwrap-reconstructed
|
||||
#:leaf-datum-stx #'leaf-to-syntax
|
||||
#:pvar-restore-stx #'unwrap-pvar
|
||||
#:cons-stx #'mcons
|
||||
#:ellipses-end-stx #'ellipses-end)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -507,7 +507,7 @@
|
|||
(set! cnt (add1 cnt))
|
||||
(string->symbol (format "~a~a" prefix cnt)))))
|
||||
;; The pattern expander:
|
||||
(-define (expander p proto-r local-top use-ellipses? use-tail-pos hash!)
|
||||
(-define (expander p proto-r local-top use-ellipses? use-tail-pos hash! need-list?)
|
||||
(cond
|
||||
[(and use-ellipses? (ellipsis? p))
|
||||
(let*-values ([(p-head) (stx-car p)]
|
||||
|
|
@ -559,8 +559,9 @@
|
|||
(pick-specificity
|
||||
top
|
||||
last-el))))]
|
||||
[rest (expander rest-p proto-r local-top #t use-tail-pos hash!)]
|
||||
[ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash!)])
|
||||
[rest (expander rest-p proto-r local-top #t use-tail-pos hash! need-list?)]
|
||||
[ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash!
|
||||
(or need-list? (positive? el-count)))])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
,(let ([pre (let ([deeps
|
||||
|
|
@ -597,10 +598,11 @@
|
|||
(sub1 el-count))))])
|
||||
(wrap
|
||||
`(map
|
||||
(lambda vals (,ehead
|
||||
,(if (null? proto-rr-shallow)
|
||||
'vals
|
||||
'(append shallows vals))))
|
||||
(lambda vals
|
||||
(,ehead
|
||||
,(if (null? proto-rr-shallow)
|
||||
'vals
|
||||
'(append shallows vals))))
|
||||
,@valses)
|
||||
el-count))]))])
|
||||
(if (null? proto-rr-shallow)
|
||||
|
|
@ -611,9 +613,17 @@
|
|||
proto-rr-shallow))])
|
||||
,deeps)))]
|
||||
[post (apply-to-r rest)])
|
||||
(if (eq? post 'null)
|
||||
pre
|
||||
`(append ,pre ,post))))
|
||||
(let ([v (if (eq? post 'null)
|
||||
pre
|
||||
`(append ,pre ,post))])
|
||||
(if (and (not need-list?) (syntax? p))
|
||||
;; Keep srcloc, properties, etc.:
|
||||
(let ([small-dest (datum->syntax p
|
||||
'dest
|
||||
p
|
||||
p)])
|
||||
`(datum->syntax/shape (quote-syntax ,small-dest) ,v))
|
||||
v))))
|
||||
;; variables were hashed
|
||||
(void))))]
|
||||
[(stx-pair? p)
|
||||
|
|
@ -623,21 +633,21 @@
|
|||
(if (and (stx-pair? (stx-cdr p))
|
||||
(stx-null? (stx-cdr (stx-cdr p))))
|
||||
(let ([dp (stx-car (stx-cdr p))])
|
||||
(expander dp proto-r dp #f use-tail-pos hash!))
|
||||
(expander dp proto-r dp #f use-tail-pos hash! need-list?))
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"misplaced ellipses in template"
|
||||
top
|
||||
hd))
|
||||
(let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash!)]
|
||||
[etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash!)])
|
||||
(let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash! #f)]
|
||||
[etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash! need-list?)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym))
|
||||
;; variables were hashed
|
||||
(void)))))]
|
||||
[(stx-vector? p #f)
|
||||
(let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash!)])
|
||||
(let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(list->vector (stx->list ,(apply-to-r e))))
|
||||
|
|
@ -646,7 +656,7 @@
|
|||
[(and (syntax? p)
|
||||
(struct? (syntax-e p))
|
||||
(prefab-struct-key (syntax-e p)))
|
||||
(let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash!)])
|
||||
(let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) (stx->list ,(apply-to-r e))))
|
||||
|
|
@ -697,7 +707,8 @@
|
|||
l))])
|
||||
(if pr
|
||||
(set-mcdr! pr (cons r (mcdr pr)))
|
||||
(hash-set! ht (syntax-e r) (cons (mcons r (list r)) l))))))))])
|
||||
(hash-set! ht (syntax-e r) (cons (mcons r (list r)) l)))))))
|
||||
#f)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
,(let ([main (let ([build (apply-to-r l)])
|
||||
|
|
@ -808,9 +819,10 @@
|
|||
`(pattern-substitute (quote-syntax ()))
|
||||
p
|
||||
sub-gensym)]
|
||||
|
||||
[(and (pair? t)
|
||||
(eq? (car t) 'quote-syntax)
|
||||
(stx-smaller-than? (car t) 10))
|
||||
(stx-smaller-than? (cdr t) 10))
|
||||
;; Shift into `pattern-substitute' mode with an intitial constant.
|
||||
;; (Only do this for small constants, so we don't traverse
|
||||
;; big constants when looking for substitutions.)
|
||||
|
|
@ -1028,7 +1040,7 @@
|
|||
(stx-car stx)))))))
|
||||
(-define (make-syntax-mapping depth valvar)
|
||||
(make-set!-transformer (-make-syntax-mapping depth valvar)))
|
||||
(-define (syntax-mapping? v)
|
||||
(-define (syntax-pattern-variable? v)
|
||||
(and (set!-transformer? v)
|
||||
(-syntax-mapping? (set!-transformer-procedure v))))
|
||||
(-define (syntax-mapping-depth v)
|
||||
|
|
@ -1038,6 +1050,6 @@
|
|||
|
||||
(#%provide (protect make-match&env get-match-vars make-interp-match
|
||||
make-pexpand
|
||||
make-syntax-mapping syntax-mapping?
|
||||
make-syntax-mapping syntax-pattern-variable?
|
||||
syntax-mapping-depth syntax-mapping-valvar
|
||||
stx-memq-pos no-ellipses?)))
|
||||
|
|
|
|||
|
|
@ -60,4 +60,5 @@
|
|||
|
||||
(#%provide syntax (all-from "with-stx.ss") (all-from "stxloc.ss")
|
||||
check-duplicate-identifier
|
||||
syntax-rules syntax-id-rules))
|
||||
syntax-rules syntax-id-rules
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
|
|
|
|||
|
|
@ -491,7 +491,7 @@
|
|||
(map
|
||||
(lambda (var)
|
||||
(and (let ([v (syntax-local-value var (lambda () #f))])
|
||||
(and (syntax-mapping? v)
|
||||
(and (syntax-pattern-variable? v)
|
||||
v))))
|
||||
unique-vars)])
|
||||
(if (and (or (null? var-bindings)
|
||||
|
|
@ -556,4 +556,5 @@
|
|||
(cons (quote-syntax list*) r)]))))))))))
|
||||
x)))
|
||||
|
||||
(#%provide (all-from "ellipses.ss") syntax-case** syntax))
|
||||
(#%provide (all-from "ellipses.ss") syntax-case** syntax
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
(syntax-case** #f #t stx () free-identifier=?
|
||||
[(_ loc pattern)
|
||||
(if (if (symbol? (syntax-e #'pattern))
|
||||
(syntax-mapping? (syntax-local-value #'pattern (lambda () #f)))
|
||||
(syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f)))
|
||||
#f)
|
||||
(syntax (syntax pattern))
|
||||
(syntax (relocate loc (syntax pattern))))])))
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@
|
|||
(cadddr (cdr stx/binding)))))])])
|
||||
(and
|
||||
(pair? b)
|
||||
(let ([seen (make-hasheq)]
|
||||
(let ([seen (make-hash)]
|
||||
[search-key #f])
|
||||
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
||||
[rqueue null]
|
||||
|
|
@ -99,7 +99,7 @@
|
|||
(loop queue rqueue need-result?)
|
||||
;; Check parents, if we can get the source:
|
||||
(if (and (path? (resolved-module-path-name rmp))
|
||||
(not (hash-ref seen rmp #f)))
|
||||
(not (hash-ref seen (cons export-phase rmp) #f)))
|
||||
(let ([exports
|
||||
(hash-ref
|
||||
module-info-cache
|
||||
|
|
@ -130,7 +130,7 @@
|
|||
(cdr stxess))]))])
|
||||
(hash-set! module-info-cache rmp t)
|
||||
t))))])
|
||||
(hash-set! seen rmp #t)
|
||||
(hash-set! seen (cons export-phase rmp) #t)
|
||||
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
||||
(if a
|
||||
(cdr a)
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
0
|
||||
0
|
||||
0)))
|
||||
(cadr a))
|
||||
(reverse (cadr a)))
|
||||
rqueue)
|
||||
need-result?)
|
||||
(begin
|
||||
|
|
@ -158,9 +158,9 @@
|
|||
;; for now.
|
||||
#;
|
||||
(error 'find-scheme-tag
|
||||
"dead end when looking for binding source: ~e"
|
||||
id)
|
||||
#f))))
|
||||
"dead end when looking for binding source: ~e"
|
||||
id)
|
||||
(loop queue rqueue need-result?)))))
|
||||
;; Can't get the module source, so continue with queue:
|
||||
(loop queue rqueue need-result?)))])
|
||||
(or here-result
|
||||
|
|
|
|||
|
|
@ -411,3 +411,16 @@ The @scheme[_] transformer binding prohibits @scheme[_] from being
|
|||
used as an expression. This binding useful only in syntax patterns,
|
||||
where it indicates a pattern that matches any syntax object. See
|
||||
@scheme[syntax-case].}
|
||||
|
||||
|
||||
@defproc[(syntax-pattern-variable? [v any/c]) boolean?]{
|
||||
|
||||
Return @scheme[#t] if @scheme[v] is a value that, as a
|
||||
transformer-binding value, makes the bound variable as pattern
|
||||
variable in @scheme[syntax] and other forms. To check whether an
|
||||
identifier is a pattern variable, use @scheme[syntax-local-value] to
|
||||
get the identifier's transformer value, and then test the value with
|
||||
@scheme[syntax-pattern-variable?].
|
||||
|
||||
The @scheme[syntax-pattern-variable?] procedure is provided
|
||||
@scheme[for-syntax] by @schememodname[scheme/base].}
|
||||
|
|
|
|||
|
|
@ -299,7 +299,7 @@
|
|||
[(attribute name)
|
||||
(identifier? #'name)
|
||||
(let ([mapping (syntax-local-value #'name (lambda () #f))])
|
||||
(unless (syntax-mapping? mapping)
|
||||
(unless (syntax-pattern-variable? mapping)
|
||||
(wrong-syntax #'name "not bound as a pattern variable"))
|
||||
(let ([var (syntax-mapping-valvar mapping)])
|
||||
(let ([attr (syntax-local-value var (lambda () #f))])
|
||||
|
|
|
|||
83
collects/syntax/private/template-runtime.ss
Normal file
83
collects/syntax/private/template-runtime.ss
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
#lang scheme/base
|
||||
(require "../stx.ss")
|
||||
|
||||
(provide template-map-apply)
|
||||
|
||||
(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes)
|
||||
(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes)
|
||||
|
||||
(define (stx-list->vector l)
|
||||
(list->vector
|
||||
(if (list? l)
|
||||
l
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l) (cons (car l) (loop (cdr l)))]
|
||||
[(syntax? l) (loop (syntax-e l))])))))
|
||||
|
||||
(define (template-map-apply tmap d->s leaf->s leaf-datum pvar->s pcons ellipses-end data stx)
|
||||
(let loop ([tmap tmap][data data][stx stx][local-pcons pcons])
|
||||
(cond
|
||||
[(not tmap) (if (box? data)
|
||||
(leaf->s (unbox data) stx)
|
||||
(leaf-datum stx))]
|
||||
[(eq? tmap #t) (pvar->s data stx)]
|
||||
[(pair? tmap)
|
||||
(let ([a (loop (car tmap)
|
||||
(if (pair? data) (car data) (vector-ref data 1))
|
||||
(stx-car stx)
|
||||
pcons)]
|
||||
[b (loop (cdr tmap)
|
||||
(if (pair? data) (cdr data) (vector-ref data 2))
|
||||
(stx-cdr stx)
|
||||
local-pcons)])
|
||||
(if (vector? data)
|
||||
(d->s
|
||||
(vector-ref data 0)
|
||||
stx
|
||||
(pcons a b))
|
||||
(local-pcons a b)))]
|
||||
[(vector? tmap)
|
||||
(d->s (car data)
|
||||
stx
|
||||
(stx-list->vector
|
||||
(loop (vector-ref tmap 0)
|
||||
(cdr data)
|
||||
(vector->list (syntax-e stx))
|
||||
cons)))]
|
||||
[(box? tmap)
|
||||
(d->s (car data)
|
||||
stx
|
||||
(box
|
||||
(loop (unbox tmap)
|
||||
(cdr data)
|
||||
(unbox (syntax-e stx))
|
||||
pcons)))]
|
||||
[(ellipses? tmap)
|
||||
(let ([prefix (map (lambda (e)
|
||||
(loop (ellipses-elem tmap)
|
||||
(if (pair? data) (car data) (vector-ref data 1))
|
||||
e
|
||||
local-pcons))
|
||||
(syntax->list (stx-car stx)))]
|
||||
[rest (loop (ellipses-rest tmap)
|
||||
(if (pair? data) (cdr data) (vector-ref data 2))
|
||||
(stx-cdr stx)
|
||||
local-pcons)])
|
||||
(let ([appended (let loop ([prefix prefix])
|
||||
(if (null? prefix)
|
||||
(ellipses-end rest)
|
||||
(local-pcons (car prefix) (loop (cdr prefix)))))])
|
||||
(if (vector? data)
|
||||
(d->s (vector-ref data 0)
|
||||
stx
|
||||
appended)
|
||||
appended)))]
|
||||
[(prefab? tmap)
|
||||
(d->s (car data)
|
||||
stx
|
||||
(loop (prefab-fields tmap)
|
||||
(cdr data)
|
||||
(cdr (vector->list (struct->vector (syntax-e stx))))))]
|
||||
[else (error "template-map-apply fallthrough")])))
|
||||
99
collects/syntax/scribblings/template.scrbl
Normal file
99
collects/syntax/scribblings/template.scrbl
Normal file
|
|
@ -0,0 +1,99 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.ss"
|
||||
(for-label syntax/template))
|
||||
|
||||
@title[#:tag "template"]{Controlling Syntax Templates}
|
||||
|
||||
@defmodule[syntax/template]
|
||||
|
||||
@defproc[(transform-template [template-stx syntax?]
|
||||
[#:save save-proc (syntax? . -> . any/c)]
|
||||
[#:restore-stx restore-proc-stx syntax?]
|
||||
[#:leaf-save leaf-save-proc (syntax? . -> . any/c) save-proc]
|
||||
[#:leaf-restore-stx leaf-restore-proc-stx syntax? #'(lambda (data stx) stx)]
|
||||
[#:leaf-datum-stx leaf-datum-proc-stx syntax? #'(lambda (v) v)]
|
||||
[#:pvar-save pvar-save-proc (identifier? . -> . any/c) (lambda (x) #f)]
|
||||
[#:pvar-restore-stx pvar-restore-stx syntax? #'(lambda (d stx) stx)]
|
||||
[#:cons-stx cons-proc-stx syntax? cons]
|
||||
[#:ellipses-end-stx ellipses-end-stx syntax? #'values]
|
||||
[#:constant-as-leaf? constant-as-leaf? boolean? #f])
|
||||
syntax?]{
|
||||
|
||||
Produces an representation of an expression similar to
|
||||
@SCHEME[#`((UNSYNTAX @scheme[syntax]) #,template-stx)], but functions like
|
||||
@scheme[save-proc] can collect information that might otherwise be
|
||||
lost by @scheme[syntax] (such as properties when the syntax object is
|
||||
marshaled within bytecode), and run-time functions like the one
|
||||
specified by @scheme[restore-proc-stx] can use the saved information or
|
||||
otherwise process the syntax object that is generated by the template.
|
||||
|
||||
The @scheme[save-proc] is applied to each syntax object in the
|
||||
representation of the original template (i.e., in
|
||||
@scheme[template-stx]). If @scheme[constant-as-leaf?] is @scheme[#t],
|
||||
then @scheme[save-proc] is applied only to syntax objects that contain
|
||||
at least one pattern variable in a sub-form. The result of
|
||||
@scheme[save-proc] is provided back as the first argument to
|
||||
@scheme[restore-proc-stx], which indicates a function with a contract
|
||||
@scheme[(any/c syntax any/c . -> . any/c)]; the second argument to
|
||||
@scheme[restore-proc-stx] is the syntax object that @scheme[syntax]
|
||||
generates, and the last argument is a datum that have been processed
|
||||
recursively (by functions such as @scheme[restore-proc-stx]) and that
|
||||
normally would be converted back to a syntax object using the second
|
||||
argument's context, source, and properties. Note that
|
||||
@scheme[save-proc] works at expansion time (with respect to the
|
||||
template form), while @scheme[restore-proc-stx] indicates a function
|
||||
that is called at run time (for the template form), and the data that
|
||||
flows from @scheme[save-proc] to @scheme[restore-proc-stx] crosses
|
||||
phases via @scheme[quote].
|
||||
|
||||
The @scheme[leaf-save-proc] and @scheme[leaf-restore-proc-stx] procedures
|
||||
are analogous to @scheme[save-proc] and
|
||||
@scheme[restore-proc-stx], but they are applied to leaves, so
|
||||
there is no third argument for recursively processed sub-forms. The
|
||||
function indicated by @scheme[leaf-restore-proc-stx] should have the
|
||||
contract @scheme[(any/c syntax? . -> . any/c)].
|
||||
|
||||
The @scheme[leaf-datum-proc-stx] procedure is applied to leaves that
|
||||
are not syntax objects, which can happen because pairs and the empty
|
||||
list are not always individually wrapped as syntax objects. The
|
||||
function should have the contract @scheme[(any/c . -> . any/c)]. When
|
||||
@scheme[constant-as-leaf?] is @scheme[#f], the only possible argument
|
||||
to the procedure is @scheme[null].
|
||||
|
||||
The @scheme[pvar-save] and @scheme[pvar-restore-stx] procedures are
|
||||
analogous to @scheme[save-proc] and @scheme[restore-proc-stx],
|
||||
but they are applied to pattern variables. The
|
||||
@scheme[pvar-restore-stx] procedure should have the contract
|
||||
@scheme[(any/c syntax? . -> . any/c)], where the second argument
|
||||
corresponds to the substitution of the pattern variable.
|
||||
|
||||
The @scheme[cons-proc-stx] procedure is used to build intermediate
|
||||
pairs, including pairs passed to @scheme[restore-proc-stx] and pairs
|
||||
that do not correspond to syntax objects.
|
||||
|
||||
The @scheme[ellipses-end-stx] procedure is an extra filter on the
|
||||
syntax object that follows a sequence of @scheme[...] ellipses in the
|
||||
template. The procedure should have the contract @scheme[(any/c . ->
|
||||
. any/c)].
|
||||
|
||||
The following example illustrates a use of @scheme[transform-template]
|
||||
to implement a @scheme[syntax/shape] form that preserves the
|
||||
@scheme['paren-shape] property from the original template, even if the
|
||||
template code is marshaled within bytecode.
|
||||
|
||||
@schemeblock[
|
||||
(define-for-syntax (get-shape-prop stx)
|
||||
(syntax-property stx 'paren-shape))
|
||||
|
||||
(define (add-shape-prop v stx datum)
|
||||
(syntax-property (datum->syntax stx datum stx stx stx)
|
||||
'paren-shape
|
||||
v))
|
||||
|
||||
(define-syntax (syntax/shape stx)
|
||||
(syntax-case stx ()
|
||||
[(_ tmpl)
|
||||
(transform-template #'tmpl
|
||||
#:save get-shape-prop
|
||||
#:restore-stx #'add-shape-prop)]))
|
||||
]}
|
||||
|
|
@ -9,3 +9,4 @@
|
|||
@include-section["flatten-begin.scrbl"]
|
||||
@include-section["struct.scrbl"]
|
||||
@include-section["path-spec.scrbl"]
|
||||
@include-section["template.scrbl"]
|
||||
|
|
|
|||
189
collects/syntax/template.ss
Normal file
189
collects/syntax/template.ss
Normal file
|
|
@ -0,0 +1,189 @@
|
|||
#lang scheme/base
|
||||
(require "stx.ss"
|
||||
(for-template scheme/base
|
||||
"private/template-runtime.ss"))
|
||||
|
||||
(provide transform-template)
|
||||
|
||||
;; A template map descibres the structure of a template
|
||||
;; in terms of where pattern variables are replaced.
|
||||
;;
|
||||
;; Walk a map and a template in parallel, and you see
|
||||
;; these map cases:
|
||||
;;
|
||||
;; - #f => corresponding template portion is constant
|
||||
;; - #t => corresponding template portion is a pattern variable
|
||||
;; - (cons map1 map2) => template part is a pair
|
||||
;; which substitutions in one side
|
||||
;; or the other
|
||||
;; - (vector map) => template portion is a vector,
|
||||
;; contents like the list in map
|
||||
;; - (box map) => template portion is a box with substition
|
||||
;; - #s(ellipses count map) => template portion is an ellipses-generated list
|
||||
;; - #s(prefab v map) => templat portion is a prefab
|
||||
|
||||
(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes)
|
||||
(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes)
|
||||
|
||||
(define (datum->syntax* stx d)
|
||||
(datum->syntax stx d stx stx stx))
|
||||
|
||||
(define (make-template-map tmpl const-leaf?)
|
||||
(let loop ([tmpl tmpl]
|
||||
[in-ellipses? #f])
|
||||
(syntax-case tmpl ()
|
||||
[(ellipses expr)
|
||||
(and (not in-ellipses?)
|
||||
(identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
(loop #'expr #t)]
|
||||
[(expr ellipses . rest)
|
||||
(and (not in-ellipses?)
|
||||
(identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
(let-values ([(elem) (loop #'expr #f)]
|
||||
[(rest count)
|
||||
(let rloop ([rest #'rest][count 1])
|
||||
(syntax-case rest ()
|
||||
[(ellipses . rest)
|
||||
(and (identifier? #'ellipses)
|
||||
(free-identifier=? #'ellipses #'(... ...)))
|
||||
;; keep going:
|
||||
(rloop #'rest (add1 count))]
|
||||
[else (values (loop rest #f) count)]))])
|
||||
(make-ellipses elem count rest))]
|
||||
[(a . b) (let ([a (loop #'a in-ellipses?)]
|
||||
[b (loop #'b in-ellipses?)])
|
||||
(and (or a b (not const-leaf?))
|
||||
(cons a b)))]
|
||||
[#(a ...) (let ([as (loop (syntax->list #'(a ...))
|
||||
in-ellipses?)])
|
||||
(and (or as (not const-leaf?))
|
||||
(vector as)))]
|
||||
[#&(a) (let ([as (loop #'a in-ellipses?)])
|
||||
(and (or as (not const-leaf?))
|
||||
(box as)))]
|
||||
[a
|
||||
(identifier? #'a)
|
||||
(syntax-pattern-variable? (syntax-local-value #'a (lambda () #f)))]
|
||||
[_
|
||||
(let ([k (prefab-struct-key (syntax-e tmpl))])
|
||||
(and k
|
||||
(let ([as (loop (cdr (vector->list (struct->vector (syntax-e tmpl))) in-ellipses?))])
|
||||
(and (or as (not const-leaf?))
|
||||
(make-prefab k as))
|
||||
#f)))])))
|
||||
|
||||
(define (template-map-collect tmap template s->d leaf->d pvar->d)
|
||||
(let loop ([tmap tmap][template template])
|
||||
(cond
|
||||
[(not tmap) (if (syntax? template)
|
||||
(box (leaf->d template))
|
||||
#f)]
|
||||
[(eq? tmap #t) (pvar->d template)]
|
||||
[(pair? tmap)
|
||||
(if (syntax? template)
|
||||
(vector (s->d template)
|
||||
(loop (car tmap) (stx-car template))
|
||||
(loop (cdr tmap) (stx-cdr template)))
|
||||
(cons (loop (car tmap) (stx-car template))
|
||||
(loop (cdr tmap) (stx-cdr template))))]
|
||||
[(vector? tmap)
|
||||
(cons (s->d template)
|
||||
(loop (vector-ref tmap 0)
|
||||
(vector->list (syntax-e template))))]
|
||||
[(box? tmap)
|
||||
(cons (s->d template)
|
||||
(loop (unbox tmap)
|
||||
(syntax-e template)))]
|
||||
[(ellipses? tmap)
|
||||
(let ([rest (let loop ([rest (stx-cdr template)]
|
||||
[count (ellipses-count tmap)])
|
||||
(if (zero? count)
|
||||
rest
|
||||
(loop (stx-cdr rest) (sub1 count))))])
|
||||
(if (syntax? template)
|
||||
(vector (s->d template)
|
||||
(loop (ellipses-elem tmap) (stx-car template))
|
||||
(loop (ellipses-rest tmap) rest))
|
||||
(cons (loop (ellipses-elem tmap) (stx-car template))
|
||||
(loop (ellipses-rest tmap) rest))))]
|
||||
[(prefab? tmap)
|
||||
(cons (s->d template)
|
||||
(loop (prefab-fields tmap)
|
||||
(cdr (vector->list (struct->vector (syntax-e template))))))]
|
||||
[else (error "template-map-collect fall-through")])))
|
||||
|
||||
(define (group-ellipses tmap template)
|
||||
(let loop ([tmap tmap][template template])
|
||||
(cond
|
||||
[(boolean? tmap) template]
|
||||
[(pair? tmap)
|
||||
(let ([p (cons (loop (car tmap) (stx-car template))
|
||||
(loop (cdr tmap) (stx-cdr template)))])
|
||||
(if (syntax? template)
|
||||
(datum->syntax* template p)
|
||||
p))]
|
||||
[(vector? tmap)
|
||||
(datum->syntax* template
|
||||
(list->vector
|
||||
(loop (vector-ref tmap 0)
|
||||
(vector->list (syntax-e template)))))]
|
||||
[(box? tmap)
|
||||
(datum->syntax* template
|
||||
(box
|
||||
(loop (unbox tmap)
|
||||
(syntax-e template))))]
|
||||
[(ellipses? tmap)
|
||||
(let ([rest
|
||||
(loop (ellipses-rest tmap)
|
||||
(let loop ([rest (stx-cdr template)]
|
||||
[count (ellipses-count tmap)])
|
||||
(if (zero? count)
|
||||
rest
|
||||
(loop (stx-cdr rest) (sub1 count)))))]
|
||||
[elem (loop (ellipses-elem tmap) (stx-car template))])
|
||||
(let ([new `((,elem ,@(for/list ([i (in-range (ellipses-count tmap))])
|
||||
#'(... ...)))
|
||||
. ,rest)])
|
||||
(if (syntax? template)
|
||||
(datum->syntax* template new)
|
||||
new)))]
|
||||
[(prefab? tmap)
|
||||
(datum->syntax*
|
||||
template
|
||||
(apply
|
||||
make-prefab-struct
|
||||
(prefab-key tmap)
|
||||
(loop (prefab-fields tmap)
|
||||
(cdr (vector->list (struct->vector (syntax-e template)))))))]
|
||||
[else (error "group-ellipses fall-through")])))
|
||||
|
||||
(define (transform-template template-stx
|
||||
#:save s->d
|
||||
#:restore-stx d->s
|
||||
#:leaf-save [leaf->d s->d]
|
||||
#:leaf-restore-stx [leaf->s #'(lambda (data stx) stx)]
|
||||
#:leaf-datum-stx [leaf-datum #'values]
|
||||
#:pvar-save [pvar->d (lambda (x) #f)]
|
||||
#:pvar-restore-stx [pvar->s #'(lambda (d s) s)]
|
||||
#:cons-stx [pcons cons]
|
||||
#:ellipses-end-stx [ellipses-end #'values]
|
||||
#:constant-as-leaf? [const-leaf? #f])
|
||||
(let* ([tmap (make-template-map template-stx const-leaf?)]
|
||||
[grouped-template
|
||||
;; Convert tmpl to group ...-created repetitions together,
|
||||
;; so that `unwrap' can tell which result came from which
|
||||
;; template:
|
||||
(group-ellipses tmap template-stx)]
|
||||
[data (template-map-collect tmap template-stx
|
||||
s->d leaf->d pvar->d)])
|
||||
#`(if #f
|
||||
;; Process tmpl first, so that syntax errors are reported
|
||||
;; usinf the original source.
|
||||
(syntax #,template-stx)
|
||||
;; Apply give d->s to result:
|
||||
(template-map-apply '#,tmap
|
||||
#,d->s #,leaf->s #,leaf-datum #,pvar->s #,pcons #,ellipses-end
|
||||
'#,data
|
||||
(syntax #,grouped-template)))))
|
||||
Loading…
Reference in New Issue
Block a user