suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed define-match-expander to certify properly

Browse Source 
svn: r2868
This commit is contained in:
Matthew Flatt 2006-05-06 15:42:44 +00:00
parent 00d2970dcc
commit 12f990e663
7 changed files with 199 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
collects/mzlib/private/convert-pat.ss
View File

@ -69,66 +69,79 @@
(pat stx)))
(define (convert-pat stx)
(syntax-case*
stx
(_ ? = and or not $ set! get! quasiquote
quote unquote unquote-splicing) stx-equal?
[(expander . args)
(and (identifier? #'expander)
(match-expander? (syntax-local-value #'expander (lambda () #f))))
(let ([xformer (match-expander-match-xform
(syntax-local-value #'expander (lambda () #f)))])
(if (not xformer)
(match:syntax-err #'expander
"This expander only works with plt-match.")
(convert-pat (xformer #'(expander . args)))))]
[p
(dot-dot-k? (syntax-object->datum #'p))
stx]
[_ stx]
[() #'(list)]
['() #'(list)]
['item stx]
[p
(let ((old-pat (syntax-object->datum #'p)))
(or (string? old-pat)
(boolean? old-pat)
(char? old-pat)
(number? old-pat)))
stx]
[(? pred) stx]
[(? pred . a)
(with-syntax ([pats (syntax-map convert-pat #'a)])
#'(? pred . pats))]
[`pat #``#,(convert-quasi #'pat)]
[(= op pat) #`(app op #,(convert-pat #'pat))]
[(and . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(and . new-pats))]
[(or . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(or . new-pats))]
[(not pat) #`(not #,(convert-pat #'pat))]
[($ struct-name . fields)
(with-syntax ([new-fields (syntax-map convert-pat #'fields)])
#'(struct struct-name new-fields))]
[(get! id) stx]
[(set! id) stx]
[(quote p) stx]
[(car-pat . cdr-pat)
(let ([l (imp-list? (syntax-e stx) stx)])
(if l #`(list-rest #,@(map convert-pat l))
#`(list #,@(map convert-pat (syntax-e stx)))))]
[pt
(vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
#'(vector . new-pats))]
[pt
(box? (syntax-e stx))
#`(box #,(convert-pat (unbox (syntax-e stx))))]
[pt
(identifier? stx)
stx]
[got-too-far
(match:syntax-err stx "syntax error in pattern")]))
(convert-pat/cert stx (lambda (x) x)))
(define (convert-pat/cert stx cert)
(let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
(syntax-case*
stx
(_ ? = and or not $ set! get! quasiquote
quote unquote unquote-splicing) stx-equal?
[(expander . args)
(and (identifier? #'expander)
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander) (lambda () #f))]
[xformer (match-expander-match-xform expander)])
(if (not xformer)
(match:syntax-err #'expander
"This expander only works with plt-match.")
(let ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)])
(convert-pat/cert
(introducer (xformer (introducer stx)))
(lambda (id)
(certifier (cert id) #f introducer))))))]
[p
(dot-dot-k? (syntax-object->datum #'p))
stx]
[_ stx]
[() #'(list)]
['() #'(list)]
['item stx]
[p
(let ((old-pat (syntax-e #'p)))
(or (string? old-pat)
(boolean? old-pat)
(char? old-pat)
(number? old-pat)))
stx]
[(? pred) #`(? #,(cert #'pred))]
[(? pred . a)
(with-syntax ([pred (cert #'pred)]
[pats (syntax-map convert-pat #'a)])
#'(? pred . pats))]
[`pat #``#,(convert-quasi #'pat)]
[(= op pat) #`(app #,(cert #'op) #,(convert-pat #'pat))]
[(and . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(and . new-pats))]
[(or . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(or . new-pats))]
[(not pat) #`(not #,(convert-pat #'pat))]
[($ struct-name . fields)
(with-syntax ([struct-name (cert #'struct-name)]
[new-fields (syntax-map convert-pat #'fields)])
#'(struct struct-name new-fields))]
[(get! id) (with-syntax ([id (cert #'id)])
#'(get! id))]
[(set! id) (with-syntax ([id (cert #'id)])
#'(set! id))]
[(quote p) stx]
[(car-pat . cdr-pat)
(let ([l (imp-list? (syntax-e stx) stx)])
(if l #`(list-rest #,@(map convert-pat l))
#`(list #,@(map convert-pat (syntax-e stx)))))]
[pt
(vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
#'(vector . new-pats))]
[pt
(box? (syntax-e stx))
#`(box #,(convert-pat (unbox (syntax-e stx))))]
[pt
(identifier? stx)
(cert stx)]
[got-too-far
(match:syntax-err stx "syntax error in pattern")])))
)

50
collects/mzlib/private/ddk-handlers.ss
View File

@ -41,10 +41,10 @@
;; pat - the pattern to be matched repeatedly
;; dot-dot-k - the ddk pattern
;; let-bound - a list of let bindings
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k let-bound) sf bv)
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k let-bound cert) sf bv)
(define k (stx-dot-dot-k? dot-dot-k))
(define (ksucc sf bv)
(let ([bound (getbindings pat)])
(let ([bound (getbindings pat cert)])
(if (syntax? bound)
(kf sf bv)
(syntax-case pat (_)
@ -59,7 +59,8 @@
bv
let-bound
(lambda (sf bv) #'#f)
(lambda (sf bv) #'#t))]
(lambda (sf bv) #'#t)
cert)]
[tst (syntax-case ptst ()
[(pred eta)
(and (identifier? #'pred)
@ -72,7 +73,7 @@
(ks sf bv))))]
[id
(and (identifier? #'id) (stx-equal? #'id (car bound)))
(next-outer #'id ae sf bv let-bound kf ks)]
(next-outer #'id ae sf bv let-bound kf ks cert)]
[the-pat
(let ([binding-list-names (generate-temporaries bound)]
(loop-name (gensym 'loop))
@ -109,7 +110,8 @@
b-var
bv)
#,bindings-var))
bound binding-list-names)))))))]))))
bound binding-list-names)))
cert))))]))))
(define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
(case k
((0) (ksucc sf bv))
@ -144,9 +146,9 @@
;; dot-dot-k - the ddk pattern
;; pat-rest - the rest of the list pattern that occurs after the ddk
;; let-bound - a list of let bindings
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest let-bound) sf bv)
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest let-bound cert) sf bv)
(let* ((k (stx-dot-dot-k? dot-dot-k)))
(let ((bound (getbindings pat)))
(let ((bound (getbindings pat cert)))
(if (syntax? bound)
(kf sf bv)
(syntax-case pat (_)
@ -163,7 +165,8 @@
bv
let-bound
(lambda (sf bv) #'#f)
(lambda (sf bv) #'#t)))
(lambda (sf bv) #'#t)
cert))
(tst (syntax-case ptst ()
((pred eta)
(and (identifier?
@ -196,7 +199,8 @@
bv
let-bound
kf
ks)))
ks
cert)))
(if (zero? k)
succ
#`(if (>= #,count-name #,k)
@ -227,7 +231,8 @@
new-bv
let-bound
kf
ks)))
ks
cert)))
(if (zero? k)
succ
#`(if (>= #,count-name #,k)
@ -259,7 +264,8 @@
bv)
#,bindings-var))
bound
binding-list-names))))))))))))))
binding-list-names)))
cert)))))))))))
;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks let-bound)
;; ->
@ -279,7 +285,7 @@
;; ks - a success function
;; pt - the whole vector pattern
;; let-bound - a list of let bindings
(define (handle-ddk-vector ae kf ks pt let-bound)
(define (handle-ddk-vector ae kf ks pt let-bound cert)
(let* ((vec-stx (syntax-e pt))
(vlen (- (vector-length vec-stx) 2)) ;; length minus
;; the pat ...
@ -287,7 +293,7 @@
(minlen (+ vlen k))
;; get the bindings for the second to last element:
;; 'pat' in pat ...
(bound (getbindings (vector-ref vec-stx vlen)))
(bound (getbindings (vector-ref vec-stx vlen) cert))
(exp-name (gensym 'exnm)))
(lambda (sf bv)
(if (syntax? bound)
@ -308,7 +314,8 @@
bv
let-bound
kf
(vloop (+ 1 n))))
(vloop (+ 1 n))
cert))
((eq? (syntax-object->datum
(vector-ref vec-stx vlen))
'_)
@ -353,7 +360,8 @@
bv)
#,bindings-var))
bound
binding-list-names)))))))))))
binding-list-names)))
cert))))))))
sf
bv))))))))
@ -377,7 +385,7 @@
;; ks - a success function
;; pt - the whole vector pattern
;; let-bound - a list of let bindings
(define (handle-ddk-vector-inner ae kf ks pt let-bound)
(define (handle-ddk-vector-inner ae kf ks pt let-bound cert)
(let* ((vec-stx (syntax-e pt))
;; vlen as an index points at the pattern before the ddk
(vlen (- (vector-length vec-stx) 2)) ;; length minus
@ -390,7 +398,7 @@
(exp-name (gensym 'exnm)))
;; get the bindings for the second to last element:
;; 'pat' in pat ...
;;(bound (getbindings (vector-ref vec-stx vlen))))
;;(bound (getbindings (vector-ref vec-stx vlen) cert)))
;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern
(lambda (sf bv)
@ -441,7 +449,8 @@
;(set! current-index-name #`(add1 #,current-index-name))
(let ((cindnm (gensym 'cindnm)))
#`(let ((#,cindnm (add1 #,count-offset-name-passover)))
#,((vloop (+ 1 n) cindnm) sf bv))))))))
#,((vloop (+ 1 n) cindnm) sf bv))))
cert))))
((and (eq? (syntax-object->datum
(vector-ref vec-stx n)) ;this could be it
'_)
@ -449,7 +458,7 @@
(stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
(ks sf bv))
(else ;; we now know that the next pattern is a ddk
(let ((bound (getbindings (vector-ref vec-stx n))))
(let ((bound (getbindings (vector-ref vec-stx n) cert)))
(if (syntax? bound)
(kf sf bv)
(let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
@ -523,7 +532,8 @@
(apply
#,vloop-name
(add1 #,count-name)
arglist)))))))))))))))
arglist)))
cert))))))))))))
sf
bv)))))))))

2
collects/mzlib/private/gen-match.ss
View File

@ -110,7 +110,7 @@
let-bound)))
bv)))
(success-func sf bv)))))
(define test-list (render-test-list pat exp stx))
(define test-list (render-test-list pat exp (lambda (x) x) stx))
(cons test-list success))
;;!(function gen-match

20
collects/mzlib/private/getbindings.ss
View File

@ -35,10 +35,11 @@
let-bound
kf
ks
cert
[stx (syntax '())]
[opt #f])
[opt #f])
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) ks) stx opt))
(lambda (x) kf) (lambda (a b) ks) cert stx opt))
;;!(function next-outer-helper
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
@ -61,10 +62,11 @@
let-bound
kf-func
ks-func
cert
[stx (syntax '())]
[opt #f])
[opt #f])
;; right now this does not bind new variables
(let ((rendered-list (render-test-list p ae stx)))
(let ((rendered-list (render-test-list p ae cert stx)))
;; no need to reorder lists although I suspect that it may be
;; better to put shape tests first
(update-binding-count rendered-list)
@ -82,7 +84,7 @@
;; bindmap - a-list of bindings mapped to their expressions
;; last-test - a boolean value that indicates whether this function
;; is collecting one value or a list of values.</pre>
(define (create-test-func p sf let-bound bind-map last-test)
(define (create-test-func p sf let-bound bind-map last-test cert)
#`(lambda (exp)
#,(next-outer-helper
p #'exp sf '() let-bound
@ -102,14 +104,15 @@
#`(set! #,binding-name
#,exp-to-bind))))
bv)
#t))))))
#t)))
cert)))
;;!(function getbindings
;; (form (getbindings pat-syntax) -> list)
;; (contract syntax -> list))
;; This function given a pattern returns a list of pattern
;; variable names which are found in the pattern.
(define (getbindings pat-syntax)
(define (getbindings pat-syntax cert)
(let/cc out
(next-outer
pat-syntax
@ -118,7 +121,8 @@
'()
'()
(lambda (sf bv) #'(dummy-symbol))
(lambda (sf bv) (out (map car bv))))))
(lambda (sf bv) (out (map car bv)))
cert)))
;; end getbindings@
))

2
collects/mzlib/private/match-expander-struct.ss
View File

@ -2,6 +2,6 @@
(require "define-struct.scm")
(provide (all-defined))
#;(provide (struct match-expander (match-xform std-xform)))
(define-struct* match-expander (plt-match-xform match-xform std-xform)
(define-struct* match-expander (plt-match-xform match-xform std-xform certifier)
(procedure-field std-xform))
)

15
collects/mzlib/private/match-expander.ss
View File

@ -16,13 +16,14 @@
[(_ id plt-match-xform match-xform std-xform)
(if (identifier? (syntax std-xform))
#`(define-syntax id (make-match-expander plt-match-xform
match-xform
match-xform
(lambda (stx)
(syntax-case stx (set!)
#;[(set! id v) #'(set! std-xform v)]
[(nm args (... ...)) #'(std-xform args (... ...))]
[nm #'std-xform]))))
#'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform)))]
[nm #'std-xform]))
(syntax-local-certifier)))
#'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform (syntax-local-certifier))))]
[(_ id plt-match-xform std-xform)
(if (identifier? (syntax std-xform))
#`(define-syntax id (make-match-expander plt-match-xform
@ -31,15 +32,17 @@
(syntax-case stx (set!)
#;[(set! id v) #'(set! std-xform v)]
[(nm args (... ...)) #'(std-xform args (... ...))]
[nm #'std-xform]))))
#'(define-syntax id (make-match-expander plt-match-xform #f std-xform)))]
[nm #'std-xform]))
(syntax-local-certifier)))
#'(define-syntax id (make-match-expander plt-match-xform #f std-xform (syntax-local-certifier))))]
[(_ id plt-match-xform)
#'(define-syntax id
(make-match-expander
plt-match-xform
#f
(lambda (stx)
(match:syntax-err stx "This match expander must be used inside match"))))]
(match:syntax-err stx "This match expander must be used inside match"))
(syntax-local-certifier)))]
[_ (match:syntax-err stx "Invalid use of define-match-expander")]
))

123
collects/mzlib/private/render-test-list-impl.ss
View File

@ -80,8 +80,8 @@
;; expand the regexp-matcher into an (and) with string?
(define (regexp-matcher ae stx pred)
(render-test-list #`(and (? string?) #,pred) ae stx))
(define (regexp-matcher ae stx pred cert)
(render-test-list #`(and (? string?) #,pred) ae cert stx))
;;!(function or-gen
@ -99,11 +99,11 @@
;; larger pattern and the state of compilation has information
;; that will help optimaize its compilation. And the success of
;; any pattern results in the same outcome.
(define (or-gen exp orpatlist sf bv ks kf let-bound)
(define (or-gen exp orpatlist sf bv ks kf let-bound cert stx)
(define rendered-list
(map
(lambda (pat)
(cons (render-test-list pat exp)
(cons (render-test-list pat exp cert stx)
(lambda (fail let-bound)
(lambda (sf bv)
(let ((bv (map
@ -138,7 +138,7 @@
;; forward in the argument list of next and then test for it later and
;; then take the appropriate action. To understand this better take a
;; look at how proper and improper lists are handled.
(define/opt (render-test-list p ae [stx #'here])
(define/opt (render-test-list p ae cert [stx #'here])
(syntax-case*
p
(_ list quote quasiquote vector box ? app and or not struct set! var
@ -148,13 +148,20 @@
;; this is how we extend match
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value #'expander (lambda () #f))))
(let ([transformer (match-expander-plt-match-xform (syntax-local-value #'expander))])
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
(let* ([expander (syntax-local-value (cert #'expander))]
[transformer (match-expander-plt-match-xform expander)])
(if (not transformer)
(match:syntax-err #'expander
"This expander only works with standard match.")
(render-test-list (transformer #'(expander args ...))
ae stx)))]
(let ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)])
(render-test-list
(introducer (transformer (introducer #'(expander args ...))))
ae
(lambda (id)
(certifier (cert id) #f introducer))
stx))))]
;; underscore is reserved to match nothing
(_ '()) ;(ks sf bv let-bound))
@ -163,7 +170,7 @@
(pt
(and (pattern-var? (syntax pt))
(not (stx-dot-dot-k? (syntax pt))))
(render-test-list #'(var pt) ae stx))
(render-test-list #'(var pt) ae cert stx))
;; for variable patterns, we do bindings, and check if we've seen this variable before
((var pt)
@ -191,7 +198,7 @@
;; This recognizes constants such strings
[pt
(let ([pt (syntax-object->datum #'pt)])
(let ([pt (syntax-e #'pt)])
(or (string? pt)
(boolean? pt)
(char? pt)
@ -208,23 +215,15 @@
;; match a quoted datum
;; this is very similar to the previous pattern, except for the second argument to equal?
[(quote _)
((quote item)
(list
(reg-test
`(equal? ,(syntax-object->datum ae)
,(syntax-object->datum p))
ae (lambda (exp) #`(equal? #,exp #,p))))]
;; I do not understand this, or why it is ever matched, but removing it causes test failures
('item
(list
(reg-test
`(equal? ,(syntax-object->datum ae)
,(syntax-object->datum p))
ae (lambda (exp) #`(equal? #,exp #,p)))))
ae (lambda (exp) #`(equal? #,exp #,p)))))
(`quasi-pat
(render-test-list (parse-quasi #'quasi-pat) ae stx))
(render-test-list (parse-quasi #'quasi-pat) ae cert stx))
;; check for predicate patterns
@ -233,11 +232,11 @@
(list (reg-test
`(,(syntax-object->datum #'pred?)
,(syntax-object->datum ae))
ae (lambda (exp) #`(pred? #,exp)))))
ae (lambda (exp) #`(#,(cert #'pred?) #,exp)))))
;; predicate patterns with binders are redundant with and patterns
((? pred? pats ...)
(render-test-list #'(and (? pred?) pats ...) ae stx))
(render-test-list #'(and (? pred?) pats ...) ae cert stx))
;; syntax checking
((? anything ...)
@ -248,17 +247,17 @@
"syntax error in predicate pattern")))
((regexp reg-exp)
(regexp-matcher ae stx #'(? (lambda (x) (regexp-match reg-exp x)))))
(regexp-matcher ae stx #'(? (lambda (x) (regexp-match reg-exp x))) cert))
((pregexp reg-exp)
(regexp-matcher ae stx #'(? (lambda (x) (pregexp-match-with-error reg-exp x)))))
(regexp-matcher ae stx #'(? (lambda (x) (pregexp-match-with-error reg-exp x))) cert))
((regexp reg-exp pat)
(regexp-matcher ae stx #'(app (lambda (x) (regexp-match reg-exp x)) pat)))
(regexp-matcher ae stx #'(app (lambda (x) (regexp-match reg-exp x)) pat) cert))
((pregexp reg-exp pat)
(regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat)))
(regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat) cert))
;; app patterns just apply their operation. I'm not sure why they exist.
((app op pat)
(render-test-list #'pat #`(op #,ae) stx))
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))
;; syntax checking
((app . op)
@ -274,7 +273,7 @@
;; empty and always succeeds
[() '()] ;(ks seensofar boundvars let-bound))
[(pat . rest)
(append (render-test-list #'pat ae stx)
(append (render-test-list #'pat ae cert stx)
(loop #'rest))])))
((or . pats)
@ -284,7 +283,8 @@
(lambda (ks kf let-bound)
(lambda (sf bv)
(or-gen ae (syntax-e #'pats)
sf bv ks kf let-bound))))))
sf bv ks kf let-bound
cert stx))))))
((not pat)
@ -294,22 +294,23 @@
(lambda (ks kf let-bound)
(lambda (sf bv)
;; swap success and fail
(next-outer #'pat ae sf bv let-bound ks kf))))))
(next-outer #'pat ae sf bv let-bound ks kf cert))))))
;; (cons a b) == (list-rest a b)
[(cons p1 p2) (render-test-list #'(list-rest p1 p2) ae stx)]
[(cons p1 p2) (render-test-list #'(list-rest p1 p2) ae cert stx)]
;; could try to catch syntax local value error and rethrow syntax error
((list-no-order pats ...)
(if (stx-null? (syntax (pats ...)))
(render-test-list #'(list) ae stx)
(render-test-list #'(list) ae cert stx)
(let* ((pat-list (syntax->list (syntax (pats ...))))
(ddk-list (ddk-in-list? pat-list))
(ddk (ddk-only-at-end-of-list? pat-list)))
(if (or (not ddk-list)
(and ddk-list ddk))
(let* ((bound (getbindings (append-if-necc 'list
(syntax (pats ...)))))
(syntax (pats ...)))
cert))
(bind-map
(map (lambda (x)
(cons x #`#,(gensym (syntax-object->datum x))))
@ -333,7 +334,8 @@
sf
let-bound
bind-map
#t)))
#t
cert)))
#f)))
#`(let #,(map (lambda (b)
#`(#,(cdr b) '()))
@ -347,7 +349,8 @@
sf
let-bound
bind-map
#f))
#f
cert))
pat-list))))
(if (match:test-no-order test-list
#,ae
@ -404,7 +407,8 @@
bv
let-bound
kf
ks)))))))))
ks
cert)))))))))
((hash-table . pats)
(match:syntax-err
@ -416,7 +420,7 @@
(let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
[(num-of-fields) (length field-pats)]
[(pred accessors mutators parental-chain)
(struct-pred-accessors-mutators #'struct-name)]
(struct-pred-accessors-mutators (cert #'struct-name))]
;; check that we have the right number of fields
[(dif) (- (length accessors) num-of-fields)])
(unless (zero? dif)
@ -446,7 +450,8 @@
[_ (render-test-list
cur-pat
(quasisyntax/loc stx (#,cur-accessor #,ae))
stx)]))
cert
stx)]))
field-pats mutators accessors))))
;; syntax checking
@ -486,13 +491,15 @@
(handle-end-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
let-bound)
let-bound
cert)
(handle-inner-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
(append-if-necc 'list
(syntax (pat-rest ...)))
let-bound))))))
let-bound
cert))))))
;; list-rest pattern with a ooo or ook pattern
((list-rest pat dot-dot-k pat-rest ...)
@ -518,7 +525,8 @@
(stx-car (syntax (pat-rest ...)))
(append-if-necc 'list-rest
(syntax (pat-rest ...))))
let-bound)))))
let-bound
cert)))))
;; list-rest pattern for improper lists
;; handle proper and improper lists
@ -533,11 +541,13 @@
(append
(render-test-list (syntax car-pat)
(quasisyntax/loc (syntax car-pat) (car #,ae))
stx) ;(add-a e)
cert
stx) ;(add-a e)
(render-test-list
(syntax cdr-pat)
#`(cdr #,ae)
stx))))
cert
stx))))
;; list-rest pattern
((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
@ -551,11 +561,13 @@
(append
(render-test-list (syntax car-pat)
#`(car #,ae)
stx) ;(add-a e)
cert
stx) ;(add-a e)
(render-test-list
(append-if-necc 'list-rest (syntax (cdr-pat ...)))
#`(cdr #,ae)
stx))))
cert
stx))))
;; general list pattern
((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
@ -569,7 +581,8 @@
(append
(render-test-list (syntax car-pat)
#`(car #,ae)
stx) ;(add-a e)
cert
stx) ;(add-a e)
(if (stx-null? (syntax (cdr-pat ...)))
(list
(shape-test
@ -578,7 +591,8 @@
(render-test-list
(append-if-necc 'list (syntax (cdr-pat ...)))
#`(cdr #,ae)
stx)))))
cert
stx)))))
;; vector pattern with ooo or ook at end
((vector pats ...)
@ -593,7 +607,8 @@
(lambda (ks kf let-bound)
(handle-ddk-vector ae kf ks
#'#(pats ...)
let-bound)))))
let-bound
cert)))))
;; vector pattern with ooo or ook, but not at end
((vector pats ...)
@ -615,7 +630,8 @@
(lambda (ks kf let-bound)
(handle-ddk-vector-inner ae kf ks
#'#(pats ...)
let-bound)))))
let-bound
cert)))))
;; plain old vector pattern
((vector pats ...)
@ -635,7 +651,8 @@
(render-test-list
(vector-ref syntax-vec n)
#`(vector-ref #,ae #,n)
stx)
cert
stx)
(vloop (+ 1 n))))))))
((box pat)
@ -644,7 +661,7 @@
`(box? ,(syntax-object->datum ae))
ae (lambda (exp) #`(box? #,exp)))
(render-test-list
#'pat #`(unbox #,ae) stx)))
#'pat #`(unbox #,ae) cert stx)))
;; This pattern wasn't a valid form.
(got-too-far