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))) (pat stx)))
(define (convert-pat stx) (define (convert-pat stx)
(syntax-case* (convert-pat/cert stx (lambda (x) x)))
stx
(_ ? = and or not $ set! get! quasiquote (define (convert-pat/cert stx cert)
quote unquote unquote-splicing) stx-equal? (let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
[(expander . args) (syntax-case*
(and (identifier? #'expander) stx
(match-expander? (syntax-local-value #'expander (lambda () #f)))) (_ ? = and or not $ set! get! quasiquote
(let ([xformer (match-expander-match-xform quote unquote unquote-splicing) stx-equal?
(syntax-local-value #'expander (lambda () #f)))]) [(expander . args)
(if (not xformer) (and (identifier? #'expander)
(match:syntax-err #'expander (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
"This expander only works with plt-match.") (let* ([expander (syntax-local-value (cert #'expander) (lambda () #f))]
(convert-pat (xformer #'(expander . args)))))] [xformer (match-expander-match-xform expander)])
[p (if (not xformer)
(dot-dot-k? (syntax-object->datum #'p)) (match:syntax-err #'expander
stx] "This expander only works with plt-match.")
[_ stx] (let ([introducer (make-syntax-introducer)]
[() #'(list)] [certifier (match-expander-certifier expander)])
['() #'(list)] (convert-pat/cert
['item stx] (introducer (xformer (introducer stx)))
[p (lambda (id)
(let ((old-pat (syntax-object->datum #'p))) (certifier (cert id) #f introducer))))))]
(or (string? old-pat) [p
(boolean? old-pat) (dot-dot-k? (syntax-object->datum #'p))
(char? old-pat) stx]
(number? old-pat))) [_ stx]
stx] [() #'(list)]
[(? pred) stx] ['() #'(list)]
[(? pred . a) ['item stx]
(with-syntax ([pats (syntax-map convert-pat #'a)]) [p
#'(? pred . pats))] (let ((old-pat (syntax-e #'p)))
[`pat #``#,(convert-quasi #'pat)] (or (string? old-pat)
[(= op pat) #`(app op #,(convert-pat #'pat))] (boolean? old-pat)
[(and . pats) (char? old-pat)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)]) (number? old-pat)))
#'(and . new-pats))] stx]
[(or . pats) [(? pred) #`(? #,(cert #'pred))]
(with-syntax ([new-pats (syntax-map convert-pat #'pats)]) [(? pred . a)
#'(or . new-pats))] (with-syntax ([pred (cert #'pred)]
[(not pat) #`(not #,(convert-pat #'pat))] [pats (syntax-map convert-pat #'a)])
[($ struct-name . fields) #'(? pred . pats))]
(with-syntax ([new-fields (syntax-map convert-pat #'fields)]) [`pat #``#,(convert-quasi #'pat)]
#'(struct struct-name new-fields))] [(= op pat) #`(app #,(cert #'op) #,(convert-pat #'pat))]
[(get! id) stx] [(and . pats)
[(set! id) stx] (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
[(quote p) stx] #'(and . new-pats))]
[(car-pat . cdr-pat) [(or . pats)
(let ([l (imp-list? (syntax-e stx) stx)]) (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(if l #`(list-rest #,@(map convert-pat l)) #'(or . new-pats))]
#`(list #,@(map convert-pat (syntax-e stx)))))] [(not pat) #`(not #,(convert-pat #'pat))]
[pt [($ struct-name . fields)
(vector? (syntax-e stx)) (with-syntax ([struct-name (cert #'struct-name)]
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))]) [new-fields (syntax-map convert-pat #'fields)])
#'(vector . new-pats))] #'(struct struct-name new-fields))]
[pt [(get! id) (with-syntax ([id (cert #'id)])
(box? (syntax-e stx)) #'(get! id))]
#`(box #,(convert-pat (unbox (syntax-e stx))))] [(set! id) (with-syntax ([id (cert #'id)])
[pt #'(set! id))]
(identifier? stx) [(quote p) stx]
stx] [(car-pat . cdr-pat)
[got-too-far (let ([l (imp-list? (syntax-e stx) stx)])
(match:syntax-err stx "syntax error in pattern")])) (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 ;; pat - the pattern to be matched repeatedly
;; dot-dot-k - the ddk pattern ;; dot-dot-k - the ddk pattern
;; let-bound - a list of let bindings ;; 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 k (stx-dot-dot-k? dot-dot-k))
(define (ksucc sf bv) (define (ksucc sf bv)
(let ([bound (getbindings pat)]) (let ([bound (getbindings pat cert)])
(if (syntax? bound) (if (syntax? bound)
(kf sf bv) (kf sf bv)
(syntax-case pat (_) (syntax-case pat (_)
@ -59,7 +59,8 @@
bv bv
let-bound let-bound
(lambda (sf bv) #'#f) (lambda (sf bv) #'#f)
(lambda (sf bv) #'#t))] (lambda (sf bv) #'#t)
cert)]
[tst (syntax-case ptst () [tst (syntax-case ptst ()
[(pred eta) [(pred eta)
(and (identifier? #'pred) (and (identifier? #'pred)
@ -72,7 +73,7 @@
(ks sf bv))))] (ks sf bv))))]
[id [id
(and (identifier? #'id) (stx-equal? #'id (car bound))) (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 [the-pat
(let ([binding-list-names (generate-temporaries bound)] (let ([binding-list-names (generate-temporaries bound)]
(loop-name (gensym 'loop)) (loop-name (gensym 'loop))
@ -109,7 +110,8 @@
b-var b-var
bv) bv)
#,bindings-var)) #,bindings-var))
bound binding-list-names)))))))])))) bound binding-list-names)))
cert))))]))))
(define (new-emit f) (emit f ae let-bound sf bv kf ksucc)) (define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
(case k (case k
((0) (ksucc sf bv)) ((0) (ksucc sf bv))
@ -144,9 +146,9 @@
;; dot-dot-k - the ddk pattern ;; dot-dot-k - the ddk pattern
;; pat-rest - the rest of the list pattern that occurs after the ddk ;; pat-rest - the rest of the list pattern that occurs after the ddk
;; let-bound - a list of let bindings ;; 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* ((k (stx-dot-dot-k? dot-dot-k)))
(let ((bound (getbindings pat))) (let ((bound (getbindings pat cert)))
(if (syntax? bound) (if (syntax? bound)
(kf sf bv) (kf sf bv)
(syntax-case pat (_) (syntax-case pat (_)
@ -163,7 +165,8 @@
bv bv
let-bound let-bound
(lambda (sf bv) #'#f) (lambda (sf bv) #'#f)
(lambda (sf bv) #'#t))) (lambda (sf bv) #'#t)
cert))
(tst (syntax-case ptst () (tst (syntax-case ptst ()
((pred eta) ((pred eta)
(and (identifier? (and (identifier?
@ -196,7 +199,8 @@
bv bv
let-bound let-bound
kf kf
ks))) ks
cert)))
(if (zero? k) (if (zero? k)
succ succ
#`(if (>= #,count-name #,k) #`(if (>= #,count-name #,k)
@ -227,7 +231,8 @@
new-bv new-bv
let-bound let-bound
kf kf
ks))) ks
cert)))
(if (zero? k) (if (zero? k)
succ succ
#`(if (>= #,count-name #,k) #`(if (>= #,count-name #,k)
@ -259,7 +264,8 @@
bv) bv)
#,bindings-var)) #,bindings-var))
bound bound
binding-list-names)))))))))))))) binding-list-names)))
cert)))))))))))
;;!(function handle-ddk-vector ;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks let-bound) ;; (form (handle-ddk-vector ae kf ks let-bound)
;; -> ;; ->
@ -279,7 +285,7 @@
;; ks - a success function ;; ks - a success function
;; pt - the whole vector pattern ;; pt - the whole vector pattern
;; let-bound - a list of let bindings ;; 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)) (let* ((vec-stx (syntax-e pt))
(vlen (- (vector-length vec-stx) 2)) ;; length minus (vlen (- (vector-length vec-stx) 2)) ;; length minus
;; the pat ... ;; the pat ...
@ -287,7 +293,7 @@
(minlen (+ vlen k)) (minlen (+ vlen k))
;; get the bindings for the second to last element: ;; get the bindings for the second to last element:
;; 'pat' in pat ... ;; 'pat' in pat ...
(bound (getbindings (vector-ref vec-stx vlen))) (bound (getbindings (vector-ref vec-stx vlen) cert))
(exp-name (gensym 'exnm))) (exp-name (gensym 'exnm)))
(lambda (sf bv) (lambda (sf bv)
(if (syntax? bound) (if (syntax? bound)
@ -308,7 +314,8 @@
bv bv
let-bound let-bound
kf kf
(vloop (+ 1 n)))) (vloop (+ 1 n))
cert))
((eq? (syntax-object->datum ((eq? (syntax-object->datum
(vector-ref vec-stx vlen)) (vector-ref vec-stx vlen))
'_) '_)
@ -353,7 +360,8 @@
bv) bv)
#,bindings-var)) #,bindings-var))
bound bound
binding-list-names))))))))))) binding-list-names)))
cert))))))))
sf sf
bv)))))))) bv))))))))
@ -377,7 +385,7 @@
;; ks - a success function ;; ks - a success function
;; pt - the whole vector pattern ;; pt - the whole vector pattern
;; let-bound - a list of let bindings ;; 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)) (let* ((vec-stx (syntax-e pt))
;; vlen as an index points at the pattern before the ddk ;; vlen as an index points at the pattern before the ddk
(vlen (- (vector-length vec-stx) 2)) ;; length minus (vlen (- (vector-length vec-stx) 2)) ;; length minus
@ -390,7 +398,7 @@
(exp-name (gensym 'exnm))) (exp-name (gensym 'exnm)))
;; get the bindings for the second to last element: ;; get the bindings for the second to last element:
;; 'pat' in pat ... ;; '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 ;; we have to look at the first pattern and see if a ddk follows it
;; if so handle that case else handle the pattern ;; if so handle that case else handle the pattern
(lambda (sf bv) (lambda (sf bv)
@ -441,7 +449,8 @@
;(set! current-index-name #`(add1 #,current-index-name)) ;(set! current-index-name #`(add1 #,current-index-name))
(let ((cindnm (gensym 'cindnm))) (let ((cindnm (gensym 'cindnm)))
#`(let ((#,cindnm (add1 #,count-offset-name-passover))) #`(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 ((and (eq? (syntax-object->datum
(vector-ref vec-stx n)) ;this could be it (vector-ref vec-stx n)) ;this could be it
'_) '_)
@ -449,7 +458,7 @@
(stx-dot-dot-k? (vector-ref vec-stx (add1 n))))) (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))))
(ks sf bv)) (ks sf bv))
(else ;; we now know that the next pattern is a ddk (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) (if (syntax? bound)
(kf sf bv) (kf sf bv)
(let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))) (let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n))))
@ -523,7 +532,8 @@
(apply (apply
#,vloop-name #,vloop-name
(add1 #,count-name) (add1 #,count-name)
arglist))))))))))))))) arglist)))
cert))))))))))))
sf sf
bv))))))))) bv)))))))))

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

@ -110,7 +110,7 @@
let-bound))) let-bound)))
bv))) bv)))
(success-func sf 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)) (cons test-list success))
;;!(function gen-match ;;!(function gen-match

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

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

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

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