diff --git a/collects/mzlib/private/match/ddk-handlers.ss b/collects/mzlib/private/match/ddk-handlers.ss index c19b4498ca..bafa793af2 100644 --- a/collects/mzlib/private/match/ddk-handlers.ss +++ b/collects/mzlib/private/match/ddk-handlers.ss @@ -8,88 +8,239 @@ "render-helpers.ss" "render-sigs.ss" (lib "stx.ss" "syntax") - (lib "unitsig.ss")) + (lib "unit.ss")) (require-for-template mzscheme "test-no-order.ss") - (define ddk-handlers@ - (unit/sig ddk-handlers^ (import getbindings^ render-test-list^) - - - ;;!(function handle-end-ddk-list - ;; (form (handle-end-ddk-list ae kf ks pat - ;; dot-dot-k - ;; let-bound) - ;; -> - ;; ((list list) -> syntax)) - ;; (contract (syntax - ;; ((list list) -> syntax) - ;; ((list list) -> syntax) - ;; syntax - ;; syntax - ;; list) - ;; -> - ;; ((list list) -> syntax))) - ;; This returns a function which generates the code for - ;; a pattern that ends with a ddk. This function is only applied to the - ;; last pattern and the ddk. - ;; Args: - ;; ae - the expression being matched - ;; kf - a failure function - ;; ks - a success function - ;; 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 cert) sf bv) - (define k (stx-dot-dot-k? dot-dot-k)) - (define (ksucc sf bv) - (let ([bound (getbindings pat cert)]) - (if (syntax? bound) - (kf sf bv) - (syntax-case pat (_) - [_ (ks sf bv)] - [the-pat - (null? bound) - (with-syntax ([exp-sym #'exp-sym]) - (let* ([ptst (next-outer - pat - #'exp-sym - sf - bv - let-bound - (lambda (sf bv) #'#f) - (lambda (sf bv) #'#t) - cert)] - [tst (syntax-case ptst () - [(pred eta) - (and (identifier? #'pred) - ;free-identifier=? - (stx-equal? #'eta #'exp-sym)) - #'pred] - [_ #`(lambda (exp-sym) #,ptst)])]) - (assm #`(andmap #,tst #,(subst-bindings ae let-bound)) - (kf sf bv) - (ks sf bv))))] - [id - (and (identifier? #'id) (stx-equal? #'id (car bound))) - (next-outer #'id ae sf bv let-bound kf ks cert)] - [the-pat - (let ([binding-list-names (generate-temporaries bound)] - (loop-name (gensym 'loop)) - (exp-name (gensym 'exp))) - #`(let #,loop-name - ((#,exp-name #,(subst-bindings ae let-bound)) - #,@(map - (lambda (x) - #`(#,x '())) - binding-list-names)) - (if (null? #,exp-name) - #,(ks sf (append (map cons bound - (map - (lambda (x) #`(reverse #,x)) - binding-list-names)) - bv)) + (define-unit ddk-handlers@ + (import getbindings^ render-test-list^) + (export ddk-handlers^) + + ;;!(function handle-end-ddk-list + ;; (form (handle-end-ddk-list ae kf ks pat + ;; dot-dot-k + ;; let-bound) + ;; -> + ;; ((list list) -> syntax)) + ;; (contract (syntax + ;; ((list list) -> syntax) + ;; ((list list) -> syntax) + ;; syntax + ;; syntax + ;; list) + ;; -> + ;; ((list list) -> syntax))) + ;; This returns a function which generates the code for + ;; a pattern that ends with a ddk. This function is only applied to the + ;; last pattern and the ddk. + ;; Args: + ;; ae - the expression being matched + ;; kf - a failure function + ;; ks - a success function + ;; 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 cert) sf bv) + (define k (stx-dot-dot-k? dot-dot-k)) + (define (ksucc sf bv) + (let ([bound (getbindings pat cert)]) + (if (syntax? bound) + (kf sf bv) + (syntax-case pat (_) + [_ (ks sf bv)] + [the-pat + (null? bound) + (with-syntax ([exp-sym #'exp-sym]) + (let* ([ptst (next-outer + pat + #'exp-sym + sf + bv + let-bound + (lambda (sf bv) #'#f) + (lambda (sf bv) #'#t) + cert)] + [tst (syntax-case ptst () + [(pred eta) + (and (identifier? #'pred) + ;free-identifier=? + (stx-equal? #'eta #'exp-sym)) + #'pred] + [_ #`(lambda (exp-sym) #,ptst)])]) + (assm #`(andmap #,tst #,(subst-bindings ae let-bound)) + (kf sf bv) + (ks sf bv))))] + [id + (and (identifier? #'id) (stx-equal? #'id (car bound))) + (next-outer #'id ae sf bv let-bound kf ks cert)] + [the-pat + (let ([binding-list-names (generate-temporaries bound)] + (loop-name (gensym 'loop)) + (exp-name (gensym 'exp))) + #`(let #,loop-name + ((#,exp-name #,(subst-bindings ae let-bound)) + #,@(map + (lambda (x) + #`(#,x '())) + binding-list-names)) + (if (null? #,exp-name) + #,(ks sf (append (map cons bound + (map + (lambda (x) #`(reverse #,x)) + binding-list-names)) + bv)) + #,(next-outer #'the-pat + #`(car #,exp-name) + sf + bv ;; we always start + ;; over with the old + ;; bindings + let-bound + kf + (lambda (sf bv) + #`(#,loop-name + (cdr #,exp-name) + #,@(map + (lambda + (b-var + bindings-var) + #`(cons + #,(get-bind-val + b-var + bv) + #,bindings-var)) + bound binding-list-names))) + cert))))])))) + (define (new-emit f) (emit f ae let-bound sf bv kf ksucc)) + (case k + ((0) (ksucc sf bv)) + ((1) (new-emit (lambda (exp) #`(pair? #,exp)))) + (else (new-emit (lambda (exp) #`(>= (length #,exp) #,k)))))) + + ;;!(function handle-inner-ddk-list + ;; (form (handle-inner-ddk-list ae kf ks pat + ;; dot-dot-k pat-rest + ;; let-bound) + ;; -> + ;; ((list list) -> syntax)) + ;; (contract (syntax + ;; ((list list) -> syntax) + ;; ((list list) -> syntax) + ;; syntax + ;; syntax + ;; syntax + ;; list) + ;; -> + ;; ((list list) -> syntax))) + ;; This returns a function which generates the code for a list + ;; pattern that contains with a ddk that occurs before the end of + ;; the list. This code is extremely similar to the code in + ;; handle-end-ddk-list but there are enough differences to warrant + ;; having a separate method for readability. + ;; Args: + ;; ae - the expression being matched + ;; kf - a failure function + ;; ks - a success function + ;; pat - the pattern that preceeds the ddk + ;; 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 cert) sf bv) + (let* ((k (stx-dot-dot-k? dot-dot-k))) + (let ((bound (getbindings pat cert))) + (if (syntax? bound) + (kf sf bv) + (syntax-case pat (_) + (_ + (stx-null? pat-rest) + (ks sf bv)) + (the-pat + (null? bound) + (with-syntax ((exp-sym (syntax exp-sym))) + (let* ((ptst (next-outer + pat + #'exp-sym + sf + bv + let-bound + (lambda (sf bv) #'#f) + (lambda (sf bv) #'#t) + cert)) + (tst (syntax-case ptst () + ((pred eta) + (and (identifier? + (syntax pred)) + ;free-identifier=? + (stx-equal? + (syntax eta) + (syntax exp-sym))) + (syntax pred)) + (whatever + #`(lambda (exp-sym) #,ptst)))) + (loop-name (gensym 'ddnnl)) + (exp-name (gensym 'exp)) + (count-name (gensym 'count))) + #`(let #,loop-name ((#,exp-name + #,(subst-bindings ae let-bound)) + (#,count-name 0)) + (if (and (not (null? #,exp-name)) + ;; added for improper ddk + (pair? #,exp-name) + (#,tst (car #,exp-name))) + (#,loop-name (cdr #,exp-name) + (add1 #,count-name)) + ;; testing the count is not neccessary + ;; if the count is zero + #,(let ((succ (next-outer + pat-rest + #`#,exp-name + sf + bv + let-bound + kf + ks + cert))) + (if (zero? k) + succ + #`(if (>= #,count-name #,k) + #,succ + #,(kf sf bv))))))))) + (the-pat + (let* ([binding-list-names (generate-temporaries bound)] + (loop-name #`#,(gensym 'loop)) + (exp-name #`#,(gensym 'exp)) + (fail-name #`#,(gensym 'fail)) + (count-name #`#,(gensym 'count)) + (new-bv (append (map cons bound + (map (lambda (x) #`(reverse #,x)) + binding-list-names)) + bv))) + #`(let #,loop-name + ((#,exp-name #,(subst-bindings ae let-bound)) + (#,count-name 0) + #,@(map + (lambda (x) #`(#,x '())) + binding-list-names)) + (let ((#,fail-name + (lambda () + #,(let ((succ (next-outer + pat-rest + #`#,exp-name + sf + new-bv + let-bound + kf + ks + cert))) + (if (zero? k) + succ + #`(if (>= #,count-name #,k) + #,succ + #,(kf sf new-bv))))))) + (if (or (null? #,exp-name) + (not (pair? #,exp-name))) + (#,fail-name) #,(next-outer #'the-pat #`(car #,exp-name) sf @@ -97,10 +248,12 @@ ;; over with the old ;; bindings let-bound - kf + (lambda (sf bv) + #`(#,fail-name)) (lambda (sf bv) #`(#,loop-name (cdr #,exp-name) + (add1 #,count-name) #,@(map (lambda (b-var @@ -110,434 +263,281 @@ b-var bv) #,bindings-var)) - bound binding-list-names))) - cert))))])))) - (define (new-emit f) (emit f ae let-bound sf bv kf ksucc)) - (case k - ((0) (ksucc sf bv)) - ((1) (new-emit (lambda (exp) #`(pair? #,exp)))) - (else (new-emit (lambda (exp) #`(>= (length #,exp) #,k)))))) - - ;;!(function handle-inner-ddk-list - ;; (form (handle-inner-ddk-list ae kf ks pat - ;; dot-dot-k pat-rest - ;; let-bound) - ;; -> - ;; ((list list) -> syntax)) - ;; (contract (syntax - ;; ((list list) -> syntax) - ;; ((list list) -> syntax) - ;; syntax - ;; syntax - ;; syntax - ;; list) - ;; -> - ;; ((list list) -> syntax))) - ;; This returns a function which generates the code for a list - ;; pattern that contains with a ddk that occurs before the end of - ;; the list. This code is extremely similar to the code in - ;; handle-end-ddk-list but there are enough differences to warrant - ;; having a separate method for readability. - ;; Args: - ;; ae - the expression being matched - ;; kf - a failure function - ;; ks - a success function - ;; pat - the pattern that preceeds the ddk - ;; 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 cert) sf bv) - (let* ((k (stx-dot-dot-k? dot-dot-k))) - (let ((bound (getbindings pat cert))) - (if (syntax? bound) - (kf sf bv) - (syntax-case pat (_) - (_ - (stx-null? pat-rest) - (ks sf bv)) - (the-pat - (null? bound) - (with-syntax ((exp-sym (syntax exp-sym))) - (let* ((ptst (next-outer - pat - #'exp-sym + bound + binding-list-names))) + cert))))))))))) + ;;!(function handle-ddk-vector + ;; (form (handle-ddk-vector ae kf ks let-bound) + ;; -> + ;; ((list list) -> syntax)) + ;; (contract (syntax + ;; ((list list) -> syntax) + ;; ((list list) -> syntax) + ;; list) + ;; -> + ;; ((list list) -> syntax))) + ;; This returns a function which generates the code for a vector + ;; pattern that contains a ddk that occurs at the end of the + ;; vector. + ;; Args: + ;; ae - the expression being matched + ;; kf - a failure function + ;; 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 cert) + (let* ((vec-stx (syntax-e pt)) + (vlen (- (vector-length vec-stx) 2)) ;; length minus + ;; the pat ... + (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen)))) + (minlen (+ vlen k)) + ;; get the bindings for the second to last element: + ;; 'pat' in pat ... + (bound (getbindings (vector-ref vec-stx vlen) cert)) + (exp-name (gensym 'exnm))) + (lambda (sf bv) + (if (syntax? bound) + (kf sf bv) + (quasisyntax/loc + pt + (let ((#,exp-name #,(subst-bindings ae let-bound))) + #,(assm #`(>= (vector-length #,exp-name) #,minlen) + (kf sf bv) + ((let vloop ((n 0)) + (lambda (sf bv) + (cond + ((not (= n vlen)) + (next-outer + (vector-ref vec-stx n) + #`(vector-ref #,exp-name #,n) sf bv let-bound - (lambda (sf bv) #'#f) - (lambda (sf bv) #'#t) - cert)) - (tst (syntax-case ptst () - ((pred eta) - (and (identifier? - (syntax pred)) - ;free-identifier=? - (stx-equal? - (syntax eta) - (syntax exp-sym))) - (syntax pred)) - (whatever - #`(lambda (exp-sym) #,ptst)))) - (loop-name (gensym 'ddnnl)) - (exp-name (gensym 'exp)) - (count-name (gensym 'count))) - #`(let #,loop-name ((#,exp-name - #,(subst-bindings ae let-bound)) - (#,count-name 0)) - (if (and (not (null? #,exp-name)) - ;; added for improper ddk - (pair? #,exp-name) - (#,tst (car #,exp-name))) - (#,loop-name (cdr #,exp-name) - (add1 #,count-name)) - ;; testing the count is not neccessary - ;; if the count is zero - #,(let ((succ (next-outer - pat-rest - #`#,exp-name - sf - bv - let-bound - kf - ks - cert))) - (if (zero? k) - succ - #`(if (>= #,count-name #,k) - #,succ - #,(kf sf bv))))))))) - (the-pat - (let* ([binding-list-names (generate-temporaries bound)] - (loop-name #`#,(gensym 'loop)) - (exp-name #`#,(gensym 'exp)) - (fail-name #`#,(gensym 'fail)) - (count-name #`#,(gensym 'count)) - (new-bv (append (map cons bound - (map (lambda (x) #`(reverse #,x)) - binding-list-names)) - bv))) - #`(let #,loop-name - ((#,exp-name #,(subst-bindings ae let-bound)) - (#,count-name 0) - #,@(map - (lambda (x) #`(#,x '())) - binding-list-names)) - (let ((#,fail-name - (lambda () - #,(let ((succ (next-outer - pat-rest - #`#,exp-name - sf - new-bv - let-bound - kf - ks - cert))) - (if (zero? k) - succ - #`(if (>= #,count-name #,k) - #,succ - #,(kf sf new-bv))))))) - (if (or (null? #,exp-name) - (not (pair? #,exp-name))) - (#,fail-name) - #,(next-outer #'the-pat - #`(car #,exp-name) - sf - bv ;; we always start - ;; over with the old - ;; bindings - let-bound - (lambda (sf bv) - #`(#,fail-name)) - (lambda (sf bv) - #`(#,loop-name - (cdr #,exp-name) - (add1 #,count-name) - #,@(map - (lambda - (b-var - bindings-var) - #`(cons - #,(get-bind-val - b-var - bv) - #,bindings-var)) - bound - binding-list-names))) - cert))))))))))) - ;;!(function handle-ddk-vector - ;; (form (handle-ddk-vector ae kf ks let-bound) - ;; -> - ;; ((list list) -> syntax)) - ;; (contract (syntax - ;; ((list list) -> syntax) - ;; ((list list) -> syntax) - ;; list) - ;; -> - ;; ((list list) -> syntax))) - ;; This returns a function which generates the code for a vector - ;; pattern that contains a ddk that occurs at the end of the - ;; vector. - ;; Args: - ;; ae - the expression being matched - ;; kf - a failure function - ;; 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 cert) - (let* ((vec-stx (syntax-e pt)) - (vlen (- (vector-length vec-stx) 2)) ;; length minus - ;; the pat ... - (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen)))) - (minlen (+ vlen k)) - ;; get the bindings for the second to last element: - ;; 'pat' in pat ... - (bound (getbindings (vector-ref vec-stx vlen) cert)) - (exp-name (gensym 'exnm))) - (lambda (sf bv) - (if (syntax? bound) - (kf sf bv) - (quasisyntax/loc - pt - (let ((#,exp-name #,(subst-bindings ae let-bound))) - #,(assm #`(>= (vector-length #,exp-name) #,minlen) - (kf sf bv) - ((let vloop ((n 0)) - (lambda (sf bv) - (cond - ((not (= n vlen)) - (next-outer - (vector-ref vec-stx n) - #`(vector-ref #,exp-name #,n) - sf - bv - let-bound - kf - (vloop (+ 1 n)) - cert)) - ((eq? (syntax-object->datum - (vector-ref vec-stx vlen)) - '_) - (ks sf bv)) - (else - (let* ((binding-list-names - (map (lambda (x) - (datum->syntax-object - (quote-syntax here) - (symbol-append - (gensym (syntax-object->datum x)) - '-bindings))) - bound)) - (vloop-name (gensym 'vloop)) - (index-name (gensym 'index))) - #`(let #,vloop-name - ((#,index-name (- (vector-length #,exp-name) 1)) - #,@(map (lambda (x) #`(#,x '())) - binding-list-names)) - (if (> #,vlen #,index-name) - #,(ks sf - (append (map cons bound - binding-list-names) - bv)) + kf + (vloop (+ 1 n)) + cert)) + ((eq? (syntax-object->datum + (vector-ref vec-stx vlen)) + '_) + (ks sf bv)) + (else + (let* ((binding-list-names + (map (lambda (x) + (datum->syntax-object + (quote-syntax here) + (symbol-append + (gensym (syntax-object->datum x)) + '-bindings))) + bound)) + (vloop-name (gensym 'vloop)) + (index-name (gensym 'index))) + #`(let #,vloop-name + ((#,index-name (- (vector-length #,exp-name) 1)) + #,@(map (lambda (x) #`(#,x '())) + binding-list-names)) + (if (> #,vlen #,index-name) + #,(ks sf + (append (map cons bound + binding-list-names) + bv)) + #,(next-outer + (vector-ref vec-stx n) + #`(vector-ref #,exp-name #,index-name) + sf + bv ;; we alway start over + ;; with the old bindings + let-bound + kf + (lambda (sf bv) + #`(#,vloop-name + (- #,index-name 1) + #,@(map + (lambda (b-var + bindings-var) + #`(cons + #,(get-bind-val + b-var + bv) + #,bindings-var)) + bound + binding-list-names))) + cert)))))))) + sf + bv)))))))) + + ;;!(function handle-ddk-vector-inner + ;; (form (handle-ddk-vector-inner ae kf ks pt let-bound) + ;; -> + ;; ((list list) -> syntax)) + ;; (contract (syntax + ;; ((list list) -> syntax) + ;; ((list list) -> syntax) + ;; syntax + ;; list) + ;; -> + ;; ((list list) -> syntax))) + ;; This returns a function which generates the code for a vector + ;; pattern that contains a ddk that occurs before another pattern + ;; in the list. + ;; Args: + ;; ae - the expression being matched + ;; kf - a failure function + ;; 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 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 + ;; the pat ... + (vec-len (vector-length vec-stx)) + (total-k (ddk-in-vec? vec-stx pt)) + ;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen)))) + (minlen (+ vec-len total-k)) + (length-of-vector-name (gensym 'lv)) + (exp-name (gensym 'exnm))) + ;; get the bindings for the second to last element: + ;; 'pat' in pat ... + ;;(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) + ;; minlen here could be the lentgh plus the k's - 1 for each ddk + #`(let ((#,exp-name #,(subst-bindings ae let-bound))) + (let ((#,length-of-vector-name (vector-length #,exp-name))) + #,(assm #`(>= #,length-of-vector-name #,minlen) + (kf sf bv) + (let ((current-index-name (gensym 'curr-ind))) + #`(let ((#,current-index-name 0)) + #,((let vloop ((n 0) + (count-offset-name-passover + current-index-name)) + (lambda (sf bv) + + (cond + ((= n vec-len) ;; at the end of the patterns + (quasisyntax/loc + pt + (if (>= #,count-offset-name-passover + #,length-of-vector-name) + #,(ks sf bv) + #,(kf sf bv)))) + ((stx-dot-dot-k? (vector-ref vec-stx n)) + ;;this could be it + (match:syntax-err + pt + "should not get here")) + ;; if the next one is not a ddk do a normal pattern match + ;; on element + ((or (= n (sub1 vec-len)) + (not (stx-dot-dot-k? (vector-ref vec-stx + (add1 n))))) + (quasisyntax/loc + pt + (if (= #,count-offset-name-passover + #,length-of-vector-name) + #,(kf sf bv) #,(next-outer - (vector-ref vec-stx n) - #`(vector-ref #,exp-name #,index-name) - sf - bv ;; we alway start over - ;; with the old bindings + (vector-ref vec-stx n) ;this could be it + #`(vector-ref #,exp-name #,count-offset-name-passover) + '() ;we don't want these tests to take part in future + ; elimination or to be eliminated + bv let-bound kf - (lambda (sf bv) - #`(#,vloop-name - (- #,index-name 1) - #,@(map - (lambda (b-var - bindings-var) - #`(cons - #,(get-bind-val - b-var - bv) - #,bindings-var)) - bound - binding-list-names))) - cert)))))))) - sf - bv)))))))) - - ;;!(function handle-ddk-vector-inner - ;; (form (handle-ddk-vector-inner ae kf ks pt let-bound) - ;; -> - ;; ((list list) -> syntax)) - ;; (contract (syntax - ;; ((list list) -> syntax) - ;; ((list list) -> syntax) - ;; syntax - ;; list) - ;; -> - ;; ((list list) -> syntax))) - ;; This returns a function which generates the code for a vector - ;; pattern that contains a ddk that occurs before another pattern - ;; in the list. - ;; Args: - ;; ae - the expression being matched - ;; kf - a failure function - ;; 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 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 - ;; the pat ... - (vec-len (vector-length vec-stx)) - (total-k (ddk-in-vec? vec-stx pt)) - ;; (k (stx-dot-dot-k? (vector-ref vec-stx (add1 vlen)))) - (minlen (+ vec-len total-k)) - (length-of-vector-name (gensym 'lv)) - (exp-name (gensym 'exnm))) - ;; get the bindings for the second to last element: - ;; 'pat' in pat ... - ;;(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) - ;; minlen here could be the lentgh plus the k's - 1 for each ddk - #`(let ((#,exp-name #,(subst-bindings ae let-bound))) - (let ((#,length-of-vector-name (vector-length #,exp-name))) - #,(assm #`(>= #,length-of-vector-name #,minlen) - (kf sf bv) - (let ((current-index-name (gensym 'curr-ind))) - #`(let ((#,current-index-name 0)) - #,((let vloop ((n 0) - (count-offset-name-passover - current-index-name)) - (lambda (sf bv) - - (cond - ((= n vec-len) ;; at the end of the patterns - (quasisyntax/loc - pt - (if (>= #,count-offset-name-passover - #,length-of-vector-name) - #,(ks sf bv) - #,(kf sf bv)))) - ((stx-dot-dot-k? (vector-ref vec-stx n)) - ;;this could be it - (match:syntax-err - pt - "should not get here")) - ;; if the next one is not a ddk do a normal pattern match - ;; on element - ((or (= n (sub1 vec-len)) - (not (stx-dot-dot-k? (vector-ref vec-stx - (add1 n))))) - (quasisyntax/loc - pt - (if (= #,count-offset-name-passover - #,length-of-vector-name) - #,(kf sf bv) - #,(next-outer - (vector-ref vec-stx n) ;this could be it - #`(vector-ref #,exp-name #,count-offset-name-passover) - '() ;we don't want these tests to take part in future - ; elimination or to be eliminated - bv - let-bound - kf - (lambda (bsf bv) - ;(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)))) - cert)))) - ((and (eq? (syntax-object->datum - (vector-ref vec-stx n)) ;this could be it - '_) - (>= (- vec-len n 1) - (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) cert))) - (if (syntax? bound) - (kf sf bv) - (let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))) - (binding-list-names - (map (lambda (x) - (datum->syntax-object - (quote-syntax here) - (symbol-append - (gensym (syntax-object->datum x)) - '-bindings))) - bound)) - (vloop-name (gensym 'vloop)) - (count-name (gensym 'count)) - (index-name (gensym 'index))) - #`(let #,vloop-name - ((#,count-name #,count-offset-name-passover) - #,@(map (lambda (x) #`(#,x '())) - binding-list-names)) - #,(let ((fail-name (gensym 'fail)) - (count-offset-name (gensym 'count-offset)) - (index-name (gensym 'index)) - ) - #`(let ((#,fail-name - (lambda (#,count-offset-name #,index-name) - #,(let ((body ((vloop (+ n 2) index-name) sf - (append (map (lambda (b bln) - (cons b - (quasisyntax/loc - pt - (reverse #,bln)))) - bound - binding-list-names) - bv) - ))) - (if (> k 0) - (quasisyntax/loc - pt - (if (>= #,count-offset-name #,k) - #,body - #,(kf sf bv))) - body))))) - (if (= #,length-of-vector-name #,count-name) - (#,fail-name - (- #,count-name #,count-offset-name-passover) - #,count-name) - #,(next-outer - (vector-ref vec-stx n) ;this could be it - #`(vector-ref #,exp-name #,count-name) - '() ;sf - bv ;; we alway start over - ;; with the old bindings - let-bound - (lambda (sf bv) - #`(#,fail-name - (- #,count-name - #,count-offset-name-passover) - #,count-name)) - (lambda (sf bv) - #`(let ((arglist - (list - #,@(map - (lambda (b-var - bindings-var) - #`(cons - #,(get-bind-val - b-var - bv) - #,bindings-var)) - bound - binding-list-names)))) - (apply - #,vloop-name - (add1 #,count-name) - arglist))) - cert)))))))))))) - sf - bv))))))))) - - ;; end of ddk-handlers@ - )) + (lambda (bsf bv) + ;(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)))) + cert)))) + ((and (eq? (syntax-object->datum + (vector-ref vec-stx n)) ;this could be it + '_) + (>= (- vec-len n 1) + (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) cert))) + (if (syntax? bound) + (kf sf bv) + (let* ((k (stx-dot-dot-k? (vector-ref vec-stx (add1 n)))) + (binding-list-names + (map (lambda (x) + (datum->syntax-object + (quote-syntax here) + (symbol-append + (gensym (syntax-object->datum x)) + '-bindings))) + bound)) + (vloop-name (gensym 'vloop)) + (count-name (gensym 'count)) + (index-name (gensym 'index))) + #`(let #,vloop-name + ((#,count-name #,count-offset-name-passover) + #,@(map (lambda (x) #`(#,x '())) + binding-list-names)) + #,(let ((fail-name (gensym 'fail)) + (count-offset-name (gensym 'count-offset)) + (index-name (gensym 'index)) + ) + #`(let ((#,fail-name + (lambda (#,count-offset-name #,index-name) + #,(let ((body ((vloop (+ n 2) index-name) sf + (append (map (lambda (b bln) + (cons b + (quasisyntax/loc + pt + (reverse #,bln)))) + bound + binding-list-names) + bv) + ))) + (if (> k 0) + (quasisyntax/loc + pt + (if (>= #,count-offset-name #,k) + #,body + #,(kf sf bv))) + body))))) + (if (= #,length-of-vector-name #,count-name) + (#,fail-name + (- #,count-name #,count-offset-name-passover) + #,count-name) + #,(next-outer + (vector-ref vec-stx n) ;this could be it + #`(vector-ref #,exp-name #,count-name) + '() ;sf + bv ;; we alway start over + ;; with the old bindings + let-bound + (lambda (sf bv) + #`(#,fail-name + (- #,count-name + #,count-offset-name-passover) + #,count-name)) + (lambda (sf bv) + #`(let ((arglist + (list + #,@(map + (lambda (b-var + bindings-var) + #`(cons + #,(get-bind-val + b-var + bv) + #,bindings-var)) + bound + binding-list-names)))) + (apply + #,vloop-name + (add1 #,count-name) + arglist))) + cert)))))))))))) + sf + bv))))))))) + + ;; end of ddk-handlers@ + ) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/getbindings.ss b/collects/mzlib/private/match/getbindings.ss index 5686d5de8b..5dc9fb3393 100644 --- a/collects/mzlib/private/match/getbindings.ss +++ b/collects/mzlib/private/match/getbindings.ss @@ -5,123 +5,124 @@ "update-binding-counts.scm" "render-helpers.ss" "render-sigs.ss" - (lib "unitsig.ss")) + (lib "unit.ss")) (require-for-template mzscheme) - (define getbindings@ - (unit/sig getbindings^ (import render-test-list^) - - ;;!(function next-outer - ;; (form (next-outer p ae sf bv let-bound kf ks syntax bool) - ;; -> - ;; syntax) - ;; (contract (syntax syntax list list list (list list -> syntax) - ;; (list list -> syntax) syntax bool) - ;; -> - ;; syntax)) - ;; The function next-outer is basically a throw-back to the next - ;; function of the original match compiler. It compiles a pattern - ;; or sub-pattern of a clause and does not yield a list of - ;; partially compiled test structs. This function is called - ;; inside of test constructs that cannot be eliminated because of - ;; a related presence in the test-so-far list. So, instead of - ;; partially compiling patterns this function fully compiles patterns. - (define/opt (next-outer - p - ae ;; this is the actual expression - sf - bv - let-bound - kf - ks - cert - [stx (syntax '())]) - (next-outer-helper p ae sf bv let-bound - (lambda (x) kf) (lambda (a b) ks) cert stx)) - - ;;!(function next-outer-helper - ;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool) - ;; -> - ;; syntax) - ;; (contract (syntax syntax list list list (list list -> syntax) - ;; (list list -> syntax) syntax bool) - ;; -> - ;; syntax)) - ;; The function next-outer-helper contains the meat of next-outer - ;; and allows the programmer to pass higher order functions - ;; ks-func and kf-func that will be given compile time imformation - ;; about let-bindings etc. which in turn will allow the programmer - ;; to take advantage of this info. - (define/opt (next-outer-helper - p - ae ;; this is the actual expression - sf - bv - let-bound - kf-func - ks-func - cert - [stx (syntax '())]) - ;; right now this does not bind new variables - (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) - ((couple-tests rendered-list ks-func kf-func let-bound) sf bv))) - - ;;!(function create-test-func - ;; (form (create-test-func p sf let-bound bind-map last-test) - ;; -> - ;; syntax) - ;; (contract (syntax list list a-list bool) -> syntax)) - ;; This function creates a runtime function that is used as an - ;; individual test in a list of tests for the list-no-order - ;; pattern. - ;; 
-      ;; 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 cert) - #`(lambda (exp) - #,(next-outer-helper - p #'exp sf '() let-bound - (lambda (let-bound) - (lambda (sf bv) - #'#f)) - (lambda (fail let-bound) - (lambda (sf bv) - #`(begin - #,@(map (lambda (bind) - (let ((binding-name (get-bind-val (car bind) bind-map)) - (exp-to-bind - (subst-bindings (cdr bind) let-bound))) - (if last-test - #`(set! #,binding-name - (cons #,exp-to-bind #,binding-name)) - #`(set! #,binding-name - #,exp-to-bind)))) - bv) - #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 cert) - (let/cc out - (next-outer - pat-syntax - (quote-syntax dummy) - '() - '() - '() - (lambda (sf bv) #'(dummy-symbol)) - (lambda (sf bv) (out (map car bv))) - cert))) - - ;; end getbindings@ - )) + (define-unit getbindings@ + (import render-test-list^) + (export getbindings^) + + ;;!(function next-outer + ;; (form (next-outer p ae sf bv let-bound kf ks syntax bool) + ;; -> + ;; syntax) + ;; (contract (syntax syntax list list list (list list -> syntax) + ;; (list list -> syntax) syntax bool) + ;; -> + ;; syntax)) + ;; The function next-outer is basically a throw-back to the next + ;; function of the original match compiler. It compiles a pattern + ;; or sub-pattern of a clause and does not yield a list of + ;; partially compiled test structs. This function is called + ;; inside of test constructs that cannot be eliminated because of + ;; a related presence in the test-so-far list. So, instead of + ;; partially compiling patterns this function fully compiles patterns. + (define/opt (next-outer + p + ae ;; this is the actual expression + sf + bv + let-bound + kf + ks + cert + [stx (syntax '())]) + (next-outer-helper p ae sf bv let-bound + (lambda (x) kf) (lambda (a b) ks) cert stx)) + + ;;!(function next-outer-helper + ;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool) + ;; -> + ;; syntax) + ;; (contract (syntax syntax list list list (list list -> syntax) + ;; (list list -> syntax) syntax bool) + ;; -> + ;; syntax)) + ;; The function next-outer-helper contains the meat of next-outer + ;; and allows the programmer to pass higher order functions + ;; ks-func and kf-func that will be given compile time imformation + ;; about let-bindings etc. which in turn will allow the programmer + ;; to take advantage of this info. + (define/opt (next-outer-helper + p + ae ;; this is the actual expression + sf + bv + let-bound + kf-func + ks-func + cert + [stx (syntax '())]) + ;; right now this does not bind new variables + (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) + ((couple-tests rendered-list ks-func kf-func let-bound) sf bv))) + + ;;!(function create-test-func + ;; (form (create-test-func p sf let-bound bind-map last-test) + ;; -> + ;; syntax) + ;; (contract (syntax list list a-list bool) -> syntax)) + ;; This function creates a runtime function that is used as an + ;; individual test in a list of tests for the list-no-order + ;; pattern. + ;; 
+    ;; 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 cert) + #`(lambda (exp) + #,(next-outer-helper + p #'exp sf '() let-bound + (lambda (let-bound) + (lambda (sf bv) + #'#f)) + (lambda (fail let-bound) + (lambda (sf bv) + #`(begin + #,@(map (lambda (bind) + (let ((binding-name (get-bind-val (car bind) bind-map)) + (exp-to-bind + (subst-bindings (cdr bind) let-bound))) + (if last-test + #`(set! #,binding-name + (cons #,exp-to-bind #,binding-name)) + #`(set! #,binding-name + #,exp-to-bind)))) + bv) + #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 cert) + (let/cc out + (next-outer + pat-syntax + (quote-syntax dummy) + '() + '() + '() + (lambda (sf bv) #'(dummy-symbol)) + (lambda (sf bv) (out (map car bv))) + cert))) + + ;; end getbindings@ + ) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/render-sigs.ss b/collects/mzlib/private/match/render-sigs.ss index a4264750cd..1792869207 100644 --- a/collects/mzlib/private/match/render-sigs.ss +++ b/collects/mzlib/private/match/render-sigs.ss @@ -1,5 +1,5 @@ (module render-sigs mzscheme - (require (lib "unitsig.ss")) + (require (lib "unit.ss")) (provide (all-defined)) diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index 3a8759b99a..da9ce4d084 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -14,7 +14,7 @@ "render-helpers.ss") (require "render-sigs.ss" - (lib "unitsig.ss")) + (lib "unit.ss")) (require-for-syntax "match-helper.ss" "match-expander-struct.ss" @@ -30,291 +30,292 @@ - (define render-test-list@ - (unit/sig render-test-list^ (import ddk-handlers^ getbindings^) - - ;; some convenient syntax for make-reg-test and make-shape-test - (define make-test-gen - (case-lambda - [(constructor test ae emitter) (make-test-gen constructor test ae emitter ae)] - [(constructor test ae emitter ae2) - (constructor test ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (emit emitter ae2 let-bound sf bv kf ks))))])) - - (define (reg-test . args) (apply make-test-gen make-reg-test args)) - (define (shape-test . args) (apply make-test-gen make-shape-test args)) - - ;; produce a matcher for the empty list - (define (emit-null ae) - (list (reg-test `(null? ,(syntax-object->datum ae)) - ae (lambda (exp) #`(null? #,exp))))) - - ;; generic helper for producing set/get matchers - (define-syntax (set/get-matcher stx) - (syntax-case stx (set! get!) - [(_ set!/get! ae p arg set/get-func) #`(set/get-matcher set!/get! ae p let-bound arg set/get-func)] - [(_ set!/get! ae p let-bound arg set/get-func) - (with-syntax ([sym (syntax-case #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])]) - #`(syntax-case arg () - [(ident) - (identifier? #'ident) - (list (make-act - sym + (define-unit render-test-list@ + (import ddk-handlers^ getbindings^) + (export render-test-list^) + + ;; some convenient syntax for make-reg-test and make-shape-test + (define make-test-gen + (case-lambda + [(constructor test ae emitter) (make-test-gen constructor test ae emitter ae)] + [(constructor test ae emitter ae2) + (constructor test ae + (lambda (ks kf let-bound) + (lambda (sf bv) + (emit emitter ae2 let-bound sf bv kf ks))))])) + + (define (reg-test . args) (apply make-test-gen make-reg-test args)) + (define (shape-test . args) (apply make-test-gen make-shape-test args)) + + ;; produce a matcher for the empty list + (define (emit-null ae) + (list (reg-test `(null? ,(syntax-object->datum ae)) + ae (lambda (exp) #`(null? #,exp))))) + + ;; generic helper for producing set/get matchers + (define-syntax (set/get-matcher stx) + (syntax-case stx (set! get!) + [(_ set!/get! ae p arg set/get-func) #`(set/get-matcher set!/get! ae p let-bound arg set/get-func)] + [(_ set!/get! ae p let-bound arg set/get-func) + (with-syntax ([sym (syntax-case #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])]) + #`(syntax-case arg () + [(ident) + (identifier? #'ident) + (list (make-act + sym + ae + (lambda (ks kf let-bound) + (lambda (sf bv) + (ks sf (cons (cons #'ident + set/get-func) + bv))))))] + [() (match:syntax-err p + (format "there should be an identifier after ~a in pattern" set!/get!))] + [(_) (match:syntax-err p + (format " ~a followed by something that is not an identifier" set!/get!))] + [(_ (... ...)) + (match:syntax-err p + (format "there should be only one identifier after ~a in pattern" set!/get!))] + [_ (match:syntax-err p + (format "invalid ~a pattern syntax" set!/get!))]))])) + + + ;; expand the regexp-matcher into an (and) with string? + (define (regexp-matcher ae stx pred cert) + (render-test-list #`(and (? string?) #,pred) ae cert stx)) + + + ;;!(function or-gen + ;; (form (or-gen exp orpatlist sf bv ks kf let-bound) + ;; -> + ;; syntax) + ;; (contract (syntax list list list (list list -> syntax) + ;; (list list -> syntax) list) + ;; -> + ;; syntax)) + ;; The function or-gen is very similar to the function gen except + ;; that it is called when an or pattern is compiled. An or + ;; pattern is essentially the same as a match pattern with several + ;; clauses. The key differences are that it exists within a + ;; 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 cert stx) + (define rendered-list + (map + (lambda (pat) + (cons (render-test-list pat exp cert stx) + (lambda (fail let-bound) + (lambda (sf bv) + (let ((bv (map + (lambda (bind) + (cons (car bind) + (subst-bindings (cdr bind) + let-bound))) + bv))) + (ks sf bv)))))) + orpatlist)) + (update-counts rendered-list) + (update-binding-counts rendered-list) + ((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv)) + + + ;;!(function render-test-list + ;; (form (render-test-list p ae stx) -> test-list) + ;; (contract (syntax syntax syntax) -> list)) + ;; This is the most important function of the entire compiler. + ;; This is where the functionality of each pattern is implemented. + ;; This function maps out how each pattern is compiled. While it + ;; only returns a list of tests, the comp field of those tests + ;; contains a function which inturn knows enough to compile the + ;; pattern. + ;;

This is implemented in what Wright terms as mock-continuation-passing + ;; style. The functions that create the syntax for a match success and failure + ;; are passed forward + ;; but they are always called in emit. This is extremely effective for + ;; handling the different structures that are matched. This way we can + ;; specify ahead of time how the rest of the elements of a list or vector + ;; should be handled. Otherwise we would have to pass more information + ;; 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 cert [stx #'here]) + (define ae-datum (syntax-object->datum ae)) + (syntax-case* + p + (_ list quote quasiquote vector box ? app and or not struct set! var + list-rest get! ... ___ unquote unquote-splicing cons + list-no-order hash-table regexp pregexp cons) stx-equal? + + ;; this is how we extend match + [(expander args ...) + (and (identifier? #'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.") + (let ([introducer (make-syntax-introducer)] + [certifier (match-expander-certifier expander)]) + (render-test-list + (introducer (transformer (introducer p))) + ae + (lambda (id) + (certifier (cert id) #f introducer)) + stx))))] + + ;; underscore is reserved to match anything and bind nothing + (_ '()) ;(ks sf bv let-bound)) + + ;; for variable patterns, we do bindings, and check if we've seen this variable before + ((var pt) + (identifier? (syntax pt)) + (list (make-act `bind-var-pat ae (lambda (ks kf let-bound) - (lambda (sf bv) - (ks sf (cons (cons #'ident - set/get-func) - bv))))))] - [() (match:syntax-err p - (format "there should be an identifier after ~a in pattern" set!/get!))] - [(_) (match:syntax-err p - (format " ~a followed by something that is not an identifier" set!/get!))] - [(_ (... ...)) - (match:syntax-err p - (format "there should be only one identifier after ~a in pattern" set!/get!))] - [_ (match:syntax-err p - (format "invalid ~a pattern syntax" set!/get!))]))])) - - - ;; expand the regexp-matcher into an (and) with string? - (define (regexp-matcher ae stx pred cert) - (render-test-list #`(and (? string?) #,pred) ae cert stx)) - - - ;;!(function or-gen - ;; (form (or-gen exp orpatlist sf bv ks kf let-bound) - ;; -> - ;; syntax) - ;; (contract (syntax list list list (list list -> syntax) - ;; (list list -> syntax) list) - ;; -> - ;; syntax)) - ;; The function or-gen is very similar to the function gen except - ;; that it is called when an or pattern is compiled. An or - ;; pattern is essentially the same as a match pattern with several - ;; clauses. The key differences are that it exists within a - ;; 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 cert stx) - (define rendered-list - (map - (lambda (pat) - (cons (render-test-list pat exp cert stx) - (lambda (fail let-bound) - (lambda (sf bv) - (let ((bv (map - (lambda (bind) - (cons (car bind) - (subst-bindings (cdr bind) - let-bound))) - bv))) - (ks sf bv)))))) - orpatlist)) - (update-counts rendered-list) - (update-binding-counts rendered-list) - ((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv)) - - - ;;!(function render-test-list - ;; (form (render-test-list p ae stx) -> test-list) - ;; (contract (syntax syntax syntax) -> list)) - ;; This is the most important function of the entire compiler. - ;; This is where the functionality of each pattern is implemented. - ;; This function maps out how each pattern is compiled. While it - ;; only returns a list of tests, the comp field of those tests - ;; contains a function which inturn knows enough to compile the - ;; pattern. - ;;

This is implemented in what Wright terms as mock-continuation-passing - ;; style. The functions that create the syntax for a match success and failure - ;; are passed forward - ;; but they are always called in emit. This is extremely effective for - ;; handling the different structures that are matched. This way we can - ;; specify ahead of time how the rest of the elements of a list or vector - ;; should be handled. Otherwise we would have to pass more information - ;; 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 cert [stx #'here]) - (define ae-datum (syntax-object->datum ae)) - (syntax-case* - p - (_ list quote quasiquote vector box ? app and or not struct set! var - list-rest get! ... ___ unquote unquote-splicing cons - list-no-order hash-table regexp pregexp cons) stx-equal? - - ;; this is how we extend match - [(expander args ...) - (and (identifier? #'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.") - (let ([introducer (make-syntax-introducer)] - [certifier (match-expander-certifier expander)]) - (render-test-list - (introducer (transformer (introducer p))) - ae - (lambda (id) - (certifier (cert id) #f introducer)) - stx))))] - - ;; underscore is reserved to match anything and bind nothing - (_ '()) ;(ks sf bv let-bound)) - - ;; for variable patterns, we do bindings, and check if we've seen this variable before - ((var pt) - (identifier? (syntax pt)) - (list (make-act `bind-var-pat - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (cond [(ormap (lambda (x) - (if (bound-identifier=? #'pt (car x)) - (cdr x) - #f)) - bv) - => (lambda (bound-exp) - (emit (lambda (exp) - #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound))) - ae - let-bound - sf bv kf ks))] - [else - (ks sf (cons (cons (syntax pt) ae) bv))])))))) - - ;; Recognize the empty list - ((list) (emit-null ae)) - - ;; This recognizes constants such strings - [pt - (constant-data? (syntax-e #'pt)) - (list - (reg-test - `(equal? ,ae-datum - ,(syntax-object->datum (syntax pt))) - ae (lambda (exp) #`(equal? #,exp pt))))] - - ;(pt - ; (stx-? regexp? (syntax pt)) - ; (render-test-list (syntax/loc p (regex pt)) ae stx)) - - ;; match a quoted datum - ;; this is very similar to the previous pattern, except for the second argument to equal? - [(quote item) - (list - (reg-test - `(equal? ,ae-datum - ,(syntax-object->datum p)) - ae (lambda (exp) #`(equal? #,exp #,p))))] - - ;; check for predicate patterns - ;; could we check to see if a predicate is a procedure here? - [(? pred?) - (list (reg-test - `(,(syntax-object->datum #'pred?) - ,ae-datum) - ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))] - - ;; app patterns just apply their operation. - ((app op pat) - (render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) - - [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx)) - (syntax->list #'pats))] - - ((or . pats) - (list (make-act - 'or-pat ;`(or-pat ,ae-datum) - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (or-gen ae (syntax-e #'pats) - sf bv ks kf let-bound - cert stx)))))) - - - ((not pat) - (list (make-act - 'not-pat ;`(not-pat ,ae-datum) - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - ;; swap success and fail - (next-outer #'pat ae sf bv let-bound ks kf cert)))))) - - ;; 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 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 ...))) - cert)) - (bind-map - (map (lambda (x) - (cons x #`#,(gensym (syntax-object->datum x)))) - bound))) - - (list - (shape-test - `(list? ,ae-datum) - ae (lambda (exp) #`(list? #,exp))) - (make-act - 'list-no-order - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (let ((last-test - (if ddk - (let ((pl (cdr (reverse pat-list)))) - (begin - (set! pat-list (reverse (cdr pl))) - (create-test-func (car pl) - sf - let-bound - bind-map - #t - cert))) - #f))) - #`(let #,(map (lambda (b) - #`(#,(cdr b) '())) - bind-map) - (let ((last-test #,last-test) - (test-list - (list - #,@(map (lambda (p) - (create-test-func - p - sf - let-bound - bind-map - #f - cert)) - pat-list)))) - (if (match:test-no-order test-list - #,ae - last-test - #,ddk) - #,(ks sf (append bind-map bv)) - #,(kf sf bv)))))))))) - (match:syntax-err - p - (string-append "dot dot k can only appear at " - "the end of unordered match patterns")))))) - - ((hash-table pats ...) - ;; must check the structure - #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) + (lambda (sf bv) + (cond [(ormap (lambda (x) + (if (bound-identifier=? #'pt (car x)) + (cdr x) + #f)) + bv) + => (lambda (bound-exp) + (emit (lambda (exp) + #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound))) + ae + let-bound + sf bv kf ks))] + [else + (ks sf (cons (cons (syntax pt) ae) bv))])))))) + + ;; Recognize the empty list + ((list) (emit-null ae)) + + ;; This recognizes constants such strings + [pt + (constant-data? (syntax-e #'pt)) + (list + (reg-test + `(equal? ,ae-datum + ,(syntax-object->datum (syntax pt))) + ae (lambda (exp) #`(equal? #,exp pt))))] + + ;(pt + ; (stx-? regexp? (syntax pt)) + ; (render-test-list (syntax/loc p (regex pt)) ae stx)) + + ;; match a quoted datum + ;; this is very similar to the previous pattern, except for the second argument to equal? + [(quote item) + (list + (reg-test + `(equal? ,ae-datum + ,(syntax-object->datum p)) + ae (lambda (exp) #`(equal? #,exp #,p))))] + + ;; check for predicate patterns + ;; could we check to see if a predicate is a procedure here? + [(? pred?) + (list (reg-test + `(,(syntax-object->datum #'pred?) + ,ae-datum) + ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))] + + ;; app patterns just apply their operation. + ((app op pat) + (render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) + + [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx)) + (syntax->list #'pats))] + + ((or . pats) + (list (make-act + 'or-pat ;`(or-pat ,ae-datum) + ae + (lambda (ks kf let-bound) + (lambda (sf bv) + (or-gen ae (syntax-e #'pats) + sf bv ks kf let-bound + cert stx)))))) + + + ((not pat) + (list (make-act + 'not-pat ;`(not-pat ,ae-datum) + ae + (lambda (ks kf let-bound) + (lambda (sf bv) + ;; swap success and fail + (next-outer #'pat ae sf bv let-bound ks kf cert)))))) + + ;; 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 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 ...))) + cert)) + (bind-map + (map (lambda (x) + (cons x #`#,(gensym (syntax-object->datum x)))) + bound))) + + (list + (shape-test + `(list? ,ae-datum) + ae (lambda (exp) #`(list? #,exp))) + (make-act + 'list-no-order + ae + (lambda (ks kf let-bound) + (lambda (sf bv) + (let ((last-test + (if ddk + (let ((pl (cdr (reverse pat-list)))) + (begin + (set! pat-list (reverse (cdr pl))) + (create-test-func (car pl) + sf + let-bound + bind-map + #t + cert))) + #f))) + #`(let #,(map (lambda (b) + #`(#,(cdr b) '())) + bind-map) + (let ((last-test #,last-test) + (test-list + (list + #,@(map (lambda (p) + (create-test-func + p + sf + let-bound + bind-map + #f + cert)) + pat-list)))) + (if (match:test-no-order test-list + #,ae + last-test + #,ddk) + #,(ks sf (append bind-map bv)) + #,(kf sf bv)))))))))) + (match:syntax-err + p + (string-append "dot dot k can only appear at " + "the end of unordered match patterns")))))) + + ((hash-table pats ...) + ;; must check the structure + #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) (list (shape-test `(hash-table? ,ae-datum) @@ -350,262 +351,262 @@ kf ks cert))))))))) - - ((struct struct-name (fields ...)) - (identifier? (syntax struct-name)) - (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))] - [(num-of-fields) (length field-pats)] - [(pred accessors mutators parental-chain) - (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) - (match:syntax-err - p - (string-append - (if (> dif 0) "not enough " "too many ") - "fields for structure in pattern"))) - (cons - (shape-test - `(struct-pred ,(syntax-object->datum pred) - ,(map syntax-object->datum parental-chain) - ,ae-datum) - ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp))) - (map-append - (lambda (cur-pat cur-mutator cur-accessor) - (syntax-case cur-pat (set! get!) - [(set! . rest) - (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) - (set/get-matcher 'set! ae p #'rest - #`(lambda (y) - (#,cur-mutator #,ae y)))] - [(get! . rest) - (set/get-matcher 'get! ae p #'rest - #`(lambda () - (#,cur-accessor #,ae)))] - [_ (render-test-list - cur-pat - (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) - cert - stx)])) - field-pats mutators accessors)))) - - ;; syntax checking - ((struct ident ...) - (match:syntax-err - p - (if (zero? (length (syntax-e (syntax (ident ...))))) - (format "~a~n~a~n~a" - "a structure pattern must have the name " - "of a defined structure followed by a list of patterns " - "to match each field of that structure") - "syntax error in structure pattern"))) - ;; use a helper macro to match set/get patterns. - ;; we give it the whole rest so that it can do error-checking and reporting - [(set! . rest) - (set/get-matcher 'set! ae p let-bound (syntax rest) - (setter ae p let-bound))] - [(get! . rest) - (set/get-matcher 'get! ae p let-bound (syntax rest) - (getter ae p let-bound))] - - ;; list pattern with ooo or ook - ((list pat dot-dot-k pat-rest ...) - (and (not (or (memq (syntax-e (syntax pat)) - '(unquote unquote-splicing ... ___)) - (stx-dot-dot-k? (syntax pat)))) - (stx-dot-dot-k? (syntax dot-dot-k))) - (list + + ((struct struct-name (fields ...)) + (identifier? (syntax struct-name)) + (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))] + [(num-of-fields) (length field-pats)] + [(pred accessors mutators parental-chain) + (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) + (match:syntax-err + p + (string-append + (if (> dif 0) "not enough " "too many ") + "fields for structure in pattern"))) + (cons (shape-test - `(list? ,ae-datum) - ae (lambda (exp) #`(list? #,exp))) - (make-act - 'list-ddk-pat - ae - (lambda (ks kf let-bound) - (if (stx-null? (syntax (pat-rest ...))) - (handle-end-ddk-list ae kf ks + `(struct-pred ,(syntax-object->datum pred) + ,(map syntax-object->datum parental-chain) + ,ae-datum) + ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp))) + (map-append + (lambda (cur-pat cur-mutator cur-accessor) + (syntax-case cur-pat (set! get!) + [(set! . rest) + (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) + (set/get-matcher 'set! ae p #'rest + #`(lambda (y) + (#,cur-mutator #,ae y)))] + [(get! . rest) + (set/get-matcher 'get! ae p #'rest + #`(lambda () + (#,cur-accessor #,ae)))] + [_ (render-test-list + cur-pat + (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) + cert + stx)])) + field-pats mutators accessors)))) + + ;; syntax checking + ((struct ident ...) + (match:syntax-err + p + (if (zero? (length (syntax-e (syntax (ident ...))))) + (format "~a~n~a~n~a" + "a structure pattern must have the name " + "of a defined structure followed by a list of patterns " + "to match each field of that structure") + "syntax error in structure pattern"))) + ;; use a helper macro to match set/get patterns. + ;; we give it the whole rest so that it can do error-checking and reporting + [(set! . rest) + (set/get-matcher 'set! ae p let-bound (syntax rest) + (setter ae p let-bound))] + [(get! . rest) + (set/get-matcher 'get! ae p let-bound (syntax rest) + (getter ae p let-bound))] + + ;; list pattern with ooo or ook + ((list pat dot-dot-k pat-rest ...) + (and (not (or (memq (syntax-e (syntax pat)) + '(unquote unquote-splicing ... ___)) + (stx-dot-dot-k? (syntax pat)))) + (stx-dot-dot-k? (syntax dot-dot-k))) + (list + (shape-test + `(list? ,ae-datum) + ae (lambda (exp) #`(list? #,exp))) + (make-act + 'list-ddk-pat + ae + (lambda (ks kf let-bound) + (if (stx-null? (syntax (pat-rest ...))) + (handle-end-ddk-list ae kf ks + (syntax pat) + (syntax dot-dot-k) + 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 - cert) - (handle-inner-ddk-list ae kf ks - (syntax pat) - (syntax dot-dot-k) - (append-if-necc 'list - (syntax (pat-rest ...))) - let-bound - cert)))))) - - ;; list-rest pattern with a ooo or ook pattern - ((list-rest pat dot-dot-k pat-rest ...) - (and (not (or (memq (syntax-e (syntax pat)) - '(unquote unquote-splicing ... ___)) - (stx-dot-dot-k? (syntax pat)) - (stx-null? (syntax (pat-rest ...))))) - (stx-dot-dot-k? (syntax dot-dot-k))) - (list + cert)))))) + + ;; list-rest pattern with a ooo or ook pattern + ((list-rest pat dot-dot-k pat-rest ...) + (and (not (or (memq (syntax-e (syntax pat)) + '(unquote unquote-splicing ... ___)) + (stx-dot-dot-k? (syntax pat)) + (stx-null? (syntax (pat-rest ...))))) + (stx-dot-dot-k? (syntax dot-dot-k))) + (list + (shape-test + `(pair? ,ae-datum) + ae (lambda (exp) #`(pair? #,exp))) + (make-act + 'list-ddk-pat + ae + (lambda (ks kf let-bound) + (handle-inner-ddk-list + ae kf ks + (syntax pat) + (syntax dot-dot-k) + (if (= 1 (length + (syntax->list (syntax (pat-rest ...))))) + (stx-car (syntax (pat-rest ...))) + (append-if-necc 'list-rest + (syntax (pat-rest ...)))) + let-bound + cert))))) + + ;; list-rest pattern for improper lists + ;; handle proper and improper lists + ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...) + (not (or (memq (syntax-e (syntax car-pat)) + '(unquote unquote-splicing)) + (stx-dot-dot-k? (syntax car-pat)))) + (cons + (shape-test + `(pair? ,ae-datum) + ae (lambda (exp) #`(pair? #,exp))) + (append + (render-test-list (syntax car-pat) + (quasisyntax/loc (syntax car-pat) (car #,ae)) + cert + stx) ;(add-a e) + (render-test-list + (syntax cdr-pat) + #`(cdr #,ae) + cert + stx)))) + + ;; list-rest pattern + ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) + (not (or (memq (syntax-e (syntax car-pat)) + '(unquote unquote-splicing)) + (stx-dot-dot-k? (syntax car-pat)))) + (cons + (shape-test + `(pair? ,ae-datum) + ae (lambda (exp) #`(pair? #,exp))) + (append + (render-test-list (syntax car-pat) + #`(car #,ae) + cert + stx) ;(add-a e) + (render-test-list + (append-if-necc 'list-rest (syntax (cdr-pat ...))) + #`(cdr #,ae) + cert + stx)))) + + ;; general list pattern + ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) + (not (or (memq (syntax-e (syntax car-pat)) + '(unquote unquote-splicing)) + (stx-dot-dot-k? (syntax car-pat)))) + (cons + (shape-test + `(pair? ,ae-datum) + ae (lambda (exp) #`(pair? #,exp))) + (append + (render-test-list (syntax car-pat) + #`(car #,ae) + cert + stx) ;(add-a e) + (if (stx-null? (syntax (cdr-pat ...))) + (list + (shape-test + `(null? (cdr ,ae-datum)) + ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae))) + (render-test-list + (append-if-necc 'list (syntax (cdr-pat ...))) + #`(cdr #,ae) + cert + stx))))) + + ;; vector pattern with ooo or ook at end + ((vector pats ...) + (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...)))) + (list + (shape-test + `(vector? ,ae-datum) + ae (lambda (exp) #`(vector? #,exp))) + (make-act + 'vec-ddk-pat + ae + (lambda (ks kf let-bound) + (handle-ddk-vector ae kf ks + #'#(pats ...) + let-bound + cert))))) + + ;; vector pattern with ooo or ook, but not at end + [(vector pats ...) + (let* ((temp (syntax-e (syntax (pats ...)))) + (len (length temp))) + (and (>= len 2) + (ddk-in-list? temp))) + ;; make this contains ddk with no ddks consecutive + ;;(stx-dot-dot-k? (vector-ref temp (sub1 len)))))) + (list + (shape-test + `(vector? ,ae-datum) + ae (lambda (exp) #`(vector? #,exp))) + ;; we have to look at the first pattern and see if a ddk follows it + ;; if so handle that case else handle the pattern + (make-act + 'vec-ddk-pat + ae + (lambda (ks kf let-bound) + (handle-ddk-vector-inner ae kf ks + #'#(pats ...) + let-bound + cert))))] + + ;; plain old vector pattern + [(vector pats ...) + (let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))] + [vlen (vector-length syntax-vec)]) + (list* (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (make-act - 'list-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-inner-ddk-list - ae kf ks - (syntax pat) - (syntax dot-dot-k) - (if (= 1 (length - (syntax->list (syntax (pat-rest ...))))) - (stx-car (syntax (pat-rest ...))) - (append-if-necc 'list-rest - (syntax (pat-rest ...)))) - let-bound - cert))))) - - ;; list-rest pattern for improper lists - ;; handle proper and improper lists - ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons + `(vector? ,ae-datum) ae + (lambda (exp) #`(vector? #,exp))) (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - (quasisyntax/loc (syntax car-pat) (car #,ae)) - cert - stx) ;(add-a e) - (render-test-list - (syntax cdr-pat) - #`(cdr #,ae) - cert - stx)))) - - ;; list-rest pattern - ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - #`(car #,ae) - cert - stx) ;(add-a e) - (render-test-list - (append-if-necc 'list-rest (syntax (cdr-pat ...))) - #`(cdr #,ae) - cert - stx)))) - - ;; general list pattern - ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - #`(car #,ae) - cert - stx) ;(add-a e) - (if (stx-null? (syntax (cdr-pat ...))) - (list - (shape-test - `(null? (cdr ,ae-datum)) - ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae))) - (render-test-list - (append-if-necc 'list (syntax (cdr-pat ...))) - #`(cdr #,ae) - cert - stx))))) - - ;; vector pattern with ooo or ook at end - ((vector pats ...) - (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...)))) - (list - (shape-test - `(vector? ,ae-datum) - ae (lambda (exp) #`(vector? #,exp))) - (make-act - 'vec-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-ddk-vector ae kf ks - #'#(pats ...) - let-bound - cert))))) - - ;; vector pattern with ooo or ook, but not at end - [(vector pats ...) - (let* ((temp (syntax-e (syntax (pats ...)))) - (len (length temp))) - (and (>= len 2) - (ddk-in-list? temp))) - ;; make this contains ddk with no ddks consecutive - ;;(stx-dot-dot-k? (vector-ref temp (sub1 len)))))) - (list - (shape-test - `(vector? ,ae-datum) - ae (lambda (exp) #`(vector? #,exp))) - ;; we have to look at the first pattern and see if a ddk follows it - ;; if so handle that case else handle the pattern - (make-act - 'vec-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-ddk-vector-inner ae kf ks - #'#(pats ...) - let-bound - cert))))] - - ;; plain old vector pattern - [(vector pats ...) - (let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))] - [vlen (vector-length syntax-vec)]) - (list* - (shape-test - `(vector? ,ae-datum) ae - (lambda (exp) #`(vector? #,exp))) - (shape-test - `(equal? (vector-length ,ae-datum) ,vlen) - ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen))) - (let vloop ((n 0)) - (if (= n vlen) - '() - (append - (render-test-list - (vector-ref syntax-vec n) - #`(vector-ref #,ae #,n) - cert - stx) - (vloop (+ 1 n)))))))] - - [(box pat) - (cons - (shape-test - `(box? ,ae-datum) - ae (lambda (exp) #`(box? #,exp))) - (render-test-list - #'pat #`(unbox #,ae) cert stx))] - - ;; This pattern wasn't a valid form. - [got-too-far - (match:syntax-err - #'got-too-far - "syntax error in pattern")])) - - ;; end of render-test-list@ - )) + `(equal? (vector-length ,ae-datum) ,vlen) + ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen))) + (let vloop ((n 0)) + (if (= n vlen) + '() + (append + (render-test-list + (vector-ref syntax-vec n) + #`(vector-ref #,ae #,n) + cert + stx) + (vloop (+ 1 n)))))))] + + [(box pat) + (cons + (shape-test + `(box? ,ae-datum) + ae (lambda (exp) #`(box? #,exp))) + (render-test-list + #'pat #`(unbox #,ae) cert stx))] + + ;; This pattern wasn't a valid form. + [got-too-far + (match:syntax-err + #'got-too-far + "syntax error in pattern")])) + + ;; end of render-test-list@ + ) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/render-test-list.scm b/collects/mzlib/private/match/render-test-list.scm index 3c86fc5c5f..0d964424ee 100644 --- a/collects/mzlib/private/match/render-test-list.scm +++ b/collects/mzlib/private/match/render-test-list.scm @@ -7,18 +7,13 @@ "render-test-list-impl.ss" "getbindings.ss" "ddk-handlers.ss" - (lib "unitsig.ss")) + (lib "unit.ss")) - (define rtl@ - (compound-unit/sig - (import) - (link (RTL : render-test-list^ (render-test-list@ DDK GET)) - (GET : getbindings^ (getbindings@ RTL)) - (DDK : ddk-handlers^ (ddk-handlers@ GET RTL)) - ) - (export (var (RTL render-test-list))) - )) - - (define-values/invoke-unit/sig render-test-list^ rtl@) + (define-compound-unit/infer rtl@ + (import) + (export render-test-list^) + (link render-test-list@ getbindings@ ddk-handlers@)) + (define-values/invoke-unit/infer rtl@) + ) \ No newline at end of file