diff --git a/collects/mzlib/private/convert-pat.ss b/collects/mzlib/private/convert-pat.ss index 14de311ad7..9c94e771f8 100644 --- a/collects/mzlib/private/convert-pat.ss +++ b/collects/mzlib/private/convert-pat.ss @@ -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")]))) ) \ No newline at end of file diff --git a/collects/mzlib/private/ddk-handlers.ss b/collects/mzlib/private/ddk-handlers.ss index 8da04c61ba..c19b4498ca 100644 --- a/collects/mzlib/private/ddk-handlers.ss +++ b/collects/mzlib/private/ddk-handlers.ss @@ -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))))))))) diff --git a/collects/mzlib/private/gen-match.ss b/collects/mzlib/private/gen-match.ss index c1db8a450e..4441df02a1 100644 --- a/collects/mzlib/private/gen-match.ss +++ b/collects/mzlib/private/gen-match.ss @@ -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 diff --git a/collects/mzlib/private/getbindings.ss b/collects/mzlib/private/getbindings.ss index 671c72ac8a..03676c6540 100644 --- a/collects/mzlib/private/getbindings.ss +++ b/collects/mzlib/private/getbindings.ss @@ -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. - (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@ )) diff --git a/collects/mzlib/private/match-expander-struct.ss b/collects/mzlib/private/match-expander-struct.ss index 0dbb5e28aa..22e205d06d 100644 --- a/collects/mzlib/private/match-expander-struct.ss +++ b/collects/mzlib/private/match-expander-struct.ss @@ -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)) ) \ No newline at end of file diff --git a/collects/mzlib/private/match-expander.ss b/collects/mzlib/private/match-expander.ss index dbe7011be1..3f545c28c5 100644 --- a/collects/mzlib/private/match-expander.ss +++ b/collects/mzlib/private/match-expander.ss @@ -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")] )) diff --git a/collects/mzlib/private/render-test-list-impl.ss b/collects/mzlib/private/render-test-list-impl.ss index 82dc0f6a33..1b8fe3a4e0 100644 --- a/collects/mzlib/private/render-test-list-impl.ss +++ b/collects/mzlib/private/render-test-list-impl.ss @@ -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)))] + "This expander only works with standard match.") + (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