merge syntax/parse's template into core (syntax, syntax/loc, etc)
This commit is contained in:
Ryan Culpepper
parent
2c627c300b
commit
8d607b83f9
|
|
@ -246,8 +246,6 @@
|
|||
(with-syntax ([(z ...) '()])
|
||||
(tloc quasitemplate/loc (z ... . 2) #f)) ;; zero iters + syntax tail => no relocation
|
||||
(tloc quasitemplate/loc (#,'a) #t)
|
||||
(tloc quasitemplate/loc #,'a #f)
|
||||
(tloc quasitemplate/loc (#,@(list 1 2 3)) #t)
|
||||
|
||||
;; Lazy attribute tests from test.rkt
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,17 @@
|
|||
(module ellipses '#%kernel
|
||||
(#%require (for-syntax '#%kernel))
|
||||
|
||||
(#%provide ... _)
|
||||
(#%provide ... _ ?? ?@)
|
||||
|
||||
(define-syntaxes (...)
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "ellipses not allowed as an expression" stx)))
|
||||
|
||||
(define-syntaxes (??)
|
||||
(lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx)))
|
||||
(define-syntaxes (?@)
|
||||
(lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx)))
|
||||
|
||||
(define-syntaxes (_)
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "wildcard not allowed as an expression" stx))))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
;; #%qqstx : quasisyntax
|
||||
|
||||
(module qqstx '#%kernel
|
||||
(#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt"
|
||||
(#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "template.rkt"
|
||||
(for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt"))
|
||||
|
||||
(#%provide quasisyntax
|
||||
|
|
@ -105,13 +105,11 @@
|
|||
[ctx (datum->syntax #'x 'ctx #'x)])
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list* (syntax temp)
|
||||
(quote-syntax ...)
|
||||
rest-v)
|
||||
(cons #'(?@! . temp) rest-v)
|
||||
stx
|
||||
stx)
|
||||
(with-syntax ([check check-splicing-list-id])
|
||||
(cons #'[(temp (... ...)) (check x (quote-syntax ctx))]
|
||||
(cons #'[temp (check x (quote-syntax ctx))]
|
||||
bindings)))))])
|
||||
(loop (syntax rest) depth
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -494,451 +494,6 @@
|
|||
`(cons/#f ,(cadr e1) ,e2)
|
||||
`(append/#f ,e1 ,e2)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; Output generator
|
||||
|
||||
;; Takes a syntax pattern, an environment prototype, and
|
||||
;; a keyword symbol list, and produces an expander
|
||||
;; that takes an environment and produces syntax.
|
||||
;;
|
||||
;; If the environment prototype is #f, it produces a list of
|
||||
;; variables used in the pattern, instead. This is useful for
|
||||
;; determining what kind of environment (and prototype) to construct
|
||||
;; for the pattern.
|
||||
;;
|
||||
;; An environment for an expander is a list*; see the note above,
|
||||
;; under "Input Matcher", for details.
|
||||
;;
|
||||
(-define (make-pexpand p proto-r k dest s-exp?)
|
||||
(-define top p)
|
||||
;; Helper function: avoid generating completely new symbols
|
||||
;; for substitution. Instead, try to generate normal symbols
|
||||
;; with a standard prefix, so that the symbols can be shared.
|
||||
(-define sub-gensym (let ([cnt 0]
|
||||
[prefix (let pfx-loop ([pfx "_pat"])
|
||||
(if (let loop ([p p])
|
||||
(cond
|
||||
[(symbol? p)
|
||||
(let ([s (symbol->string p)])
|
||||
(and ((string-length s) . > . (string-length pfx))
|
||||
(string=? pfx (substring s 0 (string-length pfx)))))]
|
||||
[(syntax? p) (loop (syntax-e p))]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[(vector? p) (loop (vector->list p))]
|
||||
[(box? p) (loop (unbox p))]
|
||||
[(struct? p) (loop (struct->vector p))]
|
||||
[else #f]))
|
||||
(pfx-loop (string-append "_" pfx))
|
||||
pfx))])
|
||||
(lambda ()
|
||||
(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! need-list?)
|
||||
(cond
|
||||
[(and use-ellipses? (ellipsis? p))
|
||||
(let*-values ([(p-head) (stx-car p)]
|
||||
[(el-count rest-p last-el)
|
||||
(let loop ([p (stx-cdr (stx-cdr p))][el-count 0][last-el (stx-car (stx-cdr p))])
|
||||
(if (and (stx-pair? p)
|
||||
(...? (stx-car p)))
|
||||
(loop (stx-cdr p) (add1 el-count) (stx-car p))
|
||||
(values el-count p last-el)))]
|
||||
[(p-head) (let loop ([el-count el-count])
|
||||
(if (zero? el-count)
|
||||
p-head
|
||||
(datum->syntax
|
||||
#f
|
||||
(list (loop (sub1 el-count)) (quote-syntax ...)))))]
|
||||
[(nestings) (and proto-r (get-ellipsis-nestings p-head k))])
|
||||
(when (null? nestings)
|
||||
(apply
|
||||
raise-syntax-error
|
||||
'syntax
|
||||
"no pattern variables before ellipsis in template"
|
||||
(pick-specificity
|
||||
top
|
||||
last-el)))
|
||||
(let* ([proto-rr+deep?s (and proto-r
|
||||
(map (lambda (nesting)
|
||||
(ellipsis-sub-env nesting proto-r top local-top))
|
||||
nestings))]
|
||||
[proto-rr-deep (and proto-r
|
||||
;; the ones that we had to unwrap:
|
||||
(let loop ([l proto-rr+deep?s])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(cdar l) (loop (cdr l))]
|
||||
[else (cons (caar l) (loop (cdr l)))])))]
|
||||
[proto-rr-shallow (and proto-r
|
||||
;; the ones that we leave alone for these ellipsis:
|
||||
(let loop ([l proto-rr+deep?s])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(cdar l) (cons (caar l) (loop (cdr l)))]
|
||||
[else (loop (cdr l))])))]
|
||||
[__ (unless (null? proto-rr-shallow)
|
||||
(when (null? proto-rr-deep)
|
||||
(apply
|
||||
raise-syntax-error
|
||||
'syntax
|
||||
"too many ellipses in template"
|
||||
(pick-specificity
|
||||
top
|
||||
last-el))))]
|
||||
[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
|
||||
(let ([valses
|
||||
;; Generate one binding per nested use. This will duplicate
|
||||
;; bindings if a pattern variable is used multiple times; that's
|
||||
;; good if the uses are in different nesting levels (which could be
|
||||
;; ok if there are extra ellipses around them), but it might also
|
||||
;; create redundant entries.
|
||||
(map (lambda (var)
|
||||
(apply-list-ref 'r (stx-memq*-pos (list var) proto-r) use-tail-pos))
|
||||
proto-rr-deep)])
|
||||
(cond
|
||||
[(and (= 1 (length valses))
|
||||
(= 0 el-count)
|
||||
(null? proto-rr-shallow)
|
||||
(equal? ehead '(lambda (r) (car r))))
|
||||
;; Common case: one item in list, no map needed:
|
||||
(car valses)]
|
||||
[(and (= 2 (length valses))
|
||||
(= 0 el-count)
|
||||
(null? proto-rr-shallow)
|
||||
(equal? ehead '(lambda (r) (list (car r) (cadr r)))))
|
||||
;; Another common case: a maintained pair
|
||||
`(map
|
||||
(lambda (a b) (list a b))
|
||||
,@valses)]
|
||||
[else
|
||||
;; General case:
|
||||
(letrec ([wrap (lambda (expr el-count)
|
||||
(if (zero? el-count)
|
||||
expr
|
||||
(wrap `(apply append ,expr)
|
||||
(sub1 el-count))))])
|
||||
(wrap
|
||||
`(map
|
||||
(lambda vals
|
||||
(,ehead
|
||||
,(if (null? proto-rr-shallow)
|
||||
'vals
|
||||
'(append shallows vals))))
|
||||
,@valses)
|
||||
el-count))]))])
|
||||
(if (null? proto-rr-shallow)
|
||||
deeps
|
||||
`(let ([shallows
|
||||
(list ,@(map (lambda (var)
|
||||
(apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos))
|
||||
proto-rr-shallow))])
|
||||
,deeps)))]
|
||||
[post (apply-to-r rest)])
|
||||
(let ([v (if (eq? post 'null)
|
||||
pre
|
||||
`(append ,pre ,post))])
|
||||
(if (and (not need-list?) (syntax? p) (not s-exp?))
|
||||
;; 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)
|
||||
(let ([hd (stx-car p)])
|
||||
(if (and use-ellipses?
|
||||
(...? hd))
|
||||
(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! need-list?))
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"misplaced ellipsis in template"
|
||||
top
|
||||
hd))
|
||||
(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 s-exp?))
|
||||
;; 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! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e))))
|
||||
;; variables were hashed
|
||||
(void)))]
|
||||
[(stx-box? p)
|
||||
(let ([e (expander (unbox (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(box (,(if s-exp? 'values 'syntax-e) ,(apply-to-r e))))
|
||||
;; variables were hashed
|
||||
(void)))]
|
||||
[(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! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(apply make-prefab-struct ',(prefab-struct-key (syntax-e p))
|
||||
(,(if s-exp? 'values 'stx->list) ,(apply-to-r e))))
|
||||
;; variables were hashed
|
||||
(void)))]
|
||||
[(identifier? p)
|
||||
(if (stx-memq p k)
|
||||
(if proto-r
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))
|
||||
(void))
|
||||
(if proto-r
|
||||
(let ((x (stx-memq p proto-r)))
|
||||
(if x
|
||||
`(lambda (r) ,(apply-list-ref 'r (stx-memq-pos p proto-r) use-tail-pos))
|
||||
(begin
|
||||
(when (and use-ellipses?
|
||||
(...? p))
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"misplaced ellipsis in template"
|
||||
top
|
||||
p))
|
||||
(check-not-pattern p proto-r)
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)))))
|
||||
(unless (and (...? p)
|
||||
use-ellipses?)
|
||||
(hash! p))))]
|
||||
[(null? p)
|
||||
;; Not syntax, so avoid useless syntax info
|
||||
(if proto-r
|
||||
`(lambda (r) null)
|
||||
(void))]
|
||||
[else (if proto-r
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))
|
||||
(void))]))
|
||||
(let* ([ht (if proto-r
|
||||
#f
|
||||
(make-hasheq))]
|
||||
[in-order null] ; same content as ht, but in deterministic order
|
||||
[l (expander p proto-r p #t
|
||||
(and proto-r (sub1 (length proto-r)))
|
||||
(if proto-r
|
||||
#f
|
||||
(lambda (r)
|
||||
(let ([l (hash-ref ht (syntax-e r) null)])
|
||||
(let ([pr (and (pair? l)
|
||||
(ormap (lambda (i)
|
||||
(and (bound-identifier=? (mcar i) r) i))
|
||||
l))])
|
||||
(if pr
|
||||
(set-mcdr! pr (cons r (mcdr pr)))
|
||||
(let ([pr (mcons r (list r))])
|
||||
(set! in-order (cons pr in-order))
|
||||
(hash-set! ht (syntax-e r) (cons pr l))))))))
|
||||
#f)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
,(let ([main (let ([build (apply-to-r l)])
|
||||
(if (or s-exp?
|
||||
(and (pair? build)
|
||||
(eq? (car build) 'pattern-substitute)))
|
||||
build
|
||||
(let ([small-dest ;; In case dest has significant structure...
|
||||
(and dest (datum->syntax
|
||||
dest
|
||||
'dest
|
||||
dest
|
||||
dest))])
|
||||
`(datum->syntax/shape (quote-syntax ,small-dest)
|
||||
,build))))])
|
||||
(if (multiple-ellipsis-vars? p proto-r)
|
||||
`(catch-ellipsis-error
|
||||
(lambda () ,main)
|
||||
(quote ,p)
|
||||
;; This is a trick to minimize the syntax structure we keep:
|
||||
(quote-syntax ,(datum->syntax #f '... p)))
|
||||
main)))
|
||||
(let ([l in-order])
|
||||
(values
|
||||
;; Get list of unique vars:
|
||||
(map mcar l)
|
||||
;; All ids, including duplicates:
|
||||
(map mcdr l))))))
|
||||
|
||||
;; apply-to-r creates an S-expression that applies
|
||||
;; rest to `r', but it also optimizes ((lambda (r) E) r)
|
||||
;; as simply E.
|
||||
(-define (apply-to-r rest)
|
||||
(if (and (pair? rest)
|
||||
(eq? (car rest) 'lambda)
|
||||
(equal? (cadr rest) '(r)))
|
||||
(caddr rest)
|
||||
`(,rest r)))
|
||||
|
||||
;; creates an S-expression that conses h and t,
|
||||
;; with optimizations. If h and t are quoted
|
||||
;; versions of the car and cdr of p, then return
|
||||
;; a quoted as the "optimization" --- one that
|
||||
;; is necessary to preserve the syntax wraps
|
||||
;; associated with p.
|
||||
(-define (apply-cons stx h t p sub-gensym s-exp?)
|
||||
(cond
|
||||
[(and (pair? h)
|
||||
(if s-exp?
|
||||
(eq? (car h) 'quote)
|
||||
(eq? (car h) 'quote-syntax))
|
||||
(eq? (cadr h) (stx-car p))
|
||||
(or (eq? t 'null)
|
||||
(and
|
||||
(pair? t)
|
||||
(eq? (car t) (car h))
|
||||
(eq? (cadr t) (stx-cdr p)))))
|
||||
`(,(if s-exp? 'quote 'quote-syntax) ,p)]
|
||||
[(and (pair? t)
|
||||
(eq? (car t) 'pattern-substitute))
|
||||
;; fold h into the existing pattern-substitute:
|
||||
(cond
|
||||
[(and (pair? h)
|
||||
(or (eq? (car h) 'quote-syntax)
|
||||
(eq? (car h) 'quote))
|
||||
(eq? (cadr h) (stx-car p)))
|
||||
;; Just extend constant part:
|
||||
`(pattern-substitute
|
||||
(,(if s-exp? 'quote 'quote-syntax)
|
||||
,(let ([v (cons (cadr h) (cadadr t))])
|
||||
;; We exploit the fact that we're
|
||||
;; building an S-expression to
|
||||
;; preserve the source's distinction
|
||||
;; between (x y) and (x . (y)).
|
||||
(if (syntax? stx)
|
||||
(datum->syntax stx
|
||||
v
|
||||
stx
|
||||
stx
|
||||
stx)
|
||||
v)))
|
||||
. ,(cddr t))]
|
||||
[(and (pair? h)
|
||||
(eq? (car t) #| = 'pattern-substitute |# (car h)))
|
||||
;; Combine two pattern substitutions:
|
||||
`(pattern-substitute
|
||||
(,(if s-exp? 'quote 'quote-syntax)
|
||||
,(let ([v (cons (cadadr h) (cadadr t))])
|
||||
(if (syntax? stx)
|
||||
(datum->syntax stx
|
||||
v
|
||||
stx
|
||||
stx
|
||||
stx)
|
||||
v)))
|
||||
,@(cddr h) ;; <-- WARNING: potential quadratic expansion
|
||||
. ,(cddr t))]
|
||||
[else
|
||||
;; General case: add a substitution:
|
||||
(let* ([id (sub-gensym)]
|
||||
[expr (cons id (cadadr t))]
|
||||
[expr (if (syntax? stx)
|
||||
(datum->syntax stx
|
||||
expr
|
||||
stx
|
||||
stx
|
||||
stx)
|
||||
expr)])
|
||||
`(pattern-substitute
|
||||
(,(if s-exp? 'quote 'quote-syntax) ,expr)
|
||||
,id ,h
|
||||
. ,(cddr t)))])]
|
||||
[(not s-exp?)
|
||||
(cond
|
||||
[(eq? t 'null)
|
||||
(apply-cons stx h
|
||||
`(pattern-substitute (quote-syntax ()))
|
||||
p
|
||||
sub-gensym
|
||||
s-exp?)]
|
||||
|
||||
[(and (pair? t)
|
||||
(eq? (car t) 'quote-syntax)
|
||||
(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.)
|
||||
(apply-cons stx h
|
||||
`(pattern-substitute ,t)
|
||||
p
|
||||
sub-gensym
|
||||
s-exp?)]
|
||||
[else
|
||||
;; Shift into `pattern-substitute' with an initial substitution:
|
||||
(apply-cons stx h
|
||||
(let ([id (sub-gensym)])
|
||||
`(pattern-substitute (quote-syntax ,id)
|
||||
,id ,t))
|
||||
p
|
||||
sub-gensym
|
||||
s-exp?)])]
|
||||
[else
|
||||
;; In S-expression mode, `cons' on, but collapse to `list'
|
||||
;; or `list*' if possible:
|
||||
(cond
|
||||
[(eq? t 'null)
|
||||
(list 'list h)]
|
||||
[(and (pair? t)
|
||||
(eq? (car t) 'list))
|
||||
(list* 'list h (cdr t))]
|
||||
[(and (pair? t)
|
||||
(or (eq? (car t) 'list*)
|
||||
(eq? (car t) 'cons)))
|
||||
(list* 'list* h (cdr t))]
|
||||
[else
|
||||
(list 'cons h t)])]))
|
||||
|
||||
(-define (stx-smaller-than? stx sz)
|
||||
(sz . > . (stx-size stx (add1 sz))))
|
||||
|
||||
(-define (stx-size stx up-to)
|
||||
(cond
|
||||
[(up-to . < . 1) 0]
|
||||
[(syntax? stx) (stx-size (syntax-e stx) up-to)]
|
||||
[(pair? stx) (let ([s1 (stx-size (car stx) up-to)])
|
||||
(+ s1 (stx-size (cdr stx) (- up-to s1))))]
|
||||
[(vector? stx) (stx-size (vector->list stx) up-to)]
|
||||
[(struct? stx) (stx-size (struct->vector stx) up-to)]
|
||||
[(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))]
|
||||
[else 1]))
|
||||
|
||||
;; Generates a list-ref expression; if use-tail-pos
|
||||
;; is not #f, then the argument list is really a list*
|
||||
;; (see the note under "Input Matcher") and in that case
|
||||
;; use-tail-pos is a number indicating the list-tail
|
||||
;; position of the last element
|
||||
(-define (apply-list-ref e p use-tail-pos)
|
||||
(cond
|
||||
[(and use-tail-pos (= p use-tail-pos))
|
||||
(cond
|
||||
[(eq? p 0) e]
|
||||
[(eq? p 1) `(cdr ,e)]
|
||||
[(eq? p 2) `(cddr ,e)]
|
||||
[(eq? p 3) `(cdddr ,e)]
|
||||
[(eq? p 4) `(cddddr ,e)]
|
||||
[else `(list-tail ,e ,p)])]
|
||||
[(eq? p 0) `(car ,e)]
|
||||
[(eq? p 1) `(cadr ,e)]
|
||||
[(eq? p 2) `(caddr ,e)]
|
||||
[(eq? p 3) `(cadddr ,e)]
|
||||
[else `(list-ref ,e ,p)]))
|
||||
|
||||
;; Returns a list that nests a pattern variable as deeply as it
|
||||
;; is ellipsed. Escaping ellipses are detected.
|
||||
(-define get-ellipsis-nestings
|
||||
|
|
@ -978,72 +533,6 @@
|
|||
(sub (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipses?)]
|
||||
[else '()]))))
|
||||
|
||||
;; Checks whether the given nesting matches a nesting in the
|
||||
;; environment prototype, returning the prototype entry if it is
|
||||
;; found, and signaling an error otherwise. If the prototype
|
||||
;; entry should be unwrapped by one, it is, and the resulting
|
||||
;; prototype is paired with #f. Otherwise, the prototype is left
|
||||
;; alone and paired with #t. There may be multiple matches; in that
|
||||
;; case, prefer unwrapping to not unwrapping (because the other one
|
||||
;; must be for a different sub-template nuder a shared ellipsis).
|
||||
(-define ellipsis-sub-env
|
||||
(lambda (nesting proto-r src detail-src)
|
||||
(let ([vs (map (lambda (proto)
|
||||
(let ([start (if (pair? proto)
|
||||
(car proto)
|
||||
proto)])
|
||||
(let loop ([c start] [n nesting] [unwrap? (pair? proto)])
|
||||
(cond
|
||||
[(and (pair? c) (pair? n))
|
||||
(loop (car c) (car n) #t)]
|
||||
[(pair? n)
|
||||
(loop c (car n) #f)]
|
||||
[(and (syntax? c) (syntax? n))
|
||||
(if (bound-identifier=? c n)
|
||||
(cons (if unwrap? start proto)
|
||||
(not unwrap?))
|
||||
#f)]
|
||||
[else #f]))))
|
||||
proto-r)])
|
||||
(unless (ormap values vs)
|
||||
(apply
|
||||
raise-syntax-error
|
||||
'syntax
|
||||
"too few ellipses for pattern variable in template"
|
||||
(pick-specificity
|
||||
src
|
||||
(let loop ([n nesting])
|
||||
(if (syntax? n)
|
||||
n
|
||||
(loop (car n)))))))
|
||||
(or (ormap (lambda (v) (and v (not (cdr v)) v)) vs)
|
||||
(ormap values vs)))))
|
||||
|
||||
(-define (extract-vars proto-r)
|
||||
(map (lambda (i)
|
||||
(let loop ([i i])
|
||||
(if (syntax? i)
|
||||
i
|
||||
(loop (car i)))))
|
||||
proto-r))
|
||||
|
||||
;; Checks that a variable is not in the prototype
|
||||
;; environment, and specifically not an ellipsed
|
||||
;; variable.
|
||||
(-define (check-not-pattern ssym proto-r)
|
||||
(for-each (lambda (p)
|
||||
(when (pair? p)
|
||||
(let loop ([l (car p)])
|
||||
(cond
|
||||
[(syntax? l)
|
||||
(when (bound-identifier=? l ssym)
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"missing ellipsis with pattern variable in template"
|
||||
ssym))]
|
||||
[else (loop (car l))]))))
|
||||
proto-r))
|
||||
|
||||
;; Tests if x is an ellipsing pattern of the form
|
||||
;; (blah ... . blah2)
|
||||
(-define (ellipsis? x)
|
||||
|
|
@ -1067,77 +556,6 @@
|
|||
(loop (cdr nestings)))
|
||||
(loop (cdr nestings))))))
|
||||
|
||||
;; Determines whether any ellipsis has multiple pattern
|
||||
;; variables so that a run-time check on the pattern-variable
|
||||
;; matching length will be needed
|
||||
(-define (multiple-ellipsis-vars? p proto-r)
|
||||
(let loop ([p p])
|
||||
(cond
|
||||
[(ellipsis? p)
|
||||
(or (eq? 'multi (multiple-pattern-vars (stx-car p) proto-r))
|
||||
(loop (stx-cdr (stx-cdr p))))]
|
||||
[(stx-pair? p)
|
||||
(let ([hd (stx-car p)])
|
||||
(if (and (identifier? hd)
|
||||
(...? hd))
|
||||
#f
|
||||
(or (loop hd)
|
||||
(loop (stx-cdr p)))))]
|
||||
[(stx-vector? p #f)
|
||||
(loop (vector->list (syntax-e p)))]
|
||||
[(stx-box? p)
|
||||
(loop (unbox (syntax-e p)))]
|
||||
[(and (syntax? p)
|
||||
(prefab-struct-key (syntax-e p)))
|
||||
(loop (cdr (vector->list (struct->vector (syntax-e p)))))]
|
||||
[else #f])))
|
||||
|
||||
;; Determines whether a given expression, which is under ellipses,
|
||||
;; has multiple pattern variables or the same variable at different
|
||||
;; depths; returns 'multi if so, some other internal accumulator otherwise
|
||||
(-define (multiple-pattern-vars p proto-r)
|
||||
(let loop ([p p] [use-ellipsis? #t] [depth 0] [found #f])
|
||||
(cond
|
||||
[(identifier? p)
|
||||
(if (ormap (lambda (l)
|
||||
(and
|
||||
(pair? l) ;; only need to track repeats
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(syntax? l)
|
||||
(bound-identifier=? l p)]
|
||||
[else (loop (car l))]))))
|
||||
proto-r)
|
||||
(cond
|
||||
[(not found) (cons p depth)]
|
||||
[(and (bound-identifier=? p (car found))
|
||||
(= depth (cdr found)))
|
||||
found]
|
||||
[else 'multi])
|
||||
found)]
|
||||
[(and use-ellipsis? (ellipsis? p))
|
||||
(let ([new-found (loop (stx-car p) #t (add1 depth) found)])
|
||||
(if (eq? new-found 'multi)
|
||||
new-found
|
||||
(loop (stx-cdr (stx-cdr p)) #t depth new-found)))]
|
||||
[(stx-pair? p)
|
||||
(let ([hd (stx-car p)])
|
||||
(if (and (identifier? hd)
|
||||
(...? hd))
|
||||
(loop (stx-cdr p) #f depth found)
|
||||
(let ([new-found (loop (stx-car p) #t depth found)])
|
||||
(if (eq? new-found 'multi)
|
||||
new-found
|
||||
(loop (stx-cdr p) #t depth new-found)))))]
|
||||
[(stx-vector? p #f)
|
||||
(loop (vector->list (syntax-e p)) use-ellipsis? depth found)]
|
||||
[(stx-box? p)
|
||||
(loop (unbox (syntax-e p)) use-ellipsis? depth found)]
|
||||
[(and (syntax? p)
|
||||
(prefab-struct-key (syntax-e p)))
|
||||
(loop (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipsis? depth found)]
|
||||
[else found])))
|
||||
|
||||
(-define (no-ellipses? stx)
|
||||
(cond
|
||||
[(stx-pair? stx)
|
||||
|
|
@ -1188,7 +606,6 @@
|
|||
(s-exp-mapping-ref (set!-transformer-procedure v) 1))
|
||||
|
||||
(#%provide (protect make-match&env get-match-vars make-interp-match
|
||||
make-pexpand
|
||||
make-syntax-mapping syntax-pattern-variable?
|
||||
syntax-mapping-depth syntax-mapping-valvar
|
||||
make-s-exp-mapping s-exp-pattern-variable?
|
||||
|
|
|
|||
|
|
@ -7,129 +7,6 @@
|
|||
(for-syntax "stx.rkt" "small-scheme.rkt"
|
||||
"member.rkt" "sc.rkt" '#%kernel))
|
||||
|
||||
(-define (datum->syntax/shape orig datum)
|
||||
(if (syntax? datum)
|
||||
datum
|
||||
;; Keeps 'paren-shape and any other properties:
|
||||
(datum->syntax orig datum orig orig)))
|
||||
|
||||
(-define (catch-ellipsis-error thunk sexp sloc)
|
||||
((let/ec esc
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(lambda (exn)
|
||||
(esc
|
||||
(lambda ()
|
||||
(if (exn:break? exn)
|
||||
(raise exn)
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"incompatible ellipsis match counts for template"
|
||||
sexp
|
||||
sloc)))))
|
||||
(let ([v (thunk)])
|
||||
(lambda () v))))))
|
||||
|
||||
(-define substitute-stop 'dummy)
|
||||
|
||||
;; pattern-substitute optimizes a pattern substitution by
|
||||
;; merging variables that look up the same simple mapping
|
||||
(-define-syntax pattern-substitute
|
||||
(lambda (stx)
|
||||
(let ([pat (stx-car (stx-cdr stx))]
|
||||
[subs (stx->list (stx-cdr (stx-cdr stx)))])
|
||||
(let ([ht-common (make-hash)]
|
||||
[ht-map (make-hasheq)])
|
||||
;; Determine merges:
|
||||
(let loop ([subs subs])
|
||||
(unless (null? subs)
|
||||
(let ([id (syntax-e (car subs))]
|
||||
[expr (cadr subs)])
|
||||
(when (or (identifier? expr)
|
||||
(and (stx-pair? expr)
|
||||
(memq (syntax-e (stx-car expr))
|
||||
'(car cadr caddr cadddr
|
||||
cdr cddr cdddr cddddr
|
||||
list-ref list-tail))
|
||||
(stx-pair? (stx-cdr expr))
|
||||
(identifier? (stx-car (stx-cdr expr)))))
|
||||
(let ([s-expr (syntax->datum expr)])
|
||||
(let ([new-id (hash-ref ht-common s-expr #f)])
|
||||
(if new-id
|
||||
(hash-set! ht-map id new-id)
|
||||
(hash-set! ht-common s-expr id))))))
|
||||
(loop (cddr subs))))
|
||||
;; Merge:
|
||||
(let ([new-pattern (if (zero? (hash-count ht-map))
|
||||
pat
|
||||
(let loop ([stx pat])
|
||||
(cond
|
||||
[(pair? stx)
|
||||
(let ([a (loop (car stx))]
|
||||
[b (loop (cdr stx))])
|
||||
(if (and (eq? a (car stx))
|
||||
(eq? b (cdr stx)))
|
||||
stx
|
||||
(cons a b)))]
|
||||
[(symbol? stx)
|
||||
(let ([new-id (hash-ref ht-map stx #f)])
|
||||
(or new-id stx))]
|
||||
[(syntax? stx)
|
||||
(let ([new-e (loop (syntax-e stx))])
|
||||
(if (eq? (syntax-e stx) new-e)
|
||||
stx
|
||||
(datum->syntax stx new-e stx stx)))]
|
||||
[(vector? stx)
|
||||
(list->vector (map loop (vector->list stx)))]
|
||||
[(box? stx) (box (loop (unbox stx)))]
|
||||
[else stx])))])
|
||||
(datum->syntax (quote-syntax here)
|
||||
`(apply-pattern-substitute
|
||||
,new-pattern
|
||||
(quote ,(let loop ([subs subs])
|
||||
(cond
|
||||
[(null? subs) null]
|
||||
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
||||
;; Drop mapped id
|
||||
(loop (cddr subs))]
|
||||
[else
|
||||
(cons (car subs) (loop (cddr subs)))])))
|
||||
. ,(let loop ([subs subs])
|
||||
(cond
|
||||
[(null? subs) null]
|
||||
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
||||
;; Drop mapped id
|
||||
(loop (cddr subs))]
|
||||
[else
|
||||
(cons (cadr subs) (loop (cddr subs)))])))
|
||||
stx))))))
|
||||
|
||||
(-define apply-pattern-substitute
|
||||
(lambda (stx sub-ids . sub-vals)
|
||||
(let loop ([stx stx])
|
||||
(cond
|
||||
[(pair? stx) (let ([a (loop (car stx))]
|
||||
[b (loop (cdr stx))])
|
||||
(if (and (eq? a (car stx))
|
||||
(eq? b (cdr stx)))
|
||||
stx
|
||||
(cons a b)))]
|
||||
[(symbol? stx)
|
||||
(let sloop ([sub-ids sub-ids][sub-vals sub-vals])
|
||||
(cond
|
||||
[(null? sub-ids) stx]
|
||||
[(eq? stx (car sub-ids)) (car sub-vals)]
|
||||
[else (sloop (cdr sub-ids) (cdr sub-vals))]))]
|
||||
[(syntax? stx)
|
||||
(let ([new-e (loop (syntax-e stx))])
|
||||
(if (eq? (syntax-e stx) new-e)
|
||||
stx
|
||||
(datum->syntax/shape stx new-e)))]
|
||||
[(vector? stx)
|
||||
(list->vector (map loop (vector->list stx)))]
|
||||
[(box? stx) (box (loop (unbox stx)))]
|
||||
[else stx]))))
|
||||
|
||||
(-define interp-match
|
||||
(lambda (pat e literals immediate=?)
|
||||
(interp-gen-match pat e literals immediate=? #f)))
|
||||
|
|
@ -502,103 +379,6 @@
|
|||
m))))])))
|
||||
x)))))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-values (gen-template)
|
||||
(lambda (x s-exp?)
|
||||
(-define here-stx (quote-syntax here))
|
||||
(unless (and (stx-pair? x)
|
||||
(let ([rest (stx-cdr x)])
|
||||
(and (stx-pair? rest)
|
||||
(stx-null? (stx-cdr rest)))))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad form"
|
||||
x))
|
||||
(syntax-arm
|
||||
(datum->syntax
|
||||
here-stx
|
||||
(let ([pattern (stx-car (stx-cdr x))])
|
||||
(let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)])
|
||||
(let ([var-bindings
|
||||
(map
|
||||
(lambda (var)
|
||||
(and (let ([v (syntax-local-value var (lambda () #f))])
|
||||
(and (if s-exp?
|
||||
(s-exp-pattern-variable? v)
|
||||
(syntax-pattern-variable? v))
|
||||
v))))
|
||||
unique-vars)])
|
||||
(if (and (or (null? var-bindings)
|
||||
(not (ormap (lambda (x) x) var-bindings)))
|
||||
(no-ellipses? pattern))
|
||||
;; Constant template:
|
||||
(list (if s-exp?
|
||||
(quote-syntax quote)
|
||||
(quote-syntax quote-syntax))
|
||||
pattern)
|
||||
;; Non-constant:
|
||||
(let ([proto-r (let loop ([vars unique-vars][bindings var-bindings])
|
||||
(if (null? bindings)
|
||||
null
|
||||
(let ([rest (loop (cdr vars)
|
||||
(cdr bindings))])
|
||||
(if (car bindings)
|
||||
(cons (let loop ([v (car vars)]
|
||||
[d (if s-exp?
|
||||
(s-exp-mapping-depth (car bindings))
|
||||
(syntax-mapping-depth (car bindings)))])
|
||||
(if (zero? d)
|
||||
v
|
||||
(loop (list v) (sub1 d))))
|
||||
rest)
|
||||
rest))))]
|
||||
[non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings])
|
||||
(if (null? bindings)
|
||||
null
|
||||
(let ([rest (loop (cdr vars)
|
||||
(cdr bindings))])
|
||||
(if (car bindings)
|
||||
rest
|
||||
(cons (car vars) rest)))))])
|
||||
(let ([build-from-template
|
||||
;; Even if we don't use the builder, we need to check
|
||||
;; for a well-formed pattern:
|
||||
(make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)]
|
||||
[r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss])
|
||||
(cond
|
||||
[(null? bindings) null]
|
||||
[(car bindings)
|
||||
(cons
|
||||
(syntax-property
|
||||
(let ([id (if s-exp?
|
||||
(s-exp-mapping-valvar (car bindings))
|
||||
(syntax-mapping-valvar (car bindings)))])
|
||||
(datum->syntax
|
||||
id
|
||||
(syntax-e id)
|
||||
x))
|
||||
'disappeared-use
|
||||
(map syntax-local-introduce (car all-varss)))
|
||||
(loop (cdr vars) (cdr bindings) (cdr all-varss)))]
|
||||
[else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))])
|
||||
(if (identifier? pattern)
|
||||
;; Simple syntax-id lookup:
|
||||
(car r)
|
||||
;; General case:
|
||||
(list (datum->syntax
|
||||
here-stx
|
||||
build-from-template
|
||||
pattern)
|
||||
(let ([len (length r)])
|
||||
(cond
|
||||
[(zero? len) (quote-syntax ())]
|
||||
[(= len 1) (car r)]
|
||||
[else
|
||||
(cons (quote-syntax list*) r)]))))))))))
|
||||
x)))))
|
||||
|
||||
(-define-syntax syntax (lambda (stx) (gen-template stx #f)))
|
||||
(-define-syntax datum (lambda (stx) (gen-template stx #t)))
|
||||
|
||||
(#%provide (all-from "ellipses.rkt") syntax-case** syntax datum
|
||||
(#%require "template.rkt")
|
||||
(#%provide (all-from "ellipses.rkt") syntax-case** syntax syntax/loc datum
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
|
|
|
|||
|
|
@ -35,28 +35,6 @@
|
|||
[(sc stxe kl . clause)
|
||||
(transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)])))
|
||||
|
||||
(-define (relocate loc stx)
|
||||
(if (or (syntax-source loc)
|
||||
(syntax-position loc))
|
||||
(datum->syntax stx
|
||||
(syntax-e stx)
|
||||
loc
|
||||
stx)
|
||||
stx))
|
||||
|
||||
;; Like syntax, but also takes a syntax object
|
||||
;; that supplies a source location for the
|
||||
;; resulting syntax object.
|
||||
(-define-syntax syntax/loc
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
[(_ loc pattern)
|
||||
(if (if (symbol? (syntax-e #'pattern))
|
||||
(syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f)))
|
||||
#f)
|
||||
(syntax (syntax pattern))
|
||||
(syntax (relocate loc (syntax pattern))))])))
|
||||
|
||||
(-define-syntax quote-syntax/prune
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
|
|
@ -77,4 +55,5 @@
|
|||
stx
|
||||
#'id))])))
|
||||
|
||||
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _))
|
||||
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case
|
||||
... _ ?? ?@))
|
||||
|
|
|
|||
716
racket/collects/racket/private/template.rkt
Normal file
716
racket/collects/racket/private/template.rkt
Normal file
|
|
@ -0,0 +1,716 @@
|
|||
(module template '#%kernel
|
||||
(#%require "stx.rkt" "small-scheme.rkt" "performance-hint.rkt"
|
||||
(rename "small-scheme.rkt" define -define)
|
||||
(rename "small-scheme.rkt" define-syntax -define-syntax)
|
||||
"ellipses.rkt"
|
||||
(for-syntax "stx.rkt" "small-scheme.rkt"
|
||||
(rename "small-scheme.rkt" define -define)
|
||||
(rename "small-scheme.rkt" define-syntax -define-syntax)
|
||||
"member.rkt" "sc.rkt" '#%kernel))
|
||||
(#%provide syntax
|
||||
syntax/loc
|
||||
datum
|
||||
?? ?@
|
||||
?@! signal-absent-pvar
|
||||
(protect
|
||||
(for-syntax attribute-mapping
|
||||
attribute-mapping?
|
||||
attribute-mapping-name
|
||||
attribute-mapping-var
|
||||
attribute-mapping-depth
|
||||
attribute-mapping-check
|
||||
metafunction metafunction?)))
|
||||
|
||||
;; ============================================================
|
||||
;; Syntax of templates
|
||||
|
||||
;; A Template (T) is one of:
|
||||
;; - pattern-variable
|
||||
;; - constant (including () and non-pvar identifiers)
|
||||
;; - (metafunction . T)
|
||||
;; - (H . T)
|
||||
;; - (H ... . T), (H ... ... . T), etc
|
||||
;; - (... T) -- escapes inner ..., ??, ?@
|
||||
;; - (?? T T)
|
||||
;; - #(T*) -- actually, vector->list interpreted as T
|
||||
;; - #s(prefab-struct-key T*) -- likewise
|
||||
|
||||
;; A HeadTemplate (H) is one of:
|
||||
;; - T
|
||||
;; - (?? H)
|
||||
;; - (?? H H)
|
||||
;; - (?@ . T)
|
||||
|
||||
(define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing
|
||||
|
||||
;; ============================================================
|
||||
;; Compile-time
|
||||
|
||||
;; Parse template syntax into a Guide (AST--the name is left over from
|
||||
;; when the "guide" was a data structure interpreted at run time).
|
||||
|
||||
;; The AST representation is designed to coincide with the run-time
|
||||
;; support, so compilation is just (datum->syntax #'here guide). The
|
||||
;; variants listed below are the ones recognized and treated specially
|
||||
;; by other functions (eg optimize-resyntax, relocate-guide).
|
||||
|
||||
;; A Guide (G) is one of:
|
||||
;; - (list 't-resyntax Expr Expr G)
|
||||
;; - (list 't-const Expr) ;; constant
|
||||
;; - (list 't-var Id) ;; trusted pattern variable
|
||||
;; - (list 't-list G ...)
|
||||
;; - (list 't-list* G ... G)
|
||||
;; - (list 't-append HG G)
|
||||
;; - (list 't-orelse G G)
|
||||
;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions
|
||||
;; -- where Subst = Nat ;; replace nth car with arg
|
||||
;; | 'tail Nat ;; replace nth cdr with arg
|
||||
;; | 'append Nat ;; replace nth car by appending arg
|
||||
;; | 'recur Nat ;; replace nth car by recurring on it with arg
|
||||
;; - other expression (must be pair!)
|
||||
|
||||
;; A HeadGuide (HG) is one of:
|
||||
;; - (list 'h-t G)
|
||||
;; - other expression (must be pair!)
|
||||
|
||||
;; A PVar is (pvar Id Id Id/#f Nat/#f)
|
||||
;;
|
||||
;; The first identifier (var) is from the syntax-mapping or attribute-binding.
|
||||
;; The second (lvar) is a local variable name used to hold its value (or parts
|
||||
;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a
|
||||
;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see
|
||||
;; below) if it needs to be checked.
|
||||
;;
|
||||
;; The depth-delta associated with a depth>0 pattern variable is the difference
|
||||
;; between the pattern variable's depth and the depth at which it is used. (For
|
||||
;; depth 0 pvars, it's #f.) For example, in
|
||||
;;
|
||||
;; (with-syntax ([x #'0]
|
||||
;; [(y ...) #'(1 2)]
|
||||
;; [((z ...) ...) #'((a b) (c d))])
|
||||
;; (template (((x y z) ...) ...)))
|
||||
;;
|
||||
;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta
|
||||
;; for z is 0. The depth-delta (or depth "delay") is also the depth of the
|
||||
;; ellipsis form where the variable begins to be iterated over. That is, the
|
||||
;; template above should be interpreted roughly as
|
||||
;;
|
||||
;; (let ([Lx (pvar-value-of x)]
|
||||
;; [Ly (pvar-value-of y)]
|
||||
;; [Lz (pvar-value-of z)])
|
||||
;; (for/list ([Lz (in-list Lz)]) ;; depth 0
|
||||
;; (for/list ([Ly (in-list Ly)] ;; depth 1
|
||||
;; [Lz (in-list Lz)])
|
||||
;; (___ Lx Ly Lz ___))))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define here-stx (quote-syntax here))
|
||||
|
||||
(define template-logger (make-logger 'template (current-logger)))
|
||||
|
||||
;; (struct pvar (var lvar check dd) #:prefab)
|
||||
(define-values (struct:pv pvar pvar? pvar-ref pvar-set!)
|
||||
(make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3)))
|
||||
(define (pvar-var pv) (pvar-ref pv 0))
|
||||
(define (pvar-lvar pv) (pvar-ref pv 1))
|
||||
(define (pvar-check pv) (pvar-ref pv 2))
|
||||
(define (pvar-dd pv) (pvar-ref pv 3))
|
||||
|
||||
;; An Attribute is an identifier statically bound to a syntax-mapping
|
||||
;; (see sc.rkt) whose valvar is an identifier statically bound to an
|
||||
;; attribute-mapping.
|
||||
|
||||
;; (struct attribute-mapping (var name depth check) ...)
|
||||
;; check : #f (trusted) or Id, ref to Checker
|
||||
;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
|
||||
(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
|
||||
attribute-mapping-ref _attribute-mapping-set!)
|
||||
(make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
|
||||
(lambda (self stx)
|
||||
(if (attribute-mapping-check self)
|
||||
(let ([source-name
|
||||
(or (let loop ([p (syntax-property stx 'disappeared-use)])
|
||||
(cond [(identifier? p) p]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[else #f]))
|
||||
(attribute-mapping-name self))])
|
||||
(define code
|
||||
`(,(attribute-mapping-check self)
|
||||
,(attribute-mapping-var self)
|
||||
,(attribute-mapping-depth self)
|
||||
#t
|
||||
(quote-syntax ,source-name)))
|
||||
(datum->syntax here-stx code stx))
|
||||
(attribute-mapping-var self)))))
|
||||
(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
|
||||
(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
|
||||
(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
|
||||
(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
|
||||
|
||||
;; (struct metafunction (var))
|
||||
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
|
||||
(make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
|
||||
(define (metafunction-var mf) (metafunction-ref mf 0))
|
||||
|
||||
(define (ht-guide? x)
|
||||
(if (and (pair? x) (eq? (car x) 'h-t)) #t #f))
|
||||
(define (ht-guide-t x)
|
||||
(if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f))
|
||||
|
||||
(define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list))))
|
||||
(define (const-guide-v x)
|
||||
(if (eq? (car x) 't-list)
|
||||
null
|
||||
(let ([e (cadr x)])
|
||||
(if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e)))))
|
||||
|
||||
(define (cons-guide g1 g2)
|
||||
(cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))]
|
||||
[(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
|
||||
[else (list 't-list* g1 g2)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Parsing templates
|
||||
|
||||
;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id))
|
||||
(define (parse-template ctx t stx?)
|
||||
;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
|
||||
(define env (make-hasheq))
|
||||
|
||||
;; wrong-syntax : Syntax Format-String Any ... -> (error)
|
||||
(define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
|
||||
|
||||
;; disappeared-uses : (Listof Id)
|
||||
(define disappeared-uses null)
|
||||
;; disappeared! : Id -> Void
|
||||
(define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses)))
|
||||
|
||||
;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide)
|
||||
(define (parse-t t depth esc?)
|
||||
(cond [(stx-pair? t)
|
||||
(if (identifier? (stx-car t))
|
||||
(parse-t-pair/command t depth esc?)
|
||||
(parse-t-pair/dots t depth esc?))]
|
||||
[else (parse-t-nonpair t depth esc?)]))
|
||||
|
||||
;; parse-t-pair/command : Stx Nat Boolean -> ...
|
||||
;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
|
||||
(define (parse-t-pair/command t depth esc?)
|
||||
(cond [esc?
|
||||
(parse-t-pair/dots t depth esc?)]
|
||||
[(parse-form t (quote-syntax ...) 1)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define-values (drivers guide) (parse-t (cadr t) depth #t))
|
||||
;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _)
|
||||
(values drivers `(t-escaped ,guide)))]
|
||||
[(parse-form t (quote-syntax ??) 2)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define t1 (cadr t))
|
||||
(define t2 (caddr t))
|
||||
(define-values (drivers1 guide1) (parse-t t1 depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-t t2 depth esc?))
|
||||
(values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))]
|
||||
[(lookup-metafun (stx-car t))
|
||||
=> (lambda (mf)
|
||||
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
|
||||
(disappeared! (stx-car t))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values drivers
|
||||
`(t-metafun ,(metafunction-var mf) ,guide
|
||||
(quote-syntax
|
||||
,(let ([tstx (and (syntax? t) t)])
|
||||
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))]
|
||||
[else (parse-t-pair/dots t depth esc?)]))
|
||||
|
||||
;; parse-t-pair/dots : Stx Nat Boolean -> ...
|
||||
;; t is a stx pair; check for dots
|
||||
(define (parse-t-pair/dots t depth esc?)
|
||||
(define head (stx-car t))
|
||||
(define-values (tail nesting)
|
||||
(let loop ([tail (stx-cdr t)] [nesting 0])
|
||||
(if (and (not esc?) (stx-pair? tail)
|
||||
(let ([x (stx-car tail)])
|
||||
(and (identifier? x) (free-identifier=? x (quote-syntax ...)))))
|
||||
(begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting)))
|
||||
(values tail nesting))))
|
||||
(if (zero? nesting)
|
||||
(parse-t-pair/normal t depth esc?)
|
||||
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)]
|
||||
[(tdrivers tguide) (parse-t tail depth esc?)])
|
||||
(when (dset-empty? hdrivers)
|
||||
(wrong-syntax head "no pattern variables before ellipsis in template"))
|
||||
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
|
||||
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
|
||||
(stx-car (stx-drop nesting t))])
|
||||
;; FIXME: improve error message?
|
||||
(wrong-syntax bad-dots "too many ellipses in template")))
|
||||
;; hdrivers is (listof (dsetof pvar))
|
||||
(define hdriverss ;; per level
|
||||
(let loop ([i 0])
|
||||
(if (< i nesting)
|
||||
(cons (dset-filter hdrivers (pvar/dd<=? (+ depth i)))
|
||||
(loop (add1 i)))
|
||||
null)))
|
||||
(define at-stx (datum->syntax #f '... head))
|
||||
(define hg
|
||||
(let loop ([hdriverss hdriverss])
|
||||
(cond [(null? (cdr hdriverss))
|
||||
(let ([cons? (ht-guide? hguide)]
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
|
||||
`(t-dots ,cons? ,hguide ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))]
|
||||
[else (let ([inner (loop (cdr hdriverss))])
|
||||
`(t-dots #f ,inner ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))])))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(if (equal? tguide '(t-list))
|
||||
(resyntax t hg)
|
||||
(resyntax t `(t-append ,hg ,tguide)))))))
|
||||
|
||||
;; parse-t-pair/normal : Stx Nat Boolean -> ...
|
||||
;; t is a normal stx pair
|
||||
(define (parse-t-pair/normal t depth esc?)
|
||||
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?))
|
||||
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(resyntax t
|
||||
(if (ht-guide? hguide)
|
||||
(let ([hguide (ht-guide-t hguide)])
|
||||
(if (and (const-guide? hguide) (const-guide? tguide))
|
||||
(const-guide t)
|
||||
(cons-guide hguide tguide)))
|
||||
(if (equal? tguide '(t-list))
|
||||
hguide
|
||||
`(t-append ,hguide ,tguide))))))
|
||||
|
||||
;; parse-t-nonpair : Syntax Nat Boolean -> ...
|
||||
;; PRE: t is not a stxpair
|
||||
(define (parse-t-nonpair t depth esc?)
|
||||
(define td (if (syntax? t) (syntax-e t) t))
|
||||
(cond [(identifier? t)
|
||||
(cond [(and (not esc?)
|
||||
(or (free-identifier=? t (quote-syntax ...))
|
||||
(free-identifier=? t (quote-syntax ??))
|
||||
(free-identifier=? t (quote-syntax ?@))))
|
||||
(wrong-syntax t "illegal use")]
|
||||
[(lookup-metafun t)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[(lookup t depth)
|
||||
=> (lambda (pvar)
|
||||
(disappeared! t)
|
||||
(values (dset pvar)
|
||||
(cond [(pvar-check pvar)
|
||||
=> (lambda (check)
|
||||
`(#%expression
|
||||
(,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))]
|
||||
[else `(t-var ,(pvar-lvar pvar))])))]
|
||||
[else (values (dset) (const-guide t))])]
|
||||
[(vector? td)
|
||||
(define-values (drivers guide) (parse-t (vector->list td) depth esc?))
|
||||
(values drivers
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-vector ,guide))]))]
|
||||
[(prefab-struct-key td)
|
||||
=> (lambda (key)
|
||||
(define-values (drivers guide)
|
||||
(let ([elems (cdr (vector->list (struct->vector td)))])
|
||||
(parse-t elems depth esc?)))
|
||||
(values drivers
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-struct (quote ,key) ,guide))])))]
|
||||
[(box? td)
|
||||
(define-values (drivers guide) (parse-t (unbox td) depth esc?))
|
||||
(values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))]
|
||||
[else (values (dset) (const-guide t))]))
|
||||
|
||||
;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide)
|
||||
(define (parse-h h depth esc?)
|
||||
(cond [(and (not esc?) (parse-form h (quote-syntax ??) 1))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers guide) (parse-h (cadr h) depth esc?))
|
||||
(values drivers `(h-orelse ,guide null)))]
|
||||
[(and (not esc?) (parse-form h (quote-syntax ??) 2))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers1 guide1) (parse-h (cadr h) depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-h (caddr h) depth esc?))
|
||||
(values (dset-union drivers1 drivers2)
|
||||
(if (and (ht-guide? guide1) (ht-guide? guide2))
|
||||
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
|
||||
`(h-orelse ,guide1 ,guide2))))]
|
||||
[(and (stx-pair? h)
|
||||
(let ([h-head (stx-car h)])
|
||||
(and (identifier? h-head)
|
||||
(or (and (free-identifier=? h-head (quote-syntax ?@)) (not esc?))
|
||||
(free-identifier=? h-head (quote-syntax ?@!))))))
|
||||
(disappeared! (stx-car h))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr h) depth esc?))
|
||||
(values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))]
|
||||
[else
|
||||
(define-values (drivers guide) (parse-t h depth esc?))
|
||||
(values drivers `(h-t ,guide))]))
|
||||
|
||||
;; lookup : Identifier Nat -> PVar/#f
|
||||
(define (lookup id depth)
|
||||
(define (make-pvar var check pvar-depth)
|
||||
(cond [(zero? pvar-depth)
|
||||
(pvar var var check #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(pvar var (gentemp) check (- depth pvar-depth))]
|
||||
[else
|
||||
(wrong-syntax id "missing ellipses with pattern variable in template")]))
|
||||
(define (hash-ref! h k proc)
|
||||
(let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*))))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (syntax-mapping-depth v))
|
||||
(define attr
|
||||
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
|
||||
(and (attribute-mapping? attr) attr)))
|
||||
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
|
||||
(define check (and attr (attribute-mapping-check attr)))
|
||||
(make-pvar var check pvar-depth)))]
|
||||
[(s-exp-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (s-exp-mapping-depth v))
|
||||
(define var (s-exp-mapping-valvar v))
|
||||
(make-pvar var #f pvar-depth)))]
|
||||
[else
|
||||
;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
|
||||
(for-each
|
||||
(lambda (pfx)
|
||||
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
|
||||
(if (and (syntax-pattern-variable? pfx-v)
|
||||
(let ([valvar (syntax-mapping-valvar pfx-v)])
|
||||
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
|
||||
(wrong-syntax id "undefined nested attribute of attribute `~a'"
|
||||
(syntax-e pfx))
|
||||
(void))))
|
||||
(dotted-prefixes id))
|
||||
#f])))
|
||||
|
||||
;; resyntax : Stx Guide -> Guide
|
||||
(define (resyntax t0 g)
|
||||
(if (and stx? (syntax? t0))
|
||||
(cond [(const-guide? g) (const-guide t0)]
|
||||
[else (optimize-resyntax t0 g)])
|
||||
g))
|
||||
|
||||
;; optimize-resyntax : Syntax Guide -> Guide
|
||||
(define (optimize-resyntax t0 g)
|
||||
(define HOLE (datum->syntax #f '_))
|
||||
(define (finish i rt rs re)
|
||||
(values (sub1 i) (reverse rs) (reverse re)
|
||||
(datum->syntax t0 (apply list* (reverse rt)) t0 t0)))
|
||||
(define (loop-gs list*? gs i rt rs re)
|
||||
(cond [(null? gs)
|
||||
(finish i (cons null rt) rs re)]
|
||||
[(and list*? (null? (cdr gs)))
|
||||
(loop-g (car gs) i rt rs re)]
|
||||
[else
|
||||
(define g0 (car gs))
|
||||
(cond [(const-guide? g0)
|
||||
(let ([const (const-guide-v g0)])
|
||||
(loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))]
|
||||
[(eq? (car g0) 't-subst) ;; (t-subst LOC STX <substs>)
|
||||
(let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _)
|
||||
[subargs (list-tail g0 3)])
|
||||
(loop-gs list*? (cdr gs) (add1 i) (cons subt rt)
|
||||
(list* i 'recur rs) (cons `(list . ,subargs) re)))]
|
||||
[else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt)
|
||||
(cons i rs) (cons g0 re))])]))
|
||||
(define (loop-g g i rt rs re)
|
||||
(cond [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)]
|
||||
[(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)]
|
||||
[(eq? (car g) 't-append)
|
||||
(loop-g (caddr g) (add1 i) (cons HOLE rt)
|
||||
(list* i 'append rs) (cons (cadr g) re))]
|
||||
[(eq? (car g) 't-const)
|
||||
(let ([const (const-guide-v g)])
|
||||
(finish i (cons const rt) rs re))]
|
||||
[else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))]))
|
||||
(define-values (npairs substs exprs t*) (loop-g g 0 null null null))
|
||||
(cond [(and substs
|
||||
;; Tunable condition for choosing whether to create a t-subst.
|
||||
;; Avoid creating useless (t-subst loc stx '(tail 0) g).
|
||||
(<= (length substs) (* 2 npairs)))
|
||||
#;(log-message template-logger 'debug
|
||||
(format "OPTIMIZED ~s" (syntax->datum t0)) #f)
|
||||
`(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)]
|
||||
[else
|
||||
#;(log-message template-logger 'debug
|
||||
(format "NOT opt ~s" (syntax->datum t0)) #f)
|
||||
(let ([rep (datum->syntax t0 'STX t0 t0)])
|
||||
`(t-resyntax #f (quote-syntax ,rep) ,g))]))
|
||||
|
||||
;; const-guide : Any -> Guide
|
||||
(define (const-guide x)
|
||||
(cond [(null? x) `(t-list)]
|
||||
[(not stx?) `(t-const (quote ,x))]
|
||||
[(syntax? x) `(t-const (quote-syntax ,x))]
|
||||
[else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
|
||||
|
||||
(let-values ([(drivers guide) (parse-t t 0 #f)])
|
||||
(values (dset->list drivers) guide disappeared-uses)))
|
||||
|
||||
;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
|
||||
(define (parse-form stx form-id arity)
|
||||
(and (stx-pair? stx)
|
||||
(let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)])
|
||||
(and (identifier? stx-h) (free-identifier=? stx-h form-id)
|
||||
(let ([stx-tl (stx->list stx-t)])
|
||||
(and (list? stx-tl)
|
||||
(= (length stx-tl) arity)
|
||||
(cons stx-h stx-tl)))))))
|
||||
|
||||
;; lookup-metafun : Identifier -> Metafunction/#f
|
||||
(define (lookup-metafun id)
|
||||
(define v (syntax-local-value id (lambda () #f)))
|
||||
(and (metafunction? v) v))
|
||||
|
||||
(define (dotted-prefixes id)
|
||||
(let* ([id-string (symbol->string (syntax-e id))]
|
||||
[dot-locations
|
||||
(let loop ([i 0])
|
||||
(if (< i (string-length id-string))
|
||||
(if (eqv? (string-ref id-string i) #\.)
|
||||
(cons i (loop (add1 i)))
|
||||
(loop (add1 i)))
|
||||
null))])
|
||||
(map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
|
||||
dot-locations)))
|
||||
|
||||
(define (pvar/dd<=? expected-dd)
|
||||
(lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))))
|
||||
|
||||
(define gentemp-counter 0)
|
||||
(define (gentemp)
|
||||
(set! gentemp-counter (add1 gentemp-counter))
|
||||
((make-syntax-introducer)
|
||||
(datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter)))))
|
||||
|
||||
(define (stx-drop n x)
|
||||
(if (zero? n) x (stx-drop (sub1 n) (stx-cdr x))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Deterministic Sets
|
||||
;; FIXME: detect big unions, use hash table
|
||||
|
||||
(define (dset . xs) xs)
|
||||
(define (dset-empty? ds) (null? ds))
|
||||
(define (dset-filter ds pred) (filter pred ds))
|
||||
(define (dset->list ds) ds)
|
||||
(define (dset-union ds1 ds2)
|
||||
(if (pair? ds1)
|
||||
(let ([elem (car ds1)])
|
||||
(if (member elem ds2)
|
||||
(dset-union (cdr ds1) ds2)
|
||||
(dset-union (cdr ds1) (cons (car ds1) ds2))))
|
||||
ds2))
|
||||
|
||||
(define (filter keep? xs)
|
||||
(if (pair? xs)
|
||||
(if (keep? (car xs))
|
||||
(cons (car xs) (filter keep? (cdr xs)))
|
||||
(filter keep? (cdr xs)))
|
||||
null))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Relocating (eg, syntax/loc)
|
||||
|
||||
;; Only relocate if relocation would affect a syntax pair originating
|
||||
;; from template structure. For example (x,y are pvars):
|
||||
;; (syntax/loc loc-stx (1 2 3)) => relocate
|
||||
;; (syntax/loc loc-stx y) => don't relocate
|
||||
;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x!
|
||||
;; Deciding whether to relocate after the fact is hard. But with explicit
|
||||
;; t-resyntax, it's much easier.
|
||||
|
||||
;; relocate-guide : Syntax Guide Id -> Guide
|
||||
(define (relocate-guide ctx g0 loc-id)
|
||||
(define (loop g)
|
||||
(define gtag (car g))
|
||||
(cond [(eq? gtag 't-resyntax)
|
||||
`(t-resyntax ,loc-id . ,(cddr g))]
|
||||
[(eq? gtag 't-const)
|
||||
`(t-relocate ,g ,loc-id)]
|
||||
[(eq? gtag 't-subst)
|
||||
`(t-subst ,loc-id . ,(cddr g))]
|
||||
;; ----
|
||||
[(eq? gtag 't-escaped)
|
||||
`(t-escaped ,(loop (cadr g)))]
|
||||
[(eq? gtag 't-orelse)
|
||||
`(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))]
|
||||
;; ----
|
||||
;; Nothing else should be relocated
|
||||
[else g]))
|
||||
(loop g0))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
|
||||
(define (do-template ctx tstx loc-id stx?)
|
||||
(define-values (pvars pre-guide disappeared-uses)
|
||||
(parse-template ctx tstx stx?))
|
||||
(define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
|
||||
(define ell-pvars (filter pvar-dd pvars))
|
||||
(define pre-code
|
||||
(if (const-guide? guide)
|
||||
(if stx? `(quote-syntax ,tstx) `(quote ,tstx))
|
||||
(let ([lvars (map pvar-lvar ell-pvars)]
|
||||
[valvars (map pvar-var ell-pvars)])
|
||||
`(let (,@(map list lvars valvars))
|
||||
,(datum->syntax here-stx guide)))))
|
||||
(define code (syntax-arm (datum->syntax here-stx pre-code ctx)))
|
||||
(syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
|
||||
)
|
||||
|
||||
(define-syntax (syntax stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 2))
|
||||
(do-template stx (cadr s) #f #t)
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
(define-syntax (syntax/loc stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 3))
|
||||
(let ([loc-id (quote-syntax loc)])
|
||||
(define code
|
||||
`(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))])
|
||||
,(do-template stx (caddr s) loc-id #t)))
|
||||
(syntax-arm (datum->syntax here-stx code stx)))
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
(define-syntax (datum stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 2))
|
||||
(do-template stx (cadr s) #f #f)
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
(define (check-loc who x)
|
||||
(if (syntax? x) x (raise-argument-error who "syntax?" x)))
|
||||
|
||||
|
||||
;; ============================================================
|
||||
;; Run-time support
|
||||
|
||||
;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)]
|
||||
(define-syntax (t-dots stx)
|
||||
(define s (syntax->list stx))
|
||||
(define cons? (syntax-e (list-ref s 1)))
|
||||
(define head (list-ref s 2))
|
||||
(define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar)
|
||||
(define in-stx (list-ref s 4))
|
||||
(define at-stx (list-ref s 5))
|
||||
(cond
|
||||
;; Case 1: (x ...) where x is trusted
|
||||
[(and cons? (let ([head-s (syntax->list head)])
|
||||
(and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var))))
|
||||
head]
|
||||
;; General case
|
||||
[else
|
||||
;; var-value-expr : Id Id/#'#f -> Expr[List]
|
||||
(define (var-value-expr lvar check)
|
||||
(if (syntax-e check) `(,check ,lvar 1 #f #f) lvar))
|
||||
(define lvars (map pvar-lvar drivers))
|
||||
(define checks (map pvar-check drivers))
|
||||
(define code
|
||||
`(let ,(map list lvars (map var-value-expr lvars checks))
|
||||
,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
|
||||
,(if cons?
|
||||
`(map (lambda ,lvars ,head) . ,lvars)
|
||||
`(apply append (map (lambda ,lvars ,head) . ,lvars)))))
|
||||
(datum->syntax here-stx code stx)]))
|
||||
|
||||
(define-syntax (t-orelse stx)
|
||||
(define s (syntax->list stx))
|
||||
(datum->syntax here-stx `(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s)))))
|
||||
(define-syntax h-orelse (make-rename-transformer (quote-syntax t-orelse)))
|
||||
|
||||
(#%require (rename '#%kernel t-const #%expression)
|
||||
(rename '#%kernel t-var #%expression)
|
||||
;; (rename '#%kernel t-append append)
|
||||
(rename '#%kernel t-list list)
|
||||
(rename '#%kernel t-list* list*)
|
||||
(rename '#%kernel t-escaped #%expression)
|
||||
(rename '#%kernel t-vector list->vector)
|
||||
(rename '#%kernel t-box box-immutable)
|
||||
(rename '#%kernel h-t list))
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(define (t-append xs ys) (if (null? ys) xs (append xs ys)))
|
||||
(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx))
|
||||
(define (t-relocate g loc) (datum->syntax g (syntax-e g) loc g))
|
||||
(define (t-orelse* g1 g2)
|
||||
((let/ec escape
|
||||
(with-continuation-mark
|
||||
absent-pvar-escape-key
|
||||
(lambda () (escape g2))
|
||||
(let ([v (g1)]) (lambda () v))))))
|
||||
(define (t-struct key g) (apply make-prefab-struct key g))
|
||||
(define (t-metafun mf g stx)
|
||||
(mf (datum->syntax stx (cons (stx-car stx) g) stx stx)))
|
||||
(define (h-splice g in-stx at-stx)
|
||||
(if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx)))
|
||||
|
||||
#| end begin-encourage-inline |#)
|
||||
|
||||
;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax
|
||||
;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs)
|
||||
;; There is one arg for each index in substs. See also defn of Guide above.
|
||||
(define (t-subst loc stx substs . args)
|
||||
(define (loop/mode s i mode seek substs args)
|
||||
(cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))]
|
||||
[(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
|
||||
[(eq? mode 'tail) (car args)]
|
||||
[(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
|
||||
[(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args))
|
||||
(loop (cdr s) (add1 i) substs (cdr args)))]))
|
||||
(define (loop s i substs args)
|
||||
(cond [(null? substs) s]
|
||||
[(symbol? (car substs))
|
||||
(loop/mode s i (car substs) (cadr substs) (cddr substs) args)]
|
||||
[else (loop/mode s i #f (car substs) (cdr substs) args)]))
|
||||
(define v (loop (syntax-e stx) 0 substs args))
|
||||
(datum->syntax stx v (or loc stx) stx))
|
||||
|
||||
(define absent-pvar-escape-key (gensym 'absent-pvar-escape))
|
||||
|
||||
;; signal-absent-pvar : -> escapes or #f
|
||||
;; Note: Only escapes if in ?? form.
|
||||
(define (signal-absent-pvar)
|
||||
(let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)])
|
||||
(if escape (escape) #f)))
|
||||
|
||||
;; error/splice : Any Stx Stx -> (escapes)
|
||||
(define (error/splice r in-stx at-stx)
|
||||
(raise-syntax-error 'syntax
|
||||
(format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx))
|
||||
|
||||
;; check-same-length : Stx Stx List ... -> Void
|
||||
(define check-same-length
|
||||
(case-lambda
|
||||
[(in at a) (void)]
|
||||
[(in at a b)
|
||||
(if (= (length a) (length b))
|
||||
(void)
|
||||
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
|
||||
(list in '...) at))]
|
||||
[(in at a . bs)
|
||||
(define alen (length a))
|
||||
(for-each (lambda (b)
|
||||
(if (= alen (length b))
|
||||
(void)
|
||||
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
|
||||
(list in '...) at)))
|
||||
bs)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; A dset is an `equal?`-based set, but it preserves order based on
|
||||
;; the history of additions, so that if items are added in a
|
||||
;; deterministic order, they come back out in a deterministic order.
|
||||
|
||||
(provide dset
|
||||
dset-empty?
|
||||
dset->list
|
||||
dset-add
|
||||
dset-union
|
||||
dset-subtract
|
||||
dset-filter)
|
||||
|
||||
(define dset
|
||||
(case-lambda
|
||||
[() (hash)]
|
||||
[(e) (hash e 0)]))
|
||||
|
||||
(define (dset-empty? ds)
|
||||
(zero? (hash-count ds)))
|
||||
|
||||
(define (dset->list ds)
|
||||
(map cdr
|
||||
(sort (for/list ([(k v) (in-hash ds)])
|
||||
(cons v k))
|
||||
<
|
||||
#:key car)))
|
||||
|
||||
(define (dset-add ds e)
|
||||
(if (hash-ref ds e #f)
|
||||
ds
|
||||
(hash-set ds e (hash-count ds))))
|
||||
|
||||
(define (dset-union ds1 ds2)
|
||||
(cond
|
||||
[((hash-count ds1) . > . (hash-count ds2))
|
||||
(dset-union ds2 ds1)]
|
||||
[else
|
||||
(for/fold ([ds2 ds2]) ([e (dset->list ds1)])
|
||||
(dset-add ds2 e))]))
|
||||
|
||||
(define (dset-subtract ds1 ds2)
|
||||
;; ! takes O(size(ds2)) time !
|
||||
(for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
|
||||
(if (hash-ref ds2 e #f)
|
||||
r
|
||||
(dset-add r e))))
|
||||
|
||||
(define (dset-filter ds pred)
|
||||
(for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
|
||||
(if (pred e)
|
||||
(dset-add r e)
|
||||
r)))
|
||||
|
|
@ -1,492 +1,16 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
"dset.rkt"
|
||||
racket/syntax
|
||||
syntax/parse/private/minimatch
|
||||
racket/private/stx ;; syntax/stx
|
||||
racket/private/sc)
|
||||
syntax/parse/private/residual
|
||||
racket/private/stx
|
||||
racket/performance-hint
|
||||
racket/private/promise)
|
||||
(provide template
|
||||
template/loc
|
||||
datum-template
|
||||
quasitemplate
|
||||
quasitemplate/loc
|
||||
define-template-metafunction
|
||||
??
|
||||
?@)
|
||||
|
||||
;; ============================================================
|
||||
;; Syntax of templates
|
||||
|
||||
;; A Template (T) is one of:
|
||||
;; - pattern-variable
|
||||
;; - constant (including () and non-pvar identifiers)
|
||||
;; - (metafunction . T)
|
||||
;; - (H . T)
|
||||
;; - (H ... . T), (H ... ... . T), etc
|
||||
;; - (?? T T)
|
||||
;; - #(T*)
|
||||
;; - #s(prefab-struct-key T*)
|
||||
;; * (unsyntax expr)
|
||||
|
||||
;; A HeadTemplate (H) is one of:
|
||||
;; - T
|
||||
;; - (?? H)
|
||||
;; - (?? H H)
|
||||
;; - (?@ . T)
|
||||
;; * (unquote-splicing expr)
|
||||
|
||||
(define-syntaxes (?? ?@)
|
||||
(let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
|
||||
(values tx tx)))
|
||||
|
||||
(define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing
|
||||
|
||||
;; ============================================================
|
||||
;; Compile-time
|
||||
|
||||
;; Parse template syntax into a Guide (AST--the name is left over from
|
||||
;; when the "guide" was a data structure interpreted at run time).
|
||||
|
||||
;; The AST representation is designed to coincide with the run-time
|
||||
;; support, so compilation is just (datum->syntax #'here guide).
|
||||
|
||||
;; A Guide (G) is one of:
|
||||
;; - (list 't-resyntax G) ;; template is syntax; re-syntax result
|
||||
;; - (list 't-const) ;; constant
|
||||
;; - (list 't-var PVar Boolean) ;; pattern variable
|
||||
;; - (list 't-cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr}
|
||||
;; - (list 't-vector G) ;; template is non-syntax vector
|
||||
;; - (list 't-struct G) ;; template is non-syntax prefab struct
|
||||
;; - (list 't-box G) ;; template is non-syntax box
|
||||
;; - (list 't-dots HG (listof (listof PVar)) Nat G/#f #f Boolean)
|
||||
;; - (list 't-dots G (listof (listof PVar)) Nat G/#f #t Boolean)
|
||||
;; - (list 't-append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr}
|
||||
;; - (list 't-escaped G)
|
||||
;; - (list 't-orelse G G)
|
||||
;; - (list 't-metafun Id G)
|
||||
;; - (list 't-relocate G Id) ;; relocate syntax
|
||||
;; - (list 't-resyntax/loc G Id) ;; like t-resyntax, but use alt srcloc
|
||||
;; For 't-var and 't-dots, the final boolean indicates whether the template
|
||||
;; fragment is in the left-hand side of an orelse (??).
|
||||
|
||||
;; A HeadGuide (HG) is one of:
|
||||
;; - (list 'h-t G)
|
||||
;; - (list 'h-orelse HG HG/#f)
|
||||
;; - (list 'h-splice G)
|
||||
|
||||
;; A PVar is (pvar Id Id Boolean Nat/#f)
|
||||
;;
|
||||
;; The first identifier (var) is from the syntax-mapping or attribute-binding.
|
||||
;; The second (lvar) is a local variable name used to hold its value (or parts
|
||||
;; thereof) in ellipsis iteration. The boolean is #f if var is trusted to have a
|
||||
;; (Listof^depth Syntax) value, #t if it needs to be checked.
|
||||
;;
|
||||
;; The depth-delta associated with a depth>0 pattern variable is the difference
|
||||
;; between the pattern variable's depth and the depth at which it is used. (For
|
||||
;; depth 0 pvars, it's #f.) For example, in
|
||||
;;
|
||||
;; (with-syntax ([x #'0]
|
||||
;; [(y ...) #'(1 2)]
|
||||
;; [((z ...) ...) #'((a b) (c d))])
|
||||
;; (template (((x y) ...) ...)))
|
||||
;;
|
||||
;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for
|
||||
;; z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis
|
||||
;; form at which the variable should be moved to the loop-env. That is, the
|
||||
;; template above should be interpreted as roughly similar to
|
||||
;;
|
||||
;; (let ([x (pvar-value-of x)]
|
||||
;; [y (pvar-value-of y)]
|
||||
;; [z (pvar-value-of z)])
|
||||
;; (for ([Lz (in-list z)]) ;; depth 0
|
||||
;; (for ([Ly (in-list y)] ;; depth 1
|
||||
;; [Lz (in-list Lz)])
|
||||
;; (___ x Ly Lz ___))))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define-logger template)
|
||||
|
||||
(struct pvar (var lvar check? dd) #:prefab)
|
||||
(struct template-metafunction (var))
|
||||
|
||||
(define (ht-guide? x) (match x [(list 'h-t _) #t] [_ #f]))
|
||||
(define (ht-guide-t x) (match x [(list 'h-t g) g]))
|
||||
|
||||
(define const-guide '(t-const))
|
||||
(define (const-guide? x) (equal? x const-guide))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Parsing templates
|
||||
|
||||
;; parse-template : Syntax Boolean -> (values (listof PVar) Guide)
|
||||
(define (parse-template t stx?)
|
||||
;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
|
||||
(define env (make-hasheq))
|
||||
|
||||
;; parse-t : Stx Nat Boolean Boolean -> (values (dsetof PVar) Guide)
|
||||
(define (parse-t t depth esc? in-try?)
|
||||
(cond [(stx-pair? t)
|
||||
(if (identifier? (stx-car t))
|
||||
(parse-t-pair/command t depth esc? in-try?)
|
||||
(parse-t-pair/dots t depth esc? in-try?))]
|
||||
[else (parse-t-nonpair t depth esc? in-try?)]))
|
||||
|
||||
;; parse-t-pair/command : Stx Nat Boolean Boolean -> ...
|
||||
;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
|
||||
(define (parse-t-pair/command t depth esc? in-try?)
|
||||
(syntax-case t (??)
|
||||
[(DOTS template)
|
||||
(and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...)))
|
||||
(let-values ([(drivers guide) (parse-t #'template depth #t in-try?)])
|
||||
(values drivers `(t-escaped ,guide)))]
|
||||
[(?? t1 t2)
|
||||
(not esc?)
|
||||
(let-values ([(drivers1 guide1) (parse-t #'t1 depth esc? #t)]
|
||||
[(drivers2 guide2) (parse-t #'t2 depth esc? in-try?)])
|
||||
(values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))]
|
||||
[(mf-id . _)
|
||||
(and (not esc?) (lookup-metafun #'mf-id))
|
||||
(let-values ([(mf) (lookup-metafun #'mf-id)]
|
||||
[(drivers guide) (parse-t (stx-cdr t) depth esc? in-try?)])
|
||||
(unless stx? (wrong-syntax "metafunctions not supported" #'mf-id))
|
||||
(values drivers `(t-metafun ,(template-metafunction-var mf) ,guide)))]
|
||||
[_ (parse-t-pair/dots t depth esc? in-try?)]))
|
||||
|
||||
;; parse-t-pair/dots : Stx Nat Boolean Boolean -> ...
|
||||
;; t is a stx pair; check for dots
|
||||
(define (parse-t-pair/dots t depth esc? in-try?)
|
||||
(define head (stx-car t))
|
||||
(define-values (tail nesting)
|
||||
(let loop ([tail (stx-cdr t)] [nesting 0])
|
||||
(if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail)))
|
||||
(loop (stx-cdr tail) (add1 nesting))
|
||||
(values tail nesting))))
|
||||
(if (zero? nesting)
|
||||
(parse-t-pair/normal t depth esc? in-try?)
|
||||
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)]
|
||||
[(tdrivers tguide)
|
||||
(if (null? tail)
|
||||
(values (dset) #f)
|
||||
(parse-t tail depth esc? in-try?))])
|
||||
(when (dset-empty? hdrivers)
|
||||
(wrong-syntax head "no pattern variables before ellipsis in template"))
|
||||
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
|
||||
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
|
||||
(stx-car (stx-drop nesting t))])
|
||||
;; FIXME: improve error message?
|
||||
(wrong-syntax bad-dots "too many ellipses in template")))
|
||||
;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level
|
||||
(define hdriverss ;; per level
|
||||
(for/list ([i (in-range nesting)])
|
||||
(dset-filter hdrivers (pvar/dd<=? (+ depth i)))))
|
||||
(define new-hdriverss ;; per level
|
||||
(let loop ([raw hdriverss] [last (dset)])
|
||||
(cond [(null? raw) null]
|
||||
[else
|
||||
(define new-hdrivers (dset->list (dset-subtract (car raw) last)))
|
||||
(cons new-hdrivers (loop (cdr raw) (car raw)))])))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(let ([cons? (ht-guide? hguide)]
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
|
||||
(resyntax t `(t-dots ,hguide ,new-hdriverss ,nesting ,tguide ,cons? ,in-try?)))))))
|
||||
|
||||
;; parse-t-pair/normal : Stx Nat Boolean Boolean -> ...
|
||||
;; t is a normal stx pair
|
||||
(define (parse-t-pair/normal t depth esc? in-try?)
|
||||
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc? in-try?))
|
||||
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc? in-try?))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(let ([kind (if (ht-guide? hguide) 't-cons/p 't-append/p)]
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
|
||||
(resyntax t `(,kind ,hguide ,tguide)))))
|
||||
|
||||
;; parse-t-nonpair : Stx Nat Boolean Boolean -> ...
|
||||
;; PRE: t is not a stxpair
|
||||
(define (parse-t-nonpair t depth esc? in-try?)
|
||||
(syntax-case t (?? ?@)
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(cond [(and (not esc?)
|
||||
(or (free-identifier=? #'id (quote-syntax ...))
|
||||
(free-identifier=? #'id (quote-syntax ??))
|
||||
(free-identifier=? #'id (quote-syntax ?@))))
|
||||
(wrong-syntax #'id "illegal use")]
|
||||
[(lookup-metafun #'id)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[(lookup #'id depth)
|
||||
=> (lambda (pvar) (values (dset pvar) `(t-var ,pvar ,in-try?)))]
|
||||
[else (values (dset) const-guide)])]
|
||||
[vec
|
||||
(vector? (syntax-e #'vec))
|
||||
(let-values ([(drivers guide)
|
||||
(parse-t (vector->list (syntax-e #'vec)) depth esc? in-try?)])
|
||||
(values drivers (if (const-guide? guide) const-guide (resyntax t `(t-vector ,guide)))))]
|
||||
[pstruct
|
||||
(prefab-struct-key (syntax-e #'pstruct))
|
||||
(let-values ([(drivers guide)
|
||||
(let ([elems (cdr (vector->list (struct->vector (syntax-e #'pstruct))))])
|
||||
(parse-t elems depth esc? in-try?))])
|
||||
(values drivers (if (const-guide? guide) const-guide (resyntax t `(t-struct ,guide)))))]
|
||||
[#&template
|
||||
(let-values ([(drivers guide)
|
||||
(parse-t #'template depth esc? in-try?)])
|
||||
(values drivers (if (const-guide? guide) const-guide (resyntax t `(t-box ,guide)))))]
|
||||
[const
|
||||
(values (dset) const-guide)]))
|
||||
|
||||
;; parse-h : Syntax Nat Boolean Boolean -> (values (dsetof PVar) HeadGuide)
|
||||
(define (parse-h h depth esc? in-try?)
|
||||
(syntax-case h (?? ?@ ?@!)
|
||||
[(?? t)
|
||||
(not esc?)
|
||||
(let-values ([(drivers guide) (parse-h #'t depth esc? #t)])
|
||||
(values drivers `(h-orelse ,guide #f)))]
|
||||
[(?? t1 t2)
|
||||
(not esc?)
|
||||
(let-values ([(drivers1 guide1) (parse-h #'t1 depth esc? #t)]
|
||||
[(drivers2 guide2) (parse-h #'t2 depth esc? in-try?)])
|
||||
(values (dset-union drivers1 drivers2)
|
||||
(if (and (ht-guide? guide1) (ht-guide? guide2))
|
||||
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
|
||||
`(h-orelse ,guide1 ,guide2))))]
|
||||
[(?@ . _)
|
||||
(not esc?)
|
||||
(let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)])
|
||||
(values drivers `(h-splice ,guide)))]
|
||||
[(?@! . _)
|
||||
(let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)])
|
||||
(values drivers `(h-splice ,guide)))]
|
||||
[t
|
||||
(let-values ([(drivers guide) (parse-t #'t depth esc? in-try?)])
|
||||
(values drivers `(h-t ,guide)))]))
|
||||
|
||||
;; lookup : Identifier Nat -> PVar/#f
|
||||
(define (lookup id depth)
|
||||
(define variable? (if stx? syntax-pattern-variable? s-exp-pattern-variable?))
|
||||
(let ([v (syntax-local-value/record id variable?)])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (syntax-mapping-depth v))
|
||||
(define attr
|
||||
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
|
||||
(and (attribute-mapping? attr) attr)))
|
||||
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
|
||||
(define check? (and attr (not (attribute-mapping-syntax? attr))))
|
||||
(cond [(zero? pvar-depth)
|
||||
(pvar var var check? #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(define lvar (car (generate-temporaries #'(pv_))))
|
||||
(pvar var lvar check? (- depth pvar-depth))]
|
||||
[else
|
||||
(wrong-syntax id "missing ellipses with pattern variable in template")])))]
|
||||
[(s-exp-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (s-exp-mapping-depth v))
|
||||
(define var (s-exp-mapping-valvar v))
|
||||
(define check? #f)
|
||||
(cond [(zero? pvar-depth)
|
||||
(pvar var var #f #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(define lvar (car (generate-temporaries #'(pv_))))
|
||||
(pvar var lvar #f (- depth pvar-depth))]
|
||||
[else
|
||||
(wrong-syntax id "missing ellipses with pattern variable in template")])))]
|
||||
[else
|
||||
;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute
|
||||
(for ([pfx (in-list (dotted-prefixes id))])
|
||||
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
|
||||
(when (and (syntax-pattern-variable? pfx-v)
|
||||
(let ([valvar (syntax-mapping-valvar pfx-v)])
|
||||
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
|
||||
(wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx)))))
|
||||
#f])))
|
||||
|
||||
;; resyntax : Stx Guide -> Guide
|
||||
(define (resyntax t g) (if (and stx? (syntax? t)) `(t-resyntax ,g) g))
|
||||
|
||||
(let-values ([(drivers guide) (parse-t t 0 #f #f)])
|
||||
(values (dset->list drivers) guide)))
|
||||
|
||||
;; lookup-metafun : Identifier -> Metafunction/#f
|
||||
(define (lookup-metafun id)
|
||||
(syntax-local-value/record id template-metafunction?))
|
||||
|
||||
(define (dotted-prefixes id)
|
||||
(let* ([id-string (symbol->string (syntax-e id))]
|
||||
[dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))])
|
||||
(for/list ([loc (in-list dot-locations)])
|
||||
(datum->syntax id (string->symbol (substring id-string 0 loc))))))
|
||||
|
||||
(define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...))))
|
||||
|
||||
(define (cons/p-guide g1 g2)
|
||||
(if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/p ,g1 ,g2)))
|
||||
|
||||
(define ((pvar/dd<=? expected-dd) x)
|
||||
(let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd))))
|
||||
|
||||
(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
|
||||
|
||||
(define (restx ctx v) (if (syntax? ctx) (datum->syntax ctx v ctx ctx) v))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Relocating (eg, template/loc)
|
||||
|
||||
;; Only relocate if relocation would affect a syntax pair originating
|
||||
;; from template structure. For example:
|
||||
;; (template/loc loc-stx (1 2 3)) => okay
|
||||
;; (template/loc loc-stx pvar) => don't relocate
|
||||
|
||||
;; relocate-guide : Guide Id -> Guide
|
||||
(define (relocate-guide g0 loc-id)
|
||||
(define (error/no-relocate)
|
||||
(wrong-syntax #f "cannot apply syntax location to template"))
|
||||
(define (loop g)
|
||||
(match g
|
||||
[(list 't-resyntax g1)
|
||||
(list 't-resyntax/loc g1 loc-id)]
|
||||
[(list 't-const)
|
||||
`(t-relocate ,g ,loc-id)]
|
||||
;; ----
|
||||
[(list 't-escaped g1)
|
||||
(list 't-escaped (loop g1))]
|
||||
[(list 't-orelse g1 g2)
|
||||
(list 't-orelse (loop g1) (loop g2))]
|
||||
;; ----
|
||||
;; Variables shouldn't be relocated.
|
||||
[(list 't-var pvar in-try?) g]
|
||||
;; ----
|
||||
;; Otherwise, cannot relocate: t-metafun, anything else?
|
||||
[_ (error/no-relocate)]))
|
||||
(loop g0))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Compilation
|
||||
|
||||
;; compile-guide : Guide -> Syntax[Expr]
|
||||
(define (compile-guide g) (datum->syntax #'here g))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
|
||||
(define (do-template ctx tstx loc-id stx?)
|
||||
(with-disappeared-uses
|
||||
(parameterize ((current-syntax-context ctx))
|
||||
(define-values (pvars pre-guide) (parse-template tstx stx?))
|
||||
(define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide))
|
||||
(syntax-arm
|
||||
(with-syntax ([t tstx]
|
||||
[quote-template (if stx? #'quote-syntax #'quote)]
|
||||
[((var . pvar-val-var) ...)
|
||||
(for/list ([pvar (in-list pvars)] #:when (pvar-dd pvar))
|
||||
(cons (pvar-lvar pvar) (pvar-var pvar)))])
|
||||
#`(let ([var pvar-val-var] ...)
|
||||
(let ([tstx0 (quote-template t)])
|
||||
(#,(compile-guide guide) tstx0))))))))
|
||||
)
|
||||
|
||||
(define-syntax (template stx)
|
||||
(syntax-case stx ()
|
||||
[(template t)
|
||||
(do-template stx #'t #f #t)]
|
||||
[(template t #:properties _)
|
||||
(begin
|
||||
(log-template-error "template #:properties argument no longer supported: ~e" stx)
|
||||
(do-template stx #'t #f))]))
|
||||
|
||||
(define-syntax (template/loc stx)
|
||||
(syntax-case stx ()
|
||||
[(template/loc loc-expr t)
|
||||
(syntax-arm
|
||||
(with-syntax ([main-expr (do-template stx #'t #'loc-var #t)])
|
||||
#'(let ([loc-var (handle-loc '?/loc loc-expr)])
|
||||
main-expr)))]))
|
||||
|
||||
|
||||
(define-syntax (datum-template stx)
|
||||
(syntax-case stx ()
|
||||
[(datum-template t)
|
||||
(do-template stx #'t #f #f)]))
|
||||
|
||||
(define (handle-loc who x)
|
||||
(if (syntax? x) x (raise-argument-error who "syntax?" x)))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
(begin-for-syntax
|
||||
;; process-quasi : Syntax -> (list Syntax[with-syntax-bindings] Syntax[expr])
|
||||
(define (process-quasi t0)
|
||||
(define bindings null)
|
||||
(define (add! binding) (set! bindings (cons binding bindings)))
|
||||
(define (process t depth)
|
||||
(define (loop t) (process t depth))
|
||||
(define (loop- t) (process t (sub1 depth)))
|
||||
(define (loop+ t) (process t (add1 depth)))
|
||||
(syntax-case t (unsyntax unsyntax-splicing quasitemplate)
|
||||
[(unsyntax expr)
|
||||
(cond [(zero? depth)
|
||||
(with-syntax ([(us) (generate-temporaries #'(us))]
|
||||
[ctx (datum->syntax #'expr 'ctx #'expr)])
|
||||
(add! (list #'us #'(check-unsyntax expr (quote-syntax ctx))))
|
||||
#'us)]
|
||||
[else
|
||||
(restx t (cons (stx-car t) (loop- (stx-cdr t))))])]
|
||||
[((unsyntax-splicing expr) . _)
|
||||
(cond [(zero? depth)
|
||||
(with-syntax ([(us) (generate-temporaries #'(us))]
|
||||
[ctx (datum->syntax #'expr 'ctx #'expr)])
|
||||
(add! (list #'us #'(check-unsyntax-splicing expr (quote-syntax ctx))))
|
||||
(restx t (cons #'(?@! . us) (loop (stx-cdr t)))))]
|
||||
[else
|
||||
(let ([tcar (stx-car t)]
|
||||
[tcdr (stx-cdr t)])
|
||||
(restx t (cons (restx tcar (cons (stx-car tcar) (loop- (stx-cdr tcar))))
|
||||
(loop tcdr))))])]
|
||||
[(quasitemplate _)
|
||||
(restx t (cons (stx-car t) (loop+ (stx-cdr t))))]
|
||||
[unsyntax
|
||||
(raise-syntax-error #f "misuse within quasitemplate" t0 t)]
|
||||
[unsyntax-splicing
|
||||
(raise-syntax-error #f "misuse within quasitemplate" t0 t)]
|
||||
[_
|
||||
(let ([d (if (syntax? t) (syntax-e t) t)])
|
||||
(cond [(pair? d) (restx t (cons (loop (car d)) (loop (cdr d))))]
|
||||
[(vector? d) (restx t (list->vector (loop (vector->list d))))]
|
||||
[(box? d) (restx t (box (loop (unbox d))))]
|
||||
[(prefab-struct-key d)
|
||||
=> (lambda (key)
|
||||
(apply make-prefab-struct key (loop (cdr (vector->list (struct->vector d))))))]
|
||||
[else t]))]))
|
||||
(define t* (process t0 0))
|
||||
(list (reverse bindings) t*)))
|
||||
|
||||
(define-syntax (quasitemplate stx)
|
||||
(syntax-case stx ()
|
||||
[(quasitemplate t)
|
||||
(with-syntax ([(bindings t*) (process-quasi #'t)])
|
||||
#'(with-syntax bindings (template t*)))]))
|
||||
|
||||
(define-syntax (quasitemplate/loc stx)
|
||||
(syntax-case stx ()
|
||||
[(quasitemplate/loc loc-expr t)
|
||||
(with-syntax ([(bindings t*) (process-quasi #'t)])
|
||||
#'(with-syntax bindings
|
||||
(template/loc (handle-loc 'quasitemplate/loc loc-expr) t*)))]))
|
||||
|
||||
(define (check-unsyntax v ctx)
|
||||
(datum->syntax ctx v ctx))
|
||||
(define (check-unsyntax-splicing v ctx)
|
||||
(unless (stx-list? v) (raise-argument-error 'unsyntax-splicing "syntax->list" v))
|
||||
(datum->syntax ctx v ctx))
|
||||
(require (for-syntax racket/base)
|
||||
(only-in racket/private/template
|
||||
metafunction))
|
||||
(provide (rename-out [syntax template]
|
||||
[syntax/loc template/loc]
|
||||
[quasisyntax quasitemplate]
|
||||
[quasisyntax/loc quasitemplate/loc])
|
||||
?? ?@
|
||||
define-template-metafunction)
|
||||
|
||||
;; ============================================================
|
||||
;; Metafunctions
|
||||
|
||||
(define-syntax (define-template-metafunction stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -495,191 +19,17 @@
|
|||
[(dsm id expr)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([(internal-id) (generate-temporaries #'(id))])
|
||||
#'(begin (define internal-id expr)
|
||||
(define-syntax id
|
||||
(template-metafunction (quote-syntax internal-id)))))]))
|
||||
|
||||
|
||||
;; ============================================================
|
||||
;; Run-time support
|
||||
|
||||
;; Template transcription involves traversing the template syntax object,
|
||||
;; substituting pattern variables etc. The interpretation of the template is
|
||||
;; known at compile time, but we still need the template syntax at run time,
|
||||
;; because it is the basis for generated syntax objects (via datum->syntax).
|
||||
|
||||
;; A template fragment (as opposed to the whole template expression) is compiled
|
||||
;; to a function of type (Stx -> Stx). It receives the corresponding template
|
||||
;; stx fragment as its argument. Pattern variables are passed through the
|
||||
;; environment. We rely on Racket's inliner and optimizer to simplify the
|
||||
;; resulting code to nearly first-order so that a new tree of closures is not
|
||||
;; allocated for each template transcription.
|
||||
|
||||
;; Note: as an optimization, we track syntax vs non-syntax pairs in the template
|
||||
;; so we can generate more specific code (hopefully smaller and faster).
|
||||
|
||||
(define-syntax (t-var stx)
|
||||
(syntax-case stx ()
|
||||
[(t-var #s(pvar var lvar check? _) in-try?)
|
||||
(cond [(syntax-e #'check?)
|
||||
#`(lambda (stx) (check-stx stx lvar in-try?))]
|
||||
[else
|
||||
#`(lambda (stx) lvar)])]))
|
||||
|
||||
(define-syntax (t-dots stx)
|
||||
(syntax-case stx ()
|
||||
;; Case 1: (x ...) where x is trusted.
|
||||
[(t-dots (t-var #s(pvar _ lvar #f _) _) _drivers 1 #f #t _)
|
||||
(begin
|
||||
(log-template-debug "dots case 1: (x ...) where x is trusted")
|
||||
#'(lambda (stx) lvar))]
|
||||
;; General case
|
||||
[(t-dots head ((#s(pvar _ lvar check? _) ...) ...) nesting tail cons? in-try?)
|
||||
(let ([cons? (syntax-e #'cons?)]
|
||||
[lvarss (map syntax->list (syntax->list #'((lvar ...) ...)))]
|
||||
[check?ss (syntax->datum #'((check? ...) ...))])
|
||||
(log-template-debug "dots general case: nesting = ~s, cons? = ~s, #vars = ~s"
|
||||
(syntax-e #'nesting) cons? (apply + (map length lvarss)))
|
||||
;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
|
||||
;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
|
||||
;; -> Syntax[(Listof AccElem) -> (Listof AccElem)]
|
||||
(define (gen-level lvars check?s inner)
|
||||
(with-syntax ([(lvar ...) lvars]
|
||||
[(var-value ...) (map var-value-expr lvars check?s)])
|
||||
#`(lambda (acc)
|
||||
(let loop ([acc acc] [lvar var-value] ...)
|
||||
(check-same-length lvar ...)
|
||||
(if (and (pair? lvar) ...)
|
||||
(loop (let ([lvar (car lvar)] ...)
|
||||
(#,inner acc)) ;; inner has free refs to {var ...}
|
||||
(cdr lvar) ...)
|
||||
acc)))))
|
||||
;; var-value-expr : Id Boolean -> Syntax[List]
|
||||
(define (var-value-expr lvar check?)
|
||||
(if check? #`(check-list/depth stx #,lvar 1 in-try?) lvar))
|
||||
(define head-loop-code
|
||||
(let nestloop ([lvarss lvarss] [check?ss check?ss] [old-lvars null] [old-check?s null])
|
||||
(cond [(null? lvarss)
|
||||
#'(lambda (acc) (cons (head stx) acc))]
|
||||
[else
|
||||
(define lvars* (append (car lvarss) old-lvars))
|
||||
(define check?s* (append (car check?ss) old-check?s))
|
||||
(gen-level lvars* check?s*
|
||||
(nestloop (cdr lvarss) (cdr check?ss) lvars* check?s*))])))
|
||||
(if cons?
|
||||
#`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))
|
||||
#`(t-dots* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))))]))
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(define (stx-cadr x) (stx-car (stx-cdr x)))
|
||||
(define (stx-cddr x) (stx-cdr (stx-cdr x)))
|
||||
(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
|
||||
(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
|
||||
(define (restx basis val)
|
||||
(if (syntax? basis) (datum->syntax basis val basis basis) val))
|
||||
|
||||
(define ((t-resyntax g) stx) (datum->syntax stx (g (syntax-e stx)) stx stx))
|
||||
(define ((t-relocate g loc) stx)
|
||||
(define new-stx (g stx))
|
||||
(datum->syntax new-stx (syntax-e new-stx) loc new-stx))
|
||||
(define ((t-resyntax/loc g loc) stx)
|
||||
(datum->syntax stx (g (syntax-e stx)) loc stx))
|
||||
|
||||
(define ((t-const) stx) stx)
|
||||
(define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx))))
|
||||
(define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx))))
|
||||
(define ((t-dots* h n t) stx) (revappend* (h (car stx)) (t (stx-drop (add1 n) stx))))
|
||||
(define ((t-dots1* h n t) stx) (revappend (h (car stx)) (t (stx-drop (add1 n) stx))))
|
||||
(define ((t-escaped g) stx) (g (stx-cadr stx)))
|
||||
(define ((t-orelse g1 g2) stx)
|
||||
(with-handlers ([absent-pvar? (lambda (e) (if g2 (g2 (stx-caddr stx)) null))])
|
||||
(g1 (stx-cadr stx))))
|
||||
(define ((t-vector g) stx) (list->vector (g (vector->list stx))))
|
||||
(define ((t-box g) stx) (box (g (unbox stx))))
|
||||
(define ((t-struct g) stx)
|
||||
(define key (prefab-struct-key stx))
|
||||
(define elems (cdr (vector->list (struct->vector stx))))
|
||||
(apply make-prefab-struct key (g elems)))
|
||||
(define ((t-metafun mf g) stx)
|
||||
(define stx* (if (syntax? stx) stx (datum->syntax #f stx)))
|
||||
(define v (restx stx* (cons (stx-car stx) (g (stx-cdr stx)))))
|
||||
(apply-metafun mf stx* v))
|
||||
(define ((h-t g) stx) (list (g stx)))
|
||||
(define (h-orelse g1 g2) (t-orelse g1 g2))
|
||||
(define ((h-splice g) stx)
|
||||
(let ([r (g (stx-cdr stx))])
|
||||
(or (stx->list r) (error/splice stx r))))
|
||||
#| end begin-encourage-inline |#)
|
||||
|
||||
(define (apply-metafun mf stx v)
|
||||
(define mark (make-syntax-introducer))
|
||||
(define old-mark (current-template-metafunction-introducer))
|
||||
(parameterize ((current-template-metafunction-introducer mark))
|
||||
(define r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v))))))
|
||||
(unless (syntax? r)
|
||||
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
|
||||
(old-mark (mark r))))
|
||||
|
||||
(define (error/splice stx r)
|
||||
(raise-syntax-error 'template "splicing template did not produce a syntax list" stx))
|
||||
|
||||
;; revappend* : (Listof (Listof X)) (Listof X) -> (Listof X)
|
||||
(define (revappend* xss ys)
|
||||
(if (null? xss) ys (revappend* (cdr xss) (append (car xss) ys))))
|
||||
|
||||
;; revappend : (Listof X) (Listof X) -> (Listof X)
|
||||
(define (revappend xs ys)
|
||||
(if (null? xs) ys (revappend (cdr xs) (cons (car xs) ys))))
|
||||
#'(begin (define internal-id (make-hygienic-metafunction expr))
|
||||
(define-syntax id (metafunction (quote-syntax internal-id)))))]))
|
||||
|
||||
(define current-template-metafunction-introducer
|
||||
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
|
||||
|
||||
;; Used to indicate absent pvar in template; ?? catches
|
||||
;; Note: not an exn, don't need continuation marks
|
||||
(struct absent-pvar (ctx))
|
||||
|
||||
(define (check-stx ctx v in-try?)
|
||||
(cond [(syntax? v) v]
|
||||
[(promise? v) (check-stx ctx (force v) in-try?)]
|
||||
[(and in-try? (eq? v #f)) (raise (absent-pvar ctx))]
|
||||
[else (err/not-syntax ctx v)]))
|
||||
|
||||
(define (check-list/depth ctx v0 depth0 in-try?)
|
||||
(let depthloop ([v v0] [depth depth0])
|
||||
(cond [(zero? depth) v]
|
||||
[(and (= depth 1) (list? v)) v]
|
||||
[else
|
||||
(let loop ([v v])
|
||||
(cond [(null? v)
|
||||
null]
|
||||
[(pair? v)
|
||||
(let ([new-car (depthloop (car v) (sub1 depth))]
|
||||
[new-cdr (loop (cdr v))])
|
||||
;; Don't copy unless necessary
|
||||
(if (and (eq? new-car (car v)) (eq? new-cdr (cdr v)))
|
||||
v
|
||||
(cons new-car new-cdr)))]
|
||||
[(promise? v)
|
||||
(loop (force v))]
|
||||
[(and in-try? (eq? v #f))
|
||||
(raise (absent-pvar ctx))]
|
||||
[else (err/not-syntax ctx v0)]))])))
|
||||
|
||||
;; FIXME: use raise-syntax-error instead, pass stx args
|
||||
(define check-same-length
|
||||
(case-lambda
|
||||
[(a) (void)]
|
||||
[(a b)
|
||||
(unless (= (length a) (length b))
|
||||
(error 'syntax "incompatible ellipsis match counts for template"))]
|
||||
[(a . bs)
|
||||
(define alen (length a))
|
||||
(for ([b (in-list bs)])
|
||||
(unless (= alen (length b))
|
||||
(error 'template "incompatible ellipsis match counts for template")))]))
|
||||
|
||||
;; Note: slightly different from error msg in syntax/parse/private/residual:
|
||||
;; here says "contains" instead of "is bound to", because might be within list
|
||||
(define (err/not-syntax ctx v)
|
||||
(raise-syntax-error #f (format "attribute contains non-syntax value\n value: ~e" v) ctx))
|
||||
(define ((make-hygienic-metafunction transformer) stx)
|
||||
(define mark (make-syntax-introducer))
|
||||
(define old-mark (current-template-metafunction-introducer))
|
||||
(parameterize ((current-template-metafunction-introducer mark))
|
||||
(define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
|
||||
(unless (syntax? r)
|
||||
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
|
||||
(old-mark (mark r))))
|
||||
|
|
|
|||
|
|
@ -10,35 +10,8 @@
|
|||
(require (for-syntax racket/private/sc "residual-ct.rkt"))
|
||||
(provide (for-syntax (all-from-out "residual-ct.rkt")))
|
||||
|
||||
(begin-for-syntax
|
||||
;; == from runtime.rkt
|
||||
|
||||
(provide make-attribute-mapping
|
||||
attribute-mapping?
|
||||
attribute-mapping-var
|
||||
attribute-mapping-name
|
||||
attribute-mapping-depth
|
||||
attribute-mapping-syntax?)
|
||||
|
||||
(define-struct attribute-mapping (var name depth syntax?)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure
|
||||
(lambda (self stx)
|
||||
(if (attribute-mapping-syntax? self)
|
||||
#`(#%expression #,(attribute-mapping-var self))
|
||||
(let ([source-name
|
||||
(or (let loop ([p (syntax-property stx 'disappeared-use)])
|
||||
(cond [(identifier? p) p]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[else #f]))
|
||||
(attribute-mapping-name self))])
|
||||
#`(let ([value #,(attribute-mapping-var self)])
|
||||
(if (syntax-list^depth? '#,(attribute-mapping-depth self) value)
|
||||
value
|
||||
(check/force-syntax-list^depth '#,(attribute-mapping-depth self)
|
||||
value
|
||||
(quote-syntax #,source-name))))))))
|
||||
)
|
||||
(require racket/private/template)
|
||||
(provide (for-syntax attribute-mapping attribute-mapping?))
|
||||
|
||||
;; ============================================================
|
||||
;; Run-time
|
||||
|
|
@ -54,10 +27,10 @@
|
|||
this-context-syntax
|
||||
attribute
|
||||
attribute-binding
|
||||
check-attr-value
|
||||
stx-list-take
|
||||
stx-list-drop/cx
|
||||
datum->syntax/with-clause
|
||||
check/force-syntax-list^depth
|
||||
check-literal*
|
||||
error/null-eh-match
|
||||
begin-for-syntax/once
|
||||
|
|
@ -113,7 +86,7 @@
|
|||
(if (attribute-mapping? value)
|
||||
#`(quote #,(make-attr (attribute-mapping-name value)
|
||||
(attribute-mapping-depth value)
|
||||
(attribute-mapping-syntax? value)))
|
||||
(if (attribute-mapping-check value) #f #t)))
|
||||
#'(quote #f)))
|
||||
#'(quote #f)))]))
|
||||
|
||||
|
|
@ -136,60 +109,28 @@
|
|||
(if (syntax? x) x cx)
|
||||
(sub1 n)))))
|
||||
|
||||
;; check/force-syntax-list^depth : nat any id -> (listof^depth syntax)
|
||||
;; Checks that value is (listof^depth syntax); forces promises.
|
||||
;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already.
|
||||
(define (check/force-syntax-list^depth depth value0 source-id)
|
||||
(define (bad sub-depth sub-value)
|
||||
(attribute-not-syntax-error depth value0 source-id sub-depth sub-value))
|
||||
(define (loop depth value)
|
||||
(cond [(promise? value)
|
||||
(loop depth (force value))]
|
||||
[(zero? depth)
|
||||
(if (syntax? value) value (bad depth value))]
|
||||
[else (loop-list depth value)]))
|
||||
(define (loop-list depth value)
|
||||
(cond [(promise? value)
|
||||
(loop-list depth (force value))]
|
||||
[(pair? value)
|
||||
(let ([new-car (loop (sub1 depth) (car value))]
|
||||
[new-cdr (loop-list depth (cdr value))])
|
||||
;; Don't copy unless necessary
|
||||
(if (and (eq? new-car (car value))
|
||||
(eq? new-cdr (cdr value)))
|
||||
value
|
||||
(cons new-car new-cdr)))]
|
||||
[(null? value)
|
||||
null]
|
||||
[else
|
||||
(bad depth value)]))
|
||||
(loop depth value0))
|
||||
|
||||
(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value)
|
||||
(raise-syntax-error #f
|
||||
(format (string-append "bad attribute value for syntax template"
|
||||
"\n attribute value: ~e"
|
||||
"\n expected for attribute: ~a"
|
||||
"\n sub-value: ~e"
|
||||
"\n expected for sub-value: ~a")
|
||||
value0
|
||||
(describe-depth depth0)
|
||||
sub-value
|
||||
(describe-depth sub-depth))
|
||||
source-id))
|
||||
|
||||
(define (describe-depth depth)
|
||||
(cond [(zero? depth) "syntax"]
|
||||
[else (format "list of depth ~s of syntax" depth)]))
|
||||
|
||||
;; syntax-list^depth? : nat any -> boolean
|
||||
;; Returns true iff value is (listof^depth syntax).
|
||||
(define (syntax-list^depth? depth value)
|
||||
(if (zero? depth)
|
||||
(syntax? value)
|
||||
(and (list? value)
|
||||
(for/and ([part (in-list value)])
|
||||
(syntax-list^depth? (sub1 depth) part)))))
|
||||
;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
|
||||
(define (check-attr-value v0 depth0 base? ctx)
|
||||
(define (bad kind v)
|
||||
(raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
|
||||
(define (depthloop depth v)
|
||||
(if (zero? depth)
|
||||
(if base? (baseloop v) v)
|
||||
(let listloop ([v v] [root? #t])
|
||||
(cond [(null? v) null]
|
||||
[(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
|
||||
[new-cdr (listloop (cdr v) #f)])
|
||||
(cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v]
|
||||
[else (cons new-car new-cdr)]))]
|
||||
[(promise? v) (listloop (force v) root?)]
|
||||
[(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
|
||||
[else (bad 'list v)]))))
|
||||
(define (baseloop v)
|
||||
(cond [(syntax? v) v]
|
||||
[(promise? v) (baseloop (force v))]
|
||||
[(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
|
||||
[else (bad 'syntax v)]))
|
||||
(depthloop depth0 v0))
|
||||
|
||||
;; datum->syntax/with-clause : any -> syntax
|
||||
(define (datum->syntax/with-clause x)
|
||||
|
|
|
|||
|
|
@ -106,8 +106,9 @@ residual.rkt.
|
|||
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
|
||||
[(stmp ...) (generate-temporaries #'(name ...))])
|
||||
#'(letrec-syntaxes+values
|
||||
([(stmp) (make-attribute-mapping (quote-syntax vtmp)
|
||||
'name 'depth 'syntax?)] ...)
|
||||
([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth
|
||||
(if 'syntax? #f (quote-syntax check-attr-value)))]
|
||||
...)
|
||||
([(vtmp) value] ...)
|
||||
(letrec-syntaxes+values
|
||||
([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
|
||||
|
|
@ -143,8 +144,8 @@ residual.rkt.
|
|||
[(stmp ...) (generate-temporaries #'(name ...))])
|
||||
#'(begin (define-values (vtmp ...) (apply values packed))
|
||||
(define-syntax stmp
|
||||
(make-attribute-mapping (quote-syntax vtmp)
|
||||
'name 'depth 'syntax?))
|
||||
(attribute-mapping (quote-syntax vtmp) 'name 'depth
|
||||
(if 'syntax? #f (quote-syntax check-attr-value))))
|
||||
...
|
||||
(define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
|
||||
...)))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user