add datum-case', etc. as syntax/datum'
This library is used by Redex, which wants a `syntax'-like template language, but for datum values instead of syntax objects. Using `datum-case' and `datum' generates much less code. Redex uses only a small part of the general functionality, so adding `syntax/datum' could be overkill. It's implemented by generalizing the `syntax-case' and `syntax' pattern matching and template constructing code, though; it's not a lot of extra code, and it's easiest to generalize completely. We may find other uses for datum templates, too.
This commit is contained in:
Matthew Flatt
parent
09402178db
commit
25dd8727cb
|
|
@ -29,8 +29,8 @@
|
|||
-regexp-replace*)
|
||||
(rename -regexp-replace* regexp-replace*)
|
||||
identifier?
|
||||
(all-from "stxcase-scheme.rkt")
|
||||
(all-from "qqstx.rkt")
|
||||
(all-from-except "stxcase-scheme.rkt" datum datum-case with-datum)
|
||||
(all-from-except "qqstx.rkt" quasidatum undatum undatum-splicing)
|
||||
(all-from "namespace.rkt")
|
||||
(all-from "cert.rkt")
|
||||
(for-syntax syntax-rules syntax-id-rules ... _)
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@
|
|||
(syntax/loc stx
|
||||
(define-syntax name
|
||||
(lambda (user-stx)
|
||||
(syntax-case** dr #t user-stx () free-identifier=?
|
||||
(syntax-case** dr #t user-stx () free-identifier=? #f
|
||||
[(_ . pattern) (syntax-protect (syntax/loc user-stx template))]
|
||||
[_ (pattern-failure user-stx 'pattern)]))))]
|
||||
[(_ (name . ptrn) tmpl) (err "expected an identifier" #'name)]
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(for-syntax '#%kernel
|
||||
"stxcase-scheme.rkt"))
|
||||
|
||||
(#%provide define-struct let-struct datum)
|
||||
(#%provide define-struct let-struct old-datum)
|
||||
|
||||
(define-syntaxes (define-struct)
|
||||
(lambda (stx)
|
||||
|
|
@ -28,6 +28,6 @@
|
|||
(define-struct base (field ...))
|
||||
body1 body ...)]))
|
||||
|
||||
(define-syntaxes (datum)
|
||||
(define-syntaxes (old-datum)
|
||||
(syntax-rules ()
|
||||
[(_ . any) (quote any)])))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,10 @@
|
|||
(#%provide quasisyntax
|
||||
quasisyntax/loc
|
||||
unsyntax
|
||||
unsyntax-splicing)
|
||||
unsyntax-splicing
|
||||
quasidatum
|
||||
undatum
|
||||
undatum-splicing)
|
||||
|
||||
(define-syntaxes (unsyntax unsyntax-splicing)
|
||||
(let ([f (lambda (stx)
|
||||
|
|
@ -18,6 +21,14 @@
|
|||
stx))])
|
||||
(values f f)))
|
||||
|
||||
(define-syntaxes (undatum undatum-splicing)
|
||||
(let ([f (lambda (stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"illegal outside of quasidatum"
|
||||
stx))])
|
||||
(values f f)))
|
||||
|
||||
(-define (check-splicing-list l ctx)
|
||||
(unless (stx-list? l)
|
||||
(raise-type-error
|
||||
|
|
@ -26,184 +37,212 @@
|
|||
l))
|
||||
(datum->syntax ctx l ctx))
|
||||
|
||||
(define-syntaxes (quasisyntax quasisyntax/loc)
|
||||
(let ([qq
|
||||
(lambda (orig-stx body mk-final)
|
||||
(let ([here-stx #'here])
|
||||
(let loop ([stx body]
|
||||
[depth 0]
|
||||
[same-k (lambda ()
|
||||
(datum->syntax
|
||||
here-stx
|
||||
(mk-final body)
|
||||
orig-stx))]
|
||||
[convert-k (lambda (body bindings)
|
||||
(datum->syntax
|
||||
here-stx
|
||||
(list
|
||||
(quote-syntax with-syntax)
|
||||
bindings
|
||||
(mk-final body))
|
||||
orig-stx))])
|
||||
(syntax-case stx (unsyntax unsyntax-splicing quasisyntax)
|
||||
[(unsyntax x)
|
||||
(if (zero? depth)
|
||||
(let ([temp (car (generate-temporaries '(uq)))])
|
||||
(convert-k temp (list (list temp (syntax x)))))
|
||||
(loop (syntax x) (sub1 depth)
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
here-stx
|
||||
(list (stx-car stx) v)
|
||||
stx)
|
||||
bindings))))]
|
||||
[unsyntax
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse within quasisyntax"
|
||||
orig-stx
|
||||
stx)]
|
||||
[((unsyntax-splicing x) . rest)
|
||||
(if (zero? depth)
|
||||
(if (stx-null? (syntax rest))
|
||||
(with-syntax ([temp (car (generate-temporaries '(uqs1)))])
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(syntax temp)
|
||||
stx)
|
||||
(list #'[temp x])))
|
||||
(let ([rest-done-k
|
||||
(lambda (rest-v bindings)
|
||||
(with-syntax ([temp (car (generate-temporaries '(uqs)))]
|
||||
[ctx (datum->syntax #'x 'ctx #'x)])
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list* (syntax temp)
|
||||
(quote-syntax ...)
|
||||
rest-v)
|
||||
stx)
|
||||
(cons #'[(temp (... ...)) (check-splicing-list x (quote-syntax ctx))]
|
||||
bindings))))])
|
||||
(loop (syntax rest) depth
|
||||
(lambda ()
|
||||
(rest-done-k (syntax rest) null))
|
||||
rest-done-k)))
|
||||
(let ([mk-rest-done-k
|
||||
(lambda (x-v x-bindings)
|
||||
(lambda (rest-v rest-bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(cons x-v rest-v)
|
||||
stx)
|
||||
(append x-bindings
|
||||
rest-bindings))))])
|
||||
(loop (syntax x) (sub1 depth)
|
||||
(lambda ()
|
||||
;; x is unchanged.
|
||||
(loop (syntax rest) depth
|
||||
same-k
|
||||
(mk-rest-done-k (stx-car stx) null)))
|
||||
(lambda (x-v x-bindings)
|
||||
;; x is generated by x-v
|
||||
(let ([rest-done-k (mk-rest-done-k
|
||||
(datum->syntax
|
||||
(stx-car stx)
|
||||
(list (stx-car (stx-car stx)) x-v)
|
||||
(stx-car stx))
|
||||
x-bindings)])
|
||||
(loop (syntax rest) depth
|
||||
(lambda ()
|
||||
;; rest is unchanged
|
||||
(rest-done-k (syntax rest) null))
|
||||
rest-done-k))))))]
|
||||
[unsyntax-splicing
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse within quasisyntax"
|
||||
orig-stx
|
||||
stx)]
|
||||
[(quasisyntax x)
|
||||
(loop (syntax x) (add1 depth)
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list (stx-car stx) v)
|
||||
stx)
|
||||
bindings)))]
|
||||
[_
|
||||
(cond
|
||||
;; We treat pairs specially so that we don't generate a lot
|
||||
;; of syntax objects when the input syntax collapses a list
|
||||
;; into a single syntax object.
|
||||
[(pair? (syntax-e stx))
|
||||
(let ploop ([l (syntax-e stx)]
|
||||
[same-k same-k]
|
||||
[convert-k (lambda (l bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
l
|
||||
stx)
|
||||
bindings))])
|
||||
(cond
|
||||
[(pair? l)
|
||||
(if (let ([a (car l)])
|
||||
(or (and (identifier? a)
|
||||
(or (free-identifier=? a (quote-syntax unsyntax))
|
||||
(free-identifier=? a (quote-syntax quasisyntax))))
|
||||
(and (stx-pair? a)
|
||||
(let ([a (stx-car a)])
|
||||
(and (identifier? a)
|
||||
(free-identifier=? a (quote-syntax unsyntax-splicing)))))))
|
||||
;; Found something important, like `unsyntax'; stop the special
|
||||
;; handling for pairs
|
||||
(loop (datum->syntax #f l #f) depth
|
||||
same-k
|
||||
convert-k)
|
||||
;; Normal special pair handling
|
||||
(ploop (cdr l)
|
||||
(lambda ()
|
||||
;; rest is the same
|
||||
(loop (car l) depth
|
||||
same-k
|
||||
(lambda (a a-bindings)
|
||||
(convert-k (cons (datum->syntax
|
||||
(car l)
|
||||
a
|
||||
(car l))
|
||||
(cdr l))
|
||||
a-bindings))))
|
||||
(lambda (rest rest-bindings)
|
||||
(loop (car l) depth
|
||||
(lambda ()
|
||||
(convert-k (cons (car l) rest)
|
||||
rest-bindings))
|
||||
(lambda (a a-bindings)
|
||||
(convert-k (cons (datum->syntax
|
||||
(car l)
|
||||
a
|
||||
(car l))
|
||||
rest)
|
||||
(append a-bindings
|
||||
rest-bindings)))))))]
|
||||
[(null? l) (same-k)]
|
||||
[else (loop l depth same-k convert-k)]))]
|
||||
[(vector? (syntax-e stx))
|
||||
(loop (datum->syntax
|
||||
stx
|
||||
(vector->list (syntax-e stx))
|
||||
stx)
|
||||
depth
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list->vector (syntax->list v))
|
||||
stx)
|
||||
bindings)))]
|
||||
[else
|
||||
(same-k)])]))))])
|
||||
(-define (check-splicing-datum-list l ctx)
|
||||
(unless (list? l)
|
||||
(raise-type-error
|
||||
'undatum-splicing
|
||||
"proper list"
|
||||
l))
|
||||
l)
|
||||
|
||||
(define-syntaxes (quasisyntax quasisyntax/loc quasidatum)
|
||||
(let* ([gen-qq
|
||||
(lambda (orig-stx body mk-final who unsyntax-id unsyntax-splicing-id quasisyntax-id
|
||||
with-syntax-id check-splicing-list-id)
|
||||
(let ([here-stx #'here])
|
||||
(let loop ([stx body]
|
||||
[depth 0]
|
||||
[same-k (lambda ()
|
||||
(datum->syntax
|
||||
here-stx
|
||||
(mk-final body)
|
||||
orig-stx))]
|
||||
[convert-k (lambda (body bindings)
|
||||
(datum->syntax
|
||||
here-stx
|
||||
(list
|
||||
with-syntax-id
|
||||
bindings
|
||||
(mk-final body))
|
||||
orig-stx))])
|
||||
(syntax-case stx ()
|
||||
[(us x)
|
||||
(and (identifier? #'us)
|
||||
(free-identifier=? #'us unsyntax-id))
|
||||
(if (zero? depth)
|
||||
(let ([temp (car (generate-temporaries '(uq)))])
|
||||
(convert-k temp (list (list temp (syntax x)))))
|
||||
(loop (syntax x) (sub1 depth)
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
here-stx
|
||||
(list (stx-car stx) v)
|
||||
stx)
|
||||
bindings))))]
|
||||
[us
|
||||
(and (identifier? #'us)
|
||||
(free-identifier=? #'us unsyntax-id))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "misuse within ~a" who)
|
||||
orig-stx
|
||||
stx)]
|
||||
[((us-s x) . rest)
|
||||
(and (identifier? #'us-s)
|
||||
(free-identifier=? #'us-s unsyntax-splicing-id))
|
||||
(if (zero? depth)
|
||||
(if (stx-null? (syntax rest))
|
||||
(with-syntax ([temp (car (generate-temporaries '(uqs1)))])
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(syntax temp)
|
||||
stx)
|
||||
(list #'[temp x])))
|
||||
(let ([rest-done-k
|
||||
(lambda (rest-v bindings)
|
||||
(with-syntax ([temp (car (generate-temporaries '(uqs)))]
|
||||
[ctx (datum->syntax #'x 'ctx #'x)])
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list* (syntax temp)
|
||||
(quote-syntax ...)
|
||||
rest-v)
|
||||
stx)
|
||||
(with-syntax ([check check-splicing-list-id])
|
||||
(cons #'[(temp (... ...)) (check x (quote-syntax ctx))]
|
||||
bindings)))))])
|
||||
(loop (syntax rest) depth
|
||||
(lambda ()
|
||||
(rest-done-k (syntax rest) null))
|
||||
rest-done-k)))
|
||||
(let ([mk-rest-done-k
|
||||
(lambda (x-v x-bindings)
|
||||
(lambda (rest-v rest-bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(cons x-v rest-v)
|
||||
stx)
|
||||
(append x-bindings
|
||||
rest-bindings))))])
|
||||
(loop (syntax x) (sub1 depth)
|
||||
(lambda ()
|
||||
;; x is unchanged.
|
||||
(loop (syntax rest) depth
|
||||
same-k
|
||||
(mk-rest-done-k (stx-car stx) null)))
|
||||
(lambda (x-v x-bindings)
|
||||
;; x is generated by x-v
|
||||
(let ([rest-done-k (mk-rest-done-k
|
||||
(datum->syntax
|
||||
(stx-car stx)
|
||||
(list (stx-car (stx-car stx)) x-v)
|
||||
(stx-car stx))
|
||||
x-bindings)])
|
||||
(loop (syntax rest) depth
|
||||
(lambda ()
|
||||
;; rest is unchanged
|
||||
(rest-done-k (syntax rest) null))
|
||||
rest-done-k))))))]
|
||||
[us-s
|
||||
(and (identifier? #'us-s)
|
||||
(free-identifier=? #'us-s unsyntax-splicing-id))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse within quasisyntax"
|
||||
orig-stx
|
||||
stx)]
|
||||
[(qs x)
|
||||
(and (identifier? #'qs)
|
||||
(free-identifier=? #'qs quasisyntax-id))
|
||||
(loop (syntax x) (add1 depth)
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list (stx-car stx) v)
|
||||
stx)
|
||||
bindings)))]
|
||||
[_
|
||||
(cond
|
||||
;; We treat pairs specially so that we don't generate a lot
|
||||
;; of syntax objects when the input syntax collapses a list
|
||||
;; into a single syntax object.
|
||||
[(pair? (syntax-e stx))
|
||||
(let ploop ([l (syntax-e stx)]
|
||||
[same-k same-k]
|
||||
[convert-k (lambda (l bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
l
|
||||
stx)
|
||||
bindings))])
|
||||
(cond
|
||||
[(pair? l)
|
||||
(if (let ([a (car l)])
|
||||
(or (and (identifier? a)
|
||||
(or (free-identifier=? a unsyntax-id)
|
||||
(free-identifier=? a quasisyntax-id)))
|
||||
(and (stx-pair? a)
|
||||
(let ([a (stx-car a)])
|
||||
(and (identifier? a)
|
||||
(free-identifier=? a unsyntax-splicing-id))))))
|
||||
;; Found something important, like `unsyntax'; stop the special
|
||||
;; handling for pairs
|
||||
(loop (datum->syntax #f l #f) depth
|
||||
same-k
|
||||
convert-k)
|
||||
;; Normal special pair handling
|
||||
(ploop (cdr l)
|
||||
(lambda ()
|
||||
;; rest is the same
|
||||
(loop (car l) depth
|
||||
same-k
|
||||
(lambda (a a-bindings)
|
||||
(convert-k (cons (datum->syntax
|
||||
(car l)
|
||||
a
|
||||
(car l))
|
||||
(cdr l))
|
||||
a-bindings))))
|
||||
(lambda (rest rest-bindings)
|
||||
(loop (car l) depth
|
||||
(lambda ()
|
||||
(convert-k (cons (car l) rest)
|
||||
rest-bindings))
|
||||
(lambda (a a-bindings)
|
||||
(convert-k (cons (datum->syntax
|
||||
(car l)
|
||||
a
|
||||
(car l))
|
||||
rest)
|
||||
(append a-bindings
|
||||
rest-bindings)))))))]
|
||||
[(null? l) (same-k)]
|
||||
[else (loop l depth same-k convert-k)]))]
|
||||
[(vector? (syntax-e stx))
|
||||
(loop (datum->syntax
|
||||
stx
|
||||
(vector->list (syntax-e stx))
|
||||
stx)
|
||||
depth
|
||||
same-k
|
||||
(lambda (v bindings)
|
||||
(convert-k (datum->syntax
|
||||
stx
|
||||
(list->vector (syntax->list v))
|
||||
stx)
|
||||
bindings)))]
|
||||
[else
|
||||
(same-k)])]))))]
|
||||
[qq (lambda (orig-stx body mk-final)
|
||||
(gen-qq orig-stx body mk-final
|
||||
'quasisyntax
|
||||
(quote-syntax unsyntax)
|
||||
(quote-syntax unsyntax-splicing)
|
||||
(quote-syntax quasisyntax)
|
||||
(quote-syntax with-syntax)
|
||||
(quote-syntax check-splicing-list)))])
|
||||
(values (lambda (orig-stx)
|
||||
(syntax-case orig-stx ()
|
||||
[(_ stx) (qq orig-stx
|
||||
|
|
@ -217,4 +256,16 @@
|
|||
(lambda (body)
|
||||
(list (quote-syntax syntax/loc)
|
||||
(syntax loc)
|
||||
body)))]))))))
|
||||
body)))]))
|
||||
(lambda (orig-stx)
|
||||
(syntax-case orig-stx ()
|
||||
[(_ stx) (gen-qq orig-stx
|
||||
(syntax stx)
|
||||
(lambda (body)
|
||||
(list (quote-syntax datum) body))
|
||||
'quasidatum
|
||||
(quote-syntax undatum)
|
||||
(quote-syntax undatum-splicing)
|
||||
(quote-syntax quasidatum-splicing)
|
||||
(quote-syntax with-datum)
|
||||
(quote-syntax check-splicing-datum-list))]))))))
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@
|
|||
;; does not contain the pattern variables as "keys", since the positions
|
||||
;; can also be determined by the prototype.
|
||||
;;
|
||||
(-define (make-match&env/extract-vars who top p k just-vars? phase-param? interp-box)
|
||||
(-define (make-match&env/extract-vars who top p k just-vars? phase-param? interp-box s-exp?)
|
||||
;; The m&e function returns three values. If just-vars? is true,
|
||||
;; only the first result is used, and it is the variable list.
|
||||
;; Otherwise, the first result is the code assuming an input bound to `e'.
|
||||
|
|
@ -109,17 +109,19 @@
|
|||
(length nest-vars)
|
||||
last?)
|
||||
`(lambda (e)
|
||||
(if (stx-list? e)
|
||||
(if (,(if s-exp? 'list? 'stx-list?) e)
|
||||
,(let ([b (app-e match-head)])
|
||||
(if (equal? b '(list e))
|
||||
(if last?
|
||||
'(stx->list e)
|
||||
'(list (stx->list e)))
|
||||
(if s-exp?
|
||||
(if last? 'e '(list e))
|
||||
(if last?
|
||||
'(stx->list e)
|
||||
'(list (stx->list e))))
|
||||
(if (null? nest-vars)
|
||||
`(andmap (lambda (e) ,b) (stx->list e))
|
||||
`(andmap (lambda (e) ,b) ,(if s-exp? 'e '(stx->list e)))
|
||||
`(let/ec esc
|
||||
(let ([l (map (lambda (e) (stx-check/esc ,b esc))
|
||||
(stx->list e))])
|
||||
,(if s-exp? 'e '(stx->list e)))])
|
||||
(if (null? l)
|
||||
(quote ,(let ([empties (map (lambda (v) '()) nest-vars)])
|
||||
(if last?
|
||||
|
|
@ -178,7 +180,7 @@
|
|||
(if mh-did-var?
|
||||
(app-append apph appt)
|
||||
`(if ,apph ,appt #f)))])
|
||||
(if cap?
|
||||
(if (and cap? (not s-exp?))
|
||||
(if id-is-rest?
|
||||
`(let ([cap (if (syntax? e) e cap)]) ,s)
|
||||
`(let ([cap e]) ,s))
|
||||
|
|
@ -221,15 +223,15 @@
|
|||
mh-did-var?
|
||||
mt-did-var?)
|
||||
`(lambda (e)
|
||||
(if (stx-pair? e)
|
||||
,(let ([s (let ([apph (app match-head '(stx-car e))]
|
||||
[appt (app match-tail '(stx-cdr e))])
|
||||
(if (,(if s-exp? 'pair? 'stx-pair?) e)
|
||||
,(let ([s (let ([apph (app match-head (if s-exp? '(car e) '(stx-car e)))]
|
||||
[appt (app match-tail (if s-exp? '(cdr e) '(stx-cdr e)))])
|
||||
(if mh-did-var?
|
||||
(if mt-did-var?
|
||||
(app-append apph appt)
|
||||
`(let ([mh ,apph]) (and mh ,appt mh)))
|
||||
`(if ,apph ,appt #f)))])
|
||||
(if cap?
|
||||
(if (and cap? (not s-exp?))
|
||||
(if id-is-rest?
|
||||
`(let ([cap (if (syntax? e) e cap)]) ,s)
|
||||
`(let ([cap e]) ,s))
|
||||
|
|
@ -242,7 +244,9 @@
|
|||
(values null #f #f)
|
||||
(values (if interp-box
|
||||
'()
|
||||
'stx-null/#f)
|
||||
(if s-exp?
|
||||
'(lambda (e) (if (null? e) null #f))
|
||||
'stx-null/#f))
|
||||
#f
|
||||
#f))]
|
||||
[(identifier? p)
|
||||
|
|
@ -264,11 +268,11 @@
|
|||
(sub1 (length (unbox interp-box))))))])
|
||||
pos)
|
||||
`(lambda (e)
|
||||
(if (identifier? e)
|
||||
(if (,(if s-exp? 'symbol? 'identifier?) e)
|
||||
;; This free-identifier=? can be turned into
|
||||
;; free-transformer-identifier=? by an
|
||||
;; enclosing binding.
|
||||
(if (free-identifier=? e (quote-syntax ,p))
|
||||
(if (free-identifier=? e (,(if s-exp? 'quote 'quote-syntax) ,p))
|
||||
null
|
||||
#f)
|
||||
#f)))
|
||||
|
|
@ -300,7 +304,7 @@
|
|||
(let ([wrap (if last?
|
||||
(lambda (x) `(lambda (e) ,x))
|
||||
(lambda (x) `(lambda (e) (list ,x))))])
|
||||
(if id-is-rest?
|
||||
(if (and id-is-rest? (not s-exp?))
|
||||
(wrap '(datum->syntax cap e cap))
|
||||
(wrap 'e))))
|
||||
#t
|
||||
|
|
@ -320,7 +324,9 @@
|
|||
(if interp-box
|
||||
(vector 'vector len body)
|
||||
`(lambda (e)
|
||||
(if (stx-vector? e ,len)
|
||||
(if ,(if s-exp?
|
||||
`(and (vector? e) (= ,len (vector-length e)))
|
||||
`(stx-vector? e ,len))
|
||||
,body
|
||||
#f)))
|
||||
did-var?
|
||||
|
|
@ -332,7 +338,9 @@
|
|||
(or did-var? elem-did-var?)
|
||||
(if interp-box
|
||||
(cons (cons match-elem elem-did-var?) body)
|
||||
(let ([app-elem (app match-elem `(stx-vector-ref e ,(sub1 pos)))])
|
||||
(let ([app-elem (app match-elem `(,(if s-exp? 'vector-ref 'stx-vector-ref)
|
||||
e
|
||||
,(sub1 pos)))])
|
||||
(if (null? body)
|
||||
app-elem
|
||||
(if elem-did-var?
|
||||
|
|
@ -346,8 +354,10 @@
|
|||
(if interp-box
|
||||
(vector 'veclist match-content)
|
||||
`(lambda (e)
|
||||
(if (stx-vector? e #f)
|
||||
,(app match-content '(vector->list (syntax-e e)))
|
||||
(if ,(if s-exp?
|
||||
'(vector? e)
|
||||
'(stx-vector? e #f))
|
||||
,(app match-content `(vector->list ,(if s-exp? 'e '(syntax-e e))))
|
||||
#f)))
|
||||
did-var?
|
||||
#f)))))]
|
||||
|
|
@ -364,7 +374,9 @@
|
|||
(if interp-box
|
||||
(vector 'prefab key match-content)
|
||||
`(lambda (e)
|
||||
(if (stx-prefab? ',key e)
|
||||
(if ,(if s-exp?
|
||||
`(equal? ',key (prefab-struct-key e))
|
||||
`(stx-prefab? ',key e))
|
||||
,(app match-content '(cdr (vector->list (struct->vector (syntax-e e)))))
|
||||
#f)))
|
||||
did-var?
|
||||
|
|
@ -416,17 +428,17 @@
|
|||
null))
|
||||
,(app-e r)))))))
|
||||
|
||||
(-define (make-match&env who top p k phase-param?)
|
||||
(make-match&env/extract-vars who top p k #f phase-param? #f))
|
||||
(-define (make-match&env who top p k phase-param? s-exp?)
|
||||
(make-match&env/extract-vars who top p k #f phase-param? #f s-exp?))
|
||||
|
||||
(-define (get-match-vars who top p k)
|
||||
(make-match&env/extract-vars who top p k #t #f #f))
|
||||
(make-match&env/extract-vars who top p k #t #f #f #f))
|
||||
|
||||
(-define (make-interp-match p keys interp-box)
|
||||
(-define (make-interp-match p keys interp-box s-exp?)
|
||||
(make-match&env/extract-vars (quote-syntax interp)
|
||||
#f p
|
||||
keys
|
||||
#f #f interp-box))
|
||||
#f #f interp-box s-exp?))
|
||||
|
||||
;; Create an S-expression that applies
|
||||
;; rest to `e'. Optimize ((lambda (e) E) e) to E.
|
||||
|
|
@ -483,7 +495,7 @@
|
|||
;; 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)
|
||||
(-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
|
||||
|
|
@ -616,7 +628,7 @@
|
|||
(let ([v (if (eq? post 'null)
|
||||
pre
|
||||
`(append ,pre ,post))])
|
||||
(if (and (not need-list?) (syntax? p))
|
||||
(if (and (not need-list?) (syntax? p) (not s-exp?))
|
||||
;; Keep srcloc, properties, etc.:
|
||||
(let ([small-dest (datum->syntax p
|
||||
'dest
|
||||
|
|
@ -643,14 +655,14 @@
|
|||
[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))
|
||||
,(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 (stx->list ,(apply-to-r e))))
|
||||
(list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e))))
|
||||
;; variables were hashed
|
||||
(void)))]
|
||||
[(and (syntax? p)
|
||||
|
|
@ -659,13 +671,14 @@
|
|||
(let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)])
|
||||
(if proto-r
|
||||
`(lambda (r)
|
||||
(apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) (stx->list ,(apply-to-r e))))
|
||||
(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) (quote-syntax ,p))
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))
|
||||
(void))
|
||||
(if proto-r
|
||||
(let ((x (stx-memq p proto-r)))
|
||||
|
|
@ -680,7 +693,7 @@
|
|||
top
|
||||
p))
|
||||
(check-not-pattern p proto-r)
|
||||
`(lambda (r) (quote-syntax ,p)))))
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)))))
|
||||
(unless (and (...? p)
|
||||
use-ellipses?)
|
||||
(hash! p))))]
|
||||
|
|
@ -690,7 +703,7 @@
|
|||
`(lambda (r) null)
|
||||
(void))]
|
||||
[else (if proto-r
|
||||
`(lambda (r) (quote-syntax ,p))
|
||||
`(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))
|
||||
(void))]))
|
||||
(let* ([ht (if proto-r
|
||||
#f
|
||||
|
|
@ -712,8 +725,9 @@
|
|||
(if proto-r
|
||||
`(lambda (r)
|
||||
,(let ([main (let ([build (apply-to-r l)])
|
||||
(if (and (pair? build)
|
||||
(eq? (car build) 'pattern-substitute))
|
||||
(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
|
||||
|
|
@ -753,52 +767,58 @@
|
|||
;; 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)
|
||||
(-define (apply-cons stx h t p sub-gensym s-exp?)
|
||||
(cond
|
||||
[(and (pair? h)
|
||||
(eq? (car h) 'quote-syntax)
|
||||
(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) 'quote-syntax)
|
||||
(eq? (car t) (car h))
|
||||
(eq? (cadr t) (stx-cdr p)))))
|
||||
`(quote-syntax ,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)
|
||||
(eq? (car h) 'quote-syntax)
|
||||
(or (eq? (car h) 'quote-syntax)
|
||||
(eq? (car h) 'quote))
|
||||
(eq? (cadr h) (stx-car p)))
|
||||
;; Just extend constant part:
|
||||
`(pattern-substitute
|
||||
(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)))
|
||||
(,(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? 'pattern-substitute (car h)))
|
||||
(eq? (car t) #| = 'pattern-substitute |# (car h)))
|
||||
;; Combine two pattern substitutions:
|
||||
`(pattern-substitute (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))]
|
||||
`(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)]
|
||||
|
|
@ -811,34 +831,54 @@
|
|||
stx)
|
||||
expr)])
|
||||
`(pattern-substitute
|
||||
(quote-syntax ,expr)
|
||||
(,(if s-exp? 'quote 'quote-syntax) ,expr)
|
||||
,id ,h
|
||||
. ,(cddr t)))])]
|
||||
[(eq? t 'null)
|
||||
(apply-cons stx h
|
||||
`(pattern-substitute (quote-syntax ()))
|
||||
p
|
||||
sub-gensym)]
|
||||
|
||||
[(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)]
|
||||
[(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
|
||||
;; 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)]))
|
||||
|
||||
;; 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))))
|
||||
|
||||
|
|
@ -1022,22 +1062,23 @@
|
|||
(not (...? stx))]
|
||||
[else #t]))
|
||||
|
||||
(-define (raise-pattern-error self stx)
|
||||
(if (identifier? stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern variable cannot be used outside of a template"
|
||||
stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern variable cannot be used outside of a template"
|
||||
stx
|
||||
(if (free-identifier=? (quote-syntax set!) (stx-car stx))
|
||||
(stx-car (stx-cdr stx))
|
||||
(stx-car stx)))))
|
||||
|
||||
;; Structure for communicating first-order pattern variable information:
|
||||
(define-values (struct:syntax-mapping -make-syntax-mapping -syntax-mapping? syntax-mapping-ref syntax-mapping-set!)
|
||||
(make-struct-type 'syntax-mapping #f 2 0 #f null (current-inspector)
|
||||
(lambda (self stx)
|
||||
(if (identifier? stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern variable cannot be used outside of a template"
|
||||
stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern variable cannot be used outside of a template"
|
||||
stx
|
||||
(if (free-identifier=? (quote-syntax set!) (stx-car stx))
|
||||
(stx-car (stx-cdr stx))
|
||||
(stx-car stx)))))))
|
||||
(make-struct-type 'syntax-mapping #f 2 0 #f null (current-inspector) raise-pattern-error))
|
||||
(-define (make-syntax-mapping depth valvar)
|
||||
(make-set!-transformer (-make-syntax-mapping depth valvar)))
|
||||
(-define (syntax-pattern-variable? v)
|
||||
|
|
@ -1048,8 +1089,23 @@
|
|||
(-define (syntax-mapping-valvar v)
|
||||
(syntax-mapping-ref (set!-transformer-procedure v) 1))
|
||||
|
||||
;; Ditto for S-expression patterns:
|
||||
(define-values (struct:s-exp-mapping -make-s-exp-mapping -s-exp-mapping? s-exp-mapping-ref s-exp-mapping-set!)
|
||||
(make-struct-type 's-exp-mapping #f 2 0 #f null (current-inspector) raise-pattern-error))
|
||||
(-define (make-s-exp-mapping depth valvar)
|
||||
(make-set!-transformer (-make-s-exp-mapping depth valvar)))
|
||||
(-define (s-exp-pattern-variable? v)
|
||||
(and (set!-transformer? v)
|
||||
(-s-exp-mapping? (set!-transformer-procedure v))))
|
||||
(-define (s-exp-mapping-depth v)
|
||||
(s-exp-mapping-ref (set!-transformer-procedure v) 0))
|
||||
(-define (s-exp-mapping-valvar v)
|
||||
(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?
|
||||
s-exp-mapping-depth s-exp-mapping-valvar
|
||||
stx-memq-pos no-ellipses?)))
|
||||
|
|
|
|||
|
|
@ -40,26 +40,26 @@
|
|||
;; From Dybvig, mostly:
|
||||
(-define-syntax syntax-rules
|
||||
(lambda (stx)
|
||||
(syntax-case** syntax-rules #t stx () free-identifier=?
|
||||
(syntax-case** syntax-rules #t stx () free-identifier=? #f
|
||||
((sr (k ...) ((keyword . pattern) template) ...)
|
||||
(andmap identifier? (syntax->list (syntax (k ...))))
|
||||
(begin
|
||||
(check-sr-rules stx (syntax (keyword ...)))
|
||||
(syntax/loc stx
|
||||
(lambda (x)
|
||||
(syntax-case** sr #t x (k ...) free-identifier=?
|
||||
(syntax-case** sr #t x (k ...) free-identifier=? #f
|
||||
((_ . pattern) (syntax-protect (syntax/loc x template)))
|
||||
...))))))))
|
||||
|
||||
(-define-syntax syntax-id-rules
|
||||
(lambda (x)
|
||||
(syntax-case** syntax-id-rules #t x () free-identifier=?
|
||||
(syntax-case** syntax-id-rules #t x () free-identifier=? #f
|
||||
((sidr (k ...) (pattern template) ...)
|
||||
(andmap identifier? (syntax->list (syntax (k ...))))
|
||||
(syntax/loc x
|
||||
(make-set!-transformer
|
||||
(lambda (x)
|
||||
(syntax-case** sidr #t x (k ...) free-identifier=?
|
||||
(syntax-case** sidr #t x (k ...) free-identifier=? #f
|
||||
(pattern (syntax-protect (syntax/loc x template)))
|
||||
...))))))))
|
||||
|
||||
|
|
@ -68,7 +68,7 @@
|
|||
(syntax-arm stx #f #t)
|
||||
(raise-type-error 'syntax-protect "syntax-object" stx)))
|
||||
|
||||
(#%provide syntax (all-from "with-stx.rkt") (all-from "stxloc.rkt")
|
||||
(#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt")
|
||||
check-duplicate-identifier syntax-protect
|
||||
syntax-rules syntax-id-rules
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
|
|
|
|||
|
|
@ -134,22 +134,34 @@
|
|||
|
||||
(-define interp-match
|
||||
(lambda (pat e literals immediate=?)
|
||||
(interp-gen-match pat e literals immediate=? #f)))
|
||||
|
||||
(-define interp-s-match
|
||||
(lambda (pat e literals immediate=?)
|
||||
(interp-gen-match pat e literals immediate=? #t)))
|
||||
|
||||
(-define interp-gen-match
|
||||
(lambda (pat e literals immediate=? s-exp?)
|
||||
(let loop ([pat pat][e e][cap e])
|
||||
(cond
|
||||
[(null? pat)
|
||||
(stx-null? e)]
|
||||
(if s-exp?
|
||||
(null? e)
|
||||
(stx-null? e))]
|
||||
[(number? pat)
|
||||
(and (identifier? e)
|
||||
(immediate=? e (vector-ref (syntax-e literals) pat)))]
|
||||
(and (if s-exp? (symbol? e) (identifier? e))
|
||||
(immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))]
|
||||
[(not pat)
|
||||
#t]
|
||||
[else
|
||||
(let ([i (vector-ref pat 0)])
|
||||
(cond
|
||||
[(eq? i 'bind)
|
||||
(let ([e (if (vector-ref pat 2)
|
||||
(datum->syntax cap e cap)
|
||||
e)])
|
||||
(let ([e (if s-exp?
|
||||
e
|
||||
(if (vector-ref pat 2)
|
||||
(datum->syntax cap e cap)
|
||||
e))])
|
||||
(if (vector-ref pat 1)
|
||||
e
|
||||
(list e)))]
|
||||
|
|
@ -170,23 +182,29 @@
|
|||
h)
|
||||
t))))))))]
|
||||
[(eq? i 'quote)
|
||||
(and (syntax? e)
|
||||
(equal? (vector-ref pat 1) (syntax-e e))
|
||||
null)]
|
||||
(if s-exp?
|
||||
(and (equal? (vector-ref pat 1) e)
|
||||
null)
|
||||
(and (syntax? e)
|
||||
(equal? (vector-ref pat 1) (syntax-e e))
|
||||
null))]
|
||||
[(eq? i 'ellipses)
|
||||
(let ([match-head (vector-ref pat 1)]
|
||||
[nest-cnt (vector-ref pat 2)]
|
||||
[last? (vector-ref pat 3)])
|
||||
(and (stx-list? e)
|
||||
(and (if s-exp?
|
||||
(list? e)
|
||||
(stx-list? e))
|
||||
(if (zero? nest-cnt)
|
||||
(andmap (lambda (e) (loop match-head e cap)) (stx->list e))
|
||||
(andmap (lambda (e) (loop match-head e cap))
|
||||
(if s-exp? e (stx->list e)))
|
||||
(let/ec esc
|
||||
(let ([l (map (lambda (e)
|
||||
(let ([m (loop match-head e cap)])
|
||||
(if m
|
||||
m
|
||||
(esc #f))))
|
||||
(stx->list e))])
|
||||
(if s-exp? e (stx->list e)))])
|
||||
(if (null? l)
|
||||
(let loop ([cnt nest-cnt])
|
||||
(cond
|
||||
|
|
@ -214,10 +232,14 @@
|
|||
t)
|
||||
h))))))))]
|
||||
[(eq? i 'veclist)
|
||||
(and (stx-vector? e #f)
|
||||
(loop (vector-ref pat 1) (vector->list (syntax-e e)) cap))]
|
||||
(and (if s-exp?
|
||||
(vector? e)
|
||||
(stx-vector? e #f))
|
||||
(loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))]
|
||||
[(eq? i 'vector)
|
||||
(and (stx-vector? e (vector-ref pat 1))
|
||||
(and (if s-exp?
|
||||
(and (vector? e) (= (vector-length e) (vector-ref pat 1)))
|
||||
(stx-vector? e (vector-ref pat 1)))
|
||||
(let vloop ([p (vector-ref pat 2)][pos 0])
|
||||
(cond
|
||||
[(null? p) null]
|
||||
|
|
@ -225,7 +247,7 @@
|
|||
(let ([clause (car p)])
|
||||
(let ([match-elem (car clause)]
|
||||
[elem-did-var? (cdr clause)])
|
||||
(let ([m (loop match-elem (stx-vector-ref e pos) cap)])
|
||||
(let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)])
|
||||
(and m
|
||||
(let ([body (vloop (cdr p) (add1 pos))])
|
||||
(and body
|
||||
|
|
@ -235,8 +257,10 @@
|
|||
(append m body))
|
||||
body)))))))])))]
|
||||
[(eq? i 'prefab)
|
||||
(and (stx-prefab? (vector-ref pat 1) e)
|
||||
(loop (vector-ref pat 2) (cdr (vector->list (struct->vector (syntax-e e)))) cap))]
|
||||
(and (if s-exp?
|
||||
(equal? (vector-ref pat 1) (prefab-struct-key e))
|
||||
(stx-prefab? (vector-ref pat 1) e))
|
||||
(loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))]
|
||||
[else (error "yikes!" pat)]))]))))
|
||||
|
||||
(-define-syntax syntax-case**
|
||||
|
|
@ -253,7 +277,8 @@
|
|||
[expr (caddr l)]
|
||||
[kws (cadddr l)]
|
||||
[lit-comp (cadddr (cdr l))]
|
||||
[clauses (cddddr (cdr l))])
|
||||
[s-exp? (syntax-e (cadddr (cddr l)))]
|
||||
[clauses (cddddr (cddr l))])
|
||||
(unless (stx-list? kws)
|
||||
(raise-syntax-error
|
||||
(syntax-e who)
|
||||
|
|
@ -300,7 +325,7 @@
|
|||
(syntax-arm
|
||||
(datum->syntax
|
||||
(quote-syntax here)
|
||||
(list (quote-syntax let) (list (list arg (if (syntax-e arg-is-stx?)
|
||||
(list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?))
|
||||
expr
|
||||
(list (quote-syntax datum->syntax)
|
||||
(list
|
||||
|
|
@ -348,7 +373,8 @@
|
|||
pattern
|
||||
pattern
|
||||
(stx->list kws)
|
||||
(not lit-comp-is-mod?))]
|
||||
(not lit-comp-is-mod?)
|
||||
s-exp?)]
|
||||
[cant-fail? (if lit-comp-is-mod?
|
||||
(equal? mtch '(lambda (e) e))
|
||||
(equal? mtch '(lambda (e free-identifier=?) e)))]
|
||||
|
|
@ -366,15 +392,16 @@
|
|||
[else (sub1 fuel)]))))]
|
||||
[mtch (if interp?
|
||||
(let ([interp-box (box null)])
|
||||
(let ([pat (make-interp-match pattern (syntax->list kws) interp-box)])
|
||||
(let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)])
|
||||
(list 'lambda
|
||||
'(e)
|
||||
(list 'interp-match
|
||||
(list (if s-exp? 'interp-s-match 'interp-match)
|
||||
(list 'quote pat)
|
||||
'e
|
||||
(if (null? (unbox interp-box))
|
||||
#f
|
||||
(list 'quote-syntax (list->vector (reverse (unbox interp-box)))))
|
||||
(list (if s-exp? 'quote 'quote-syntax)
|
||||
(list->vector (reverse (unbox interp-box)))))
|
||||
lit-comp))))
|
||||
mtch)]
|
||||
[m
|
||||
|
|
@ -436,7 +463,9 @@
|
|||
(map (lambda (pattern-var unflat-pattern-var temp-var)
|
||||
(list (list pattern-var)
|
||||
(list
|
||||
(quote-syntax make-syntax-mapping)
|
||||
(if s-exp?
|
||||
(quote-syntax make-s-exp-mapping)
|
||||
(quote-syntax make-syntax-mapping))
|
||||
;; Tell it the shape of the variable:
|
||||
(let loop ([var unflat-pattern-var][d 0])
|
||||
(if (syntax? var)
|
||||
|
|
@ -469,8 +498,9 @@
|
|||
m))))])))
|
||||
x)))))))
|
||||
|
||||
(-define-syntax syntax
|
||||
(lambda (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)])
|
||||
|
|
@ -484,19 +514,24 @@
|
|||
(datum->syntax
|
||||
here-stx
|
||||
(let ([pattern (stx-car (stx-cdr x))])
|
||||
(let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f)])
|
||||
(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 (syntax-pattern-variable? v)
|
||||
(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 (quote-syntax quote-syntax) pattern)
|
||||
(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)
|
||||
|
|
@ -505,7 +540,9 @@
|
|||
(cdr bindings))])
|
||||
(if (car bindings)
|
||||
(cons (let loop ([v (car vars)]
|
||||
[d (syntax-mapping-depth (car bindings))])
|
||||
[d (if s-exp?
|
||||
(s-exp-mapping-depth (car bindings))
|
||||
(syntax-mapping-depth (car bindings)))])
|
||||
(if (zero? d)
|
||||
v
|
||||
(loop (list v) (sub1 d))))
|
||||
|
|
@ -522,14 +559,16 @@
|
|||
(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)]
|
||||
(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 (syntax-mapping-valvar (car bindings))])
|
||||
(let ([id (if s-exp?
|
||||
(s-exp-mapping-valvar (car bindings))
|
||||
(syntax-mapping-valvar (car bindings)))])
|
||||
(datum->syntax
|
||||
id
|
||||
(syntax-e id)
|
||||
|
|
@ -552,7 +591,10 @@
|
|||
[(= len 1) (car r)]
|
||||
[else
|
||||
(cons (quote-syntax list*) r)]))))))))))
|
||||
x))))
|
||||
x)))))
|
||||
|
||||
(#%provide (all-from "ellipses.rkt") syntax-case** syntax
|
||||
(-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
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
|
|
|
|||
|
|
@ -6,19 +6,26 @@
|
|||
(#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt"
|
||||
(for-syntax '#%kernel "stxcase.rkt" "sc.rkt"))
|
||||
|
||||
;; Regular syntax-case
|
||||
;; Like regular syntax-case, but with free-identifier=? replacement
|
||||
(-define-syntax syntax-case*
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=?
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
[(sc stxe kl id=? clause ...)
|
||||
(syntax (syntax-case** sc #f stxe kl id=? clause ...))])))
|
||||
(syntax (syntax-case** sc #f stxe kl id=? #f clause ...))])))
|
||||
|
||||
;; Regular syntax-case
|
||||
(-define-syntax syntax-case
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=?
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
[(sc stxe kl clause ...)
|
||||
(syntax (syntax-case** sc #f stxe kl free-identifier=? clause ...))])))
|
||||
(syntax (syntax-case** sc #f stxe kl free-identifier=? #f clause ...))])))
|
||||
|
||||
;; Like `syntax-case, but on plain datums
|
||||
(-define-syntax datum-case
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
[(sc stxe kl clause ...)
|
||||
(syntax (syntax-case** sc #f stxe kl eq? #t clause ...))])))
|
||||
|
||||
(-define (relocate loc stx)
|
||||
(if (or (syntax-source loc)
|
||||
|
|
@ -34,7 +41,7 @@
|
|||
;; resulting syntax object.
|
||||
(-define-syntax syntax/loc
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=?
|
||||
(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)))
|
||||
|
|
@ -44,7 +51,7 @@
|
|||
|
||||
(-define-syntax quote-syntax/prune
|
||||
(lambda (stx)
|
||||
(syntax-case** #f #t stx () free-identifier=?
|
||||
(syntax-case** #f #t stx () free-identifier=? #f
|
||||
[(_ id)
|
||||
(if (symbol? (syntax-e #'id))
|
||||
(datum->syntax #'here
|
||||
|
|
@ -62,4 +69,4 @@
|
|||
stx
|
||||
#'id))])))
|
||||
|
||||
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case ... _))
|
||||
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _))
|
||||
|
|
|
|||
|
|
@ -12,48 +12,60 @@
|
|||
"binding match failed"
|
||||
stx))
|
||||
|
||||
(-define (with-datum-fail stx)
|
||||
(raise-syntax-error
|
||||
'with-datum
|
||||
"binding match failed"
|
||||
stx))
|
||||
|
||||
;; Partly from Dybvig
|
||||
(-define-syntax with-syntax
|
||||
(let ([here-stx (quote-syntax here)])
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ () e1 e2 ...)
|
||||
(syntax/loc x (begin e1 e2 ...)))
|
||||
((_ ((out in) ...) e1 e2 ...)
|
||||
(let ([ins (syntax->list (syntax (in ...)))])
|
||||
;; Check for duplicates or other syntax errors:
|
||||
(get-match-vars (syntax _) x (syntax (out ...)) null)
|
||||
;; Generate temps and contexts:
|
||||
(let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
|
||||
[heres (map (lambda (x)
|
||||
(datum->syntax
|
||||
x
|
||||
'here
|
||||
x))
|
||||
ins)]
|
||||
[outs (syntax->list (syntax (out ...)))])
|
||||
;; Let-bind RHSs, then build up nested syntax-cases:
|
||||
(datum->syntax
|
||||
here-stx
|
||||
`(let ,(map (lambda (tmp here in)
|
||||
`[,tmp (datum->syntax
|
||||
(quote-syntax ,here)
|
||||
,in)])
|
||||
tmps heres ins)
|
||||
,(let loop ([tmps tmps][outs outs])
|
||||
(cond
|
||||
[(null? tmps)
|
||||
(syntax (begin e1 e2 ...))]
|
||||
[else `(syntax-case** #f #t ,(car tmps) () free-identifier=?
|
||||
[,(car outs) ,(loop (cdr tmps)
|
||||
(cdr outs))]
|
||||
[_ (with-syntax-fail
|
||||
;; Minimize the syntax structure we keep:
|
||||
(quote-syntax ,(datum->syntax
|
||||
#f
|
||||
(syntax->datum (car outs))
|
||||
(car outs))))])])))
|
||||
x))))))))
|
||||
(begin-for-syntax
|
||||
(define-values (gen-with-syntax)
|
||||
(let ([here-stx (quote-syntax here)])
|
||||
(lambda (x s-exp?)
|
||||
(syntax-case x ()
|
||||
((_ () e1 e2 ...)
|
||||
(syntax/loc x (begin e1 e2 ...)))
|
||||
((_ ((out in) ...) e1 e2 ...)
|
||||
(let ([ins (syntax->list (syntax (in ...)))])
|
||||
;; Check for duplicates or other syntax errors:
|
||||
(get-match-vars (syntax _) x (syntax (out ...)) null)
|
||||
;; Generate temps and contexts:
|
||||
(let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
|
||||
[heres (map (lambda (x)
|
||||
(datum->syntax
|
||||
x
|
||||
'here
|
||||
x))
|
||||
ins)]
|
||||
[outs (syntax->list (syntax (out ...)))])
|
||||
;; Let-bind RHSs, then build up nested syntax-cases:
|
||||
(datum->syntax
|
||||
here-stx
|
||||
`(let ,(map (lambda (tmp here in)
|
||||
`[,tmp ,(if s-exp?
|
||||
in
|
||||
`(datum->syntax
|
||||
(quote-syntax ,here)
|
||||
,in))])
|
||||
tmps heres ins)
|
||||
,(let loop ([tmps tmps][outs outs])
|
||||
(cond
|
||||
[(null? tmps)
|
||||
(syntax (begin e1 e2 ...))]
|
||||
[else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp?
|
||||
[,(car outs) ,(loop (cdr tmps)
|
||||
(cdr outs))]
|
||||
[_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail)
|
||||
;; Minimize the syntax structure we keep:
|
||||
(quote-syntax ,(datum->syntax
|
||||
#f
|
||||
(syntax->datum (car outs))
|
||||
(car outs))))])])))
|
||||
x)))))))))
|
||||
|
||||
(-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f)))
|
||||
(-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t)))
|
||||
|
||||
(-define counter 0)
|
||||
(-define (append-number s)
|
||||
|
|
@ -84,4 +96,4 @@
|
|||
(datum->syntax #f (append-number 'temp))])))
|
||||
l)))
|
||||
|
||||
(#%provide with-syntax generate-temporaries))
|
||||
(#%provide with-syntax with-datum generate-temporaries))
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
syntax/boundmap
|
||||
syntax/parse
|
||||
racket/syntax)
|
||||
syntax/datum
|
||||
"error.rkt"
|
||||
"matcher.rkt")
|
||||
|
||||
|
|
@ -36,7 +37,7 @@
|
|||
(let-values ([(rewritten max-depth) (rewrite/max-depth args depth)])
|
||||
(let ([result-id (car (generate-temporaries '(f-results)))])
|
||||
(with-syntax ([fn fn])
|
||||
(let loop ([func (syntax (λ (x) (fn (syntax->datum x))))]
|
||||
(let loop ([func (syntax (λ (x) (fn x)))]
|
||||
[args-stx rewritten]
|
||||
[res result-id]
|
||||
[args-depth (min depth max-depth)])
|
||||
|
|
@ -46,10 +47,10 @@
|
|||
(if (zero? args-depth)
|
||||
(begin
|
||||
(set! outer-bindings
|
||||
(cons (syntax [res (func (quasisyntax args))])
|
||||
(cons (syntax [res (func (quasidatum args))])
|
||||
outer-bindings))
|
||||
(values result-id (min depth max-depth)))
|
||||
(loop (syntax (λ (l) (map func (syntax->list l))))
|
||||
(loop (syntax (λ (l) (map func l)))
|
||||
(syntax/loc args-stx (args (... ...)))
|
||||
(syntax (res (... ...)))
|
||||
(sub1 args-depth)))))))))
|
||||
|
|
@ -82,18 +83,18 @@
|
|||
#,ref)])
|
||||
(values #'#,v 0)))]
|
||||
[(unquote x)
|
||||
(values (syntax (unsyntax x)) 0)]
|
||||
(values (syntax (undatum x)) 0)]
|
||||
[(unquote . x)
|
||||
(raise-syntax-error 'term "malformed unquote" orig-stx stx)]
|
||||
[(unquote-splicing x)
|
||||
(values (syntax (unsyntax-splicing x)) 0)]
|
||||
(values (syntax (undatum-splicing x)) 0)]
|
||||
[(unquote-splicing . x)
|
||||
(raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
|
||||
[(in-hole id body)
|
||||
(rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)]
|
||||
[(in-hole . x)
|
||||
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
|
||||
[hole (values (syntax (unsyntax the-hole)) 0)]
|
||||
[hole (values (syntax (undatum the-hole)) 0)]
|
||||
|
||||
|
||||
[() (values stx 0)]
|
||||
|
|
@ -130,10 +131,10 @@
|
|||
(λ (f _) (defined-check f "metafunction")))
|
||||
#,(let loop ([bs (reverse outer-bindings)])
|
||||
(cond
|
||||
[(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))]
|
||||
[(null? bs) (syntax (quasidatum rewritten))]
|
||||
[else (with-syntax ([rec (loop (cdr bs))]
|
||||
[fst (car bs)])
|
||||
(syntax (with-syntax (fst)
|
||||
(syntax (with-datum (fst)
|
||||
rec)))])))))]))
|
||||
|
||||
(define-syntax (term-let-fn stx)
|
||||
|
|
@ -200,9 +201,9 @@
|
|||
[no-match (syntax/loc (syntax rhs1)
|
||||
(error 'error-name "term ~s does not match pattern ~s" rhs1 'x1))])
|
||||
(syntax
|
||||
(syntax-case rhs1 ()
|
||||
(datum-case rhs1 ()
|
||||
[new-x1
|
||||
(let-syntax ([orig-names (make-term-id #'new-names (syntax-e #'depths))] ...)
|
||||
(let-syntax ([orig-names (make-term-id #'new-names depths)] ...)
|
||||
(term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
|
||||
[_ no-match]))))]
|
||||
[(_ error-name () body1 body2 ...)
|
||||
|
|
@ -227,4 +228,4 @@
|
|||
(not-expression-context stx)
|
||||
#'(begin
|
||||
(define term-val (term t))
|
||||
(define-syntax x (defined-term #'term-val)))]))
|
||||
(define-syntax x (defined-term #'term-val)))]))
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@
|
|||
#%top-interaction
|
||||
map for-each andmap ormap
|
||||
assq assv assoc reverse memq memv member
|
||||
(rename datum #%datum)
|
||||
(rename old-datum #%datum)
|
||||
(rename mzscheme-in-stx-module-begin #%module-begin)
|
||||
(rename #%module-begin #%plain-module-begin)
|
||||
(rename lambda #%plain-lambda)
|
||||
|
|
|
|||
5
collects/syntax/datum.rkt
Normal file
5
collects/syntax/datum.rkt
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
(module datum '#%kernel
|
||||
(#%require racket/private/stxcase-scheme
|
||||
racket/private/qqstx)
|
||||
(#%provide datum datum-case with-datum
|
||||
quasidatum undatum undatum-splicing))
|
||||
84
collects/syntax/scribblings/datum.scrbl
Normal file
84
collects/syntax/scribblings/datum.scrbl
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
#lang scribble/manual
|
||||
@(require "common.rkt"
|
||||
scribble/eval
|
||||
(for-label racket/base
|
||||
syntax/datum))
|
||||
|
||||
@(define datum-eval (make-base-eval))
|
||||
@interaction-eval[#:eval datum-eval (require syntax/datum)]
|
||||
|
||||
@title{Datum Pattern Matching}
|
||||
|
||||
@defmodule[syntax/datum]{The @racketmodname[syntax/datum] library
|
||||
provides forms that implement the pattern and template language of
|
||||
@racket[syntax-case], but for matching and constructing datum values
|
||||
instead of syntax.}
|
||||
|
||||
For most pattern-matching purposes, @racketmodname[racket/match] is a
|
||||
better choice than @racketmodname[syntax/datum]. The
|
||||
@racketmodname[syntax/datum] library is useful mainly for its template
|
||||
support (i.e., @racket[datum]) and, to a lesser extent, its direct
|
||||
correspondence to @racket[syntax-case] patterns.
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defform[(datum-case datum-expr (literal-id ...)
|
||||
clause ...)]
|
||||
@defform[(datum template)]
|
||||
)]{
|
||||
|
||||
Like @racket[syntax-case] and @racket[syntax], but @racket[datum-expr]
|
||||
in @racket[datum-case] should produce a @tech[#:doc refman]{datum}
|
||||
(i.e., plain S-expression) instead of a @tech[#:doc refman]{syntax
|
||||
object} to be matched in @racket[clause]s, and @racket[datum]
|
||||
similarly produces a datum. Pattern variables bound in each
|
||||
@racket[clause] of @racket[datum-case] are accessible via
|
||||
@racket[datum] instead of @racket[syntax]. When a @racket[literal-id]
|
||||
appears in a @racket[clause]'s pattern, it matches the corresponding
|
||||
symbol (using @racket[eq?]).
|
||||
|
||||
|
||||
Using @racket[datum-case] and @racket[datum] is essentially equivalent
|
||||
to converting the input to @racket[syntax-case] using
|
||||
@racket[datum->syntax] and then wrapping each use of @racket[syntax]
|
||||
with @racket[syntax->datum], but @racket[datum-case] and
|
||||
@racket[datum] to not create intermediate syntax objects.
|
||||
|
||||
@examples[
|
||||
#:eval datum-eval
|
||||
(datum-case '(1 "x" -> y) (->)
|
||||
[(a ... -> b) (datum (b (+ a) ...))])
|
||||
]}
|
||||
|
||||
|
||||
@defform[(with-datum ([pattern datum-expr] ...)
|
||||
body ...+)]{
|
||||
|
||||
Analogous to @racket[with-syntax], but for @racket[datum-case] and
|
||||
@racket[datum] instead of @racket[syntax-case] and @racket[syntax].
|
||||
|
||||
@examples[
|
||||
#:eval datum-eval
|
||||
(with-datum ([(a ...) '(1 2 3)]
|
||||
[(b ...) '("x" "y" "z")])
|
||||
(datum ((a b) ...)))
|
||||
]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defform[(quasidatum template)]
|
||||
@defform[(undatum expr)]
|
||||
@defform[(undatum-splicing expr)]
|
||||
)]{
|
||||
|
||||
Analogous to @racket[quasisyntax], @racket[unsyntax], and
|
||||
@racket[unsyntax-splicing].
|
||||
|
||||
@examples[
|
||||
#:eval datum-eval
|
||||
(with-datum ([(a ...) '(1 2 3)])
|
||||
(quasidatum ((undatum (- 1 1)) a ... (undatum (+ 2 2)))))
|
||||
]}
|
||||
|
||||
|
||||
@close-eval[datum-eval]
|
||||
|
|
@ -5,14 +5,19 @@
|
|||
|
||||
@table-of-contents[]
|
||||
|
||||
@include-section["parse.scrbl"]
|
||||
|
||||
@include-section["syntax-object-helpers.scrbl"]
|
||||
|
||||
@include-section["datum.scrbl"]
|
||||
|
||||
@include-section["module-helpers.scrbl"]
|
||||
|
||||
@include-section["transformer-helpers.scrbl"]
|
||||
|
||||
@include-section["reader-helpers.scrbl"]
|
||||
|
||||
@include-section["srcloc.scrbl"]
|
||||
|
||||
@include-section["toplevel.scrbl"]
|
||||
|
||||
|
|
@ -20,8 +25,4 @@
|
|||
|
||||
@include-section["docprovide.scrbl"]
|
||||
|
||||
@include-section["parse.scrbl"]
|
||||
|
||||
@include-section["srcloc.scrbl"]
|
||||
|
||||
@index-section[]
|
||||
|
|
|
|||
57
collects/tests/syntax/datum.rkt
Normal file
57
collects/tests/syntax/datum.rkt
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
#lang racket
|
||||
(require syntax/datum)
|
||||
|
||||
(define (do-test expect got expr)
|
||||
(unless (equal? expect got) (error "failed\n" expr)))
|
||||
|
||||
|
||||
(define-syntax test
|
||||
(syntax-rules (datum-case datum)
|
||||
[(_ expect (datum-case expr () [pat (datum tmpl)]))
|
||||
(begin
|
||||
(test expect (values (datum-case expr () [pat (datum tmpl)])))
|
||||
(test expect (with-datum ([pat expr]) (datum tmpl))))]
|
||||
[(_ expect expr)
|
||||
(do-test expect expr 'expr)]))
|
||||
|
||||
(test '(3 2 1)
|
||||
(datum-case '(1 2 3) ()
|
||||
[(a b c) (datum (c b a))]))
|
||||
|
||||
(test '(3 1 2)
|
||||
(datum-case '(1 2 3) ()
|
||||
[(a ... c) (datum (c a ...))]))
|
||||
|
||||
(test '(3 1 2)
|
||||
(datum-case '#(1 2 3) ()
|
||||
[#(a ... c) (datum (c a ...))]))
|
||||
|
||||
(test '(3 2 1)
|
||||
(datum-case '#(1 2 3) ()
|
||||
[#(a b c) (datum (c b a))]))
|
||||
|
||||
(test '(3 2 1)
|
||||
(datum-case '#s(q 1 2 3) ()
|
||||
[#s(q a b c) (datum (c b a))]))
|
||||
|
||||
(test '(3 2 1)
|
||||
(datum-case '(1 ! 2 % 3) (! %)
|
||||
[(a ! b % c) (datum (c b a))]))
|
||||
|
||||
(test '(3 2 1)
|
||||
(datum-case '#(1 ! 2 % 3) (! %)
|
||||
[#(a ! b % c) (datum (c b a))]))
|
||||
|
||||
(test 'x
|
||||
(datum x))
|
||||
|
||||
(test 'x
|
||||
(quasidatum x))
|
||||
(test '(1 2 3)
|
||||
(quasidatum (1 (undatum (+ 1 1)) 3)))
|
||||
(test '#(1 2 3)
|
||||
(quasidatum #(1 (undatum (+ 1 1)) 3)))
|
||||
(test '(1 2 3)
|
||||
(quasidatum (1 (undatum-splicing (list (+ 1 1) 3)))))
|
||||
(test '(1 2 3 4)
|
||||
(quasidatum (1 (undatum-splicing (list (+ 1 1) 3)) 4)))
|
||||
Loading…
Reference in New Issue
Block a user