From d1fe9f9645c5e89c893addd261dbf6109cac4c9b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 30 Aug 2006 19:41:47 +0000 Subject: [PATCH] Rewrite emit and assem to use better style. Remove pointless optional arguments in getbindings. Don't create unneccessary match-lambda*. Implement keyword arguments to define-match-expander. Lots of refactoring of gen-match for general clarity. Use combinators instead of writing our own loops. Simplify struct info accessor. Add timing printer. Refactor coupling/binding for general clarity. Rewrite logical-equal not to use the expansion of match. General replacement of () with []. svn: r4192 --- .../private/match/coupling-and-binding.scm | 140 ++++++------- collects/mzlib/private/match/emit-assm.scm | 127 ++++++------ collects/mzlib/private/match/gen-match.ss | 189 +++++++++--------- collects/mzlib/private/match/getbindings.ss | 8 +- .../mzlib/private/match/match-expander.ss | 44 ++-- collects/mzlib/private/match/match-helper.ss | 38 ++-- .../private/match/match-internal-func.ss | 2 +- collects/mzlib/private/match/parse-quasi.scm | 43 ++-- .../private/match/render-test-list-impl.ss | 18 +- .../mzlib/private/match/test-structure.scm | 4 +- .../mzlib/private/match/update-counts.scm | 30 ++- 11 files changed, 317 insertions(+), 326 deletions(-) diff --git a/collects/mzlib/private/match/coupling-and-binding.scm b/collects/mzlib/private/match/coupling-and-binding.scm index 66f42f96ab..7fb1c9f687 100644 --- a/collects/mzlib/private/match/coupling-and-binding.scm +++ b/collects/mzlib/private/match/coupling-and-binding.scm @@ -6,10 +6,17 @@ (require "test-structure.scm" "match-helper.ss" + (lib "pretty.ss") (lib "list.ss")) (require-for-template mzscheme) + ;; a structure representing bindings of portions of the matched data + ;; exp: the expression that is bound in s-exp form + ;; exp-stx: the expression that is bound in syntax form + ;; new-exp: the new symbol that will represent the expression + (define-struct binding (exp exp-stx new-exp)) + ;;!(function couple-tests ;; (form (couple-tests test-list ks-func kf-func let-bound) ;; -> @@ -27,69 +34,57 @@ ;; compilation can be completed. This returns a function that takes a ;; list of tests so far and a list of bound pattern variables. (define (couple-tests test-list ks-func kf-func let-bound) + ;(print-time "entering couple-tests") + ;(printf "test-list: ~a~n" (map test-tst test-list)) + ;(printf "test-list size: ~a~n" (length test-list)) (if (null? test-list) (ks-func (kf-func let-bound) let-bound) - (let ([cur-test (car test-list)]) - (if (and (>= (test-bind-count cur-test) 2) - (not (exp-already-bound? - (test-bind-exp cur-test) - let-bound))) ;; if it is member of - ;;let-bound skip it + (let* ([cur-test (car test-list)] + [rest-tests (cdr test-list)] + ;; this couples together the rest of the test + ;; it is passed a list of the already bound expressions + ;; only used in test/rest + [couple-rest (lambda (let-bound) + (couple-tests rest-tests + ks-func + (if (negate-test? cur-test) + (lambda (let-bound) + (lambda (sf bv) + #`(match-failure))) + kf-func) + let-bound))] + ;; this generates the current test as well as the rest of the match expression + ;; it is passed a list of the already bound expressions + [test/rest (lambda (let-bound) + ((test-comp cur-test) + (couple-rest let-bound) + (kf-func let-bound) + let-bound))]) + (if (and + ;; the expression is referenced twice + (>= (test-bind-count cur-test) 2) + ;; and it's not already bound to some variable + (not (exp-already-bound? + (test-bind-exp cur-test) + let-bound))) + ;; then generate a new binding for this expression (let* ([new-exp (get-exp-var)] - [binding (list (test-bind-exp cur-test) - (test-bind-exp-stx cur-test) - new-exp)] - [let-bound (cons binding let-bound)] - [kf (kf-func let-bound)]) - (lambda (sf bv) - #`(let ((#,new-exp - #,(sub-expr-subst (bind-get-exp-stx binding) - let-bound))) - #,(((test-comp (car test-list)) - (couple-tests (cdr test-list) - ks-func - (if (negate-test? cur-test) - (lambda (let-bound) - (lambda (sf bv) - #`(match-failure))) - kf-func) - ;kf-func - let-bound) - kf let-bound) sf bv)))) - (let* ([kf (kf-func let-bound)]) - ((test-comp (car test-list)) - (couple-tests (cdr test-list) - ks-func - (if (negate-test? cur-test) - (lambda (let-bound) - (lambda (sf bv) - #`(match-failure))) - kf-func) - ;kf-func - let-bound) - kf - let-bound)))))) - - ;;!(function bind-get-exp - ;; (form (bind-get-exp binding) -> exp) - ;; (contract binding -> exp)) - ;; This is just an accessor function for a binding. This function - ;; returns the expression that is bound in s-exp form. - (define bind-get-exp car) - - ;;!(function bind-get-exp-stx - ;; (form (bind-get-exp-stx binding) -> exp) - ;; (contract binding -> exp)) - ;; This is just an accessor function for a binding. This function - ;; returns the expression that is bound in syntax form. - (define bind-get-exp-stx cadr) - - ;;!(function bind-get-new-exp - ;; (form (bind-get-new-exp binding) -> exp) - ;; (contract binding -> exp)) - ;; This is just an accessor function for a binding. This function - ;; returns the new symbol that will represent the expression. - (define bind-get-new-exp caddr) + [binding (make-binding (test-bind-exp cur-test) + (test-bind-exp-stx cur-test) + new-exp)] + [let-bound (cons binding let-bound)]) + (with-syntax (;; the new variable + [v new-exp] + ;; the expression being bound + ;; with appropriate substitutions for the already bound portions + [expr (sub-expr-subst (binding-exp-stx binding) let-bound)]) + (lambda (sf bv) + #`(let ([v expr]) + ;; the new body, using the new binding (through let-bound) + #,((test/rest let-bound) sf bv))))) + + ;; otherwise it doesn't need a binding, and we can just do the test + (test/rest let-bound))))) ;;!(function subst-bindings ;; (form (subst-bindings exp-stx let-bound) -> syntax) @@ -102,10 +97,8 @@ ;; This function substitutes let bound variables names for the ;; expressions that they represent. (define (subst-bindings exp-stx let-bound) - (define binding (get-bind exp-stx let-bound)) - (if binding - (bind-get-new-exp binding) - (sub-expr-subst exp-stx let-bound))) + (cond [(get-bind exp-stx let-bound) => binding-new-exp] + [else (sub-expr-subst exp-stx let-bound)])) ;;!(function sub-exp-subst ;; (form (sub-exp-subst exp-stx let-bound) -> syntax) @@ -118,19 +111,20 @@ ;; This function substitutes let bound variables names for the ;; expressions that they represent. This only works if a ;; subexpression of exp-stx is bound in the let-bound list. + ;; This function assumes that all accessors are of the form + ;; (acc obj other-args ...) (such as list-ref) (define (sub-expr-subst exp-stx let-bound) (syntax-case exp-stx () [(access sub-exp rest ...) (let ([binding (get-bind #'sub-exp let-bound)]) - ;;(write (syntax sub-exp))(newline) (write binding)(newline) (if binding - #`(access #,(bind-get-new-exp binding) rest ...) + #`(access #,(binding-new-exp binding) rest ...) #`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))] [_ exp-stx])) ; helper for the following functions - (define ((equal-bind-get exp) e) - (equal? exp (bind-get-exp e))) + (define ((equal-bind-get exp) e) + (equal? exp (binding-exp e))) ;;!(function get-bind ;; (form (get-bind exp let-bound) -> binding) @@ -164,6 +158,9 @@ ;; yeilding one function that when invoked will compile the whole ;; original match expression. (define (meta-couple rendered-list failure-func let-bound bvsf) + #;(print-time "entering meta-couple") + ;(printf "rendered-list ~n") + ;(pretty-print (map (lambda (x) (map test-tst (car x))) rendered-list)) (if (null? rendered-list) failure-func ;; here we erase the previously bound variables @@ -173,11 +170,16 @@ ((meta-couple (cdr rendered-list) failure-func let-bound - bvsf) sf bvsf)))]) + bvsf) + sf bvsf)))]) (couple-tests (caar rendered-list) (cdar rendered-list) ;; successfunc needs ;; failure method failed ;; needs let-bound let-bound ;; initial-let bindings )))) ;; fail-func + + (require (lib "trace.ss")) + ;(trace meta-couple) + ;(trace couple-tests) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/emit-assm.scm b/collects/mzlib/private/match/emit-assm.scm index d83c39c050..ed5e762e3b 100644 --- a/collects/mzlib/private/match/emit-assm.scm +++ b/collects/mzlib/private/match/emit-assm.scm @@ -7,7 +7,7 @@ "coupling-and-binding.scm") (require-for-template mzscheme) - + ;;!(function emit ;; (form (emit act-test-func ae let-bound sf bv kf ks) ;; -> @@ -28,76 +28,69 @@ ;; determined to be a false property emit calls the fail function. ;; emit adds implied truths to the test seen so far list so that ;; these truths can be checked against later. - (define emit - (lambda (act-test-func ae let-bound sf bv kf ks) - (let ((test (syntax-object->datum (act-test-func ae)))) - (cond - ((in test sf) (ks sf bv)) - ((in `(not ,test) sf) (kf sf bv)) - (else - (let* ((pred (car test)) - (exp (cadr test)) - (implied (implied test)) - (not-imp - (if (equal? pred 'list?) - (list `(not (null? ,exp))) - '())) - (s (ks (cons test (append implied sf)) bv)) - (k (kf (cons `(not ,test) (append not-imp sf)) bv)) - (the-test (act-test-func (subst-bindings ae let-bound)))) - (assm (syntax-case the-test (struct-pred) - ((struct-pred pred parent-list exp) (syntax (pred exp))) - (reg (syntax reg))) - k s))))))) + (define (emit act-test-func ae let-bound sf bv kf ks) + (let ([test (syntax-object->datum (act-test-func ae))]) + (cond + [(in test sf) (ks sf bv)] + [(in `(not ,test) sf) (kf sf bv)] + [else + (let* ([pred (car test)] + [exp (cadr test)] + [implied (implied test)] + [not-imp + (if (equal? pred 'list?) + (list `(not (null? ,exp))) + '())] + [s (ks (cons test (append implied sf)) bv)] + [k (kf (cons `(not ,test) (append not-imp sf)) bv)] + [the-test (act-test-func (subst-bindings ae let-bound))]) + (assm (syntax-case the-test (struct-pred) + [(struct-pred pred parent-list exp) #'(pred exp)] + [reg #'reg]) + k s))]))) ;;!(function assm ;; (form (assm tst main-fail main-succ) -> syntax) ;; (contract (syntax syntax syntax) -> syntax)) ;; assm - this function is responsible for constructing the actual ;; if statements. It performs minor expansion optimizations. - (define assm - (lambda (tst main-fail main-succ) - (let ((s (syntax-object->datum main-succ)) - (f (syntax-object->datum main-fail))) - ;; this is for match-count - ;;(write (syntax-object->datum tst))(newline) - (node-count (add1 (node-count))) - (cond ((equal? s f) - (begin - (when (equal? s '(match-failure)) - (node-count (sub1 (node-count))) - ;(write 'here)(newline) - '() - ) - main-succ)) - ((and (eq? s #t) (eq? f #f)) tst) - (else - (syntax-case main-succ (if - and - call/ec - lambda - let) ;free-identifier=? ;stx-equal? - ((if (and tsts ...) true-act fail-act) - (equal? f (syntax-object->datum (syntax fail-act))) - (quasisyntax/loc - tst - (if (and #,tst tsts ...) true-act fail-act))) - ((if tst-prev true-act fail-act) - (equal? f (syntax-object->datum (syntax fail-act))) - (quasisyntax/loc - tst - (if (and #,tst tst-prev) true-act fail-act))) - ((call/ec - (lambda (k) (let ((fail (lambda () (_ f2)))) s2))) - (equal? f (syntax-object->datum (syntax f2))) - (quasisyntax/loc - tst - (call/ec - (lambda (k) - (let ((fail (lambda () (k #,main-fail)))) - #,(assm tst (syntax/loc tst (fail)) (syntax s2))))))) - ;; leaving out pattern that is never used in original - (_ (quasisyntax/loc - tst - (if #,tst #,main-succ #,main-fail))))))))) + (define (assm tst main-fail main-succ) + (node-count (add1 (node-count))) + (cond + [(stx-equal? main-succ main-fail) + (begin + (when (stx-equal? main-succ #'(match-failure)) + (node-count (sub1 (node-count)))) + main-succ)] + [(and (eq? (syntax-e main-succ) #t) (eq? (syntax-e main-fail) #f)) tst] + [else + (syntax-case main-succ (if + and + let/ec + lambda + let) ;free-identifier=? ;stx-equal? + [(if (and tsts ...) true-act fail-act) + (stx-equal? main-fail #'fail-act) + (quasisyntax/loc + tst + (if (and #,tst tsts ...) true-act fail-act))] + [(if tst-prev true-act fail-act) + (stx-equal? main-fail #'fail-act) + (quasisyntax/loc + tst + (if (and #,tst tst-prev) true-act fail-act))] + [(let/ec k (let ((fail (lambda () (_ f2)))) s2)) + (stx-equal? main-fail #'f2) + (begin + (error "never happens") + (printf "got here!~n") + (quasisyntax/loc + tst + (let/ec k + (let ((fail (lambda () (k #,main-fail)))) + #,(assm tst (syntax/loc tst (fail)) (syntax s2))))))] + ;; leaving out pattern that is never used in original + [_ (quasisyntax/loc + tst + (if #,tst #,main-succ #,main-fail))])])) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index f54b0721cb..25a22a12c1 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -18,6 +18,8 @@ (lib "etc.ss") "match-error.ss") + + ;;!(function mark-patlist ;; (form (mark-patlist clauses) -> marked-clause-list) ;; (contract list -> list)) @@ -74,31 +76,16 @@ (lambda (sf bv) ;; mark this pattern as reached (set-cdr! car-patlist #t) - (if fail-sym - #`(let/ec fail-cont - (let - ((failure - (lambda () - (fail-cont - ; it seems like fail is called - ; twice in this situation - #,( fail sf bv))))) - ((lambda (#,fail-sym - #,@(map car bv)) - #,@body) - failure - #,@(map (lambda (b) - (subst-bindings - (cdr b) - let-bound)) - bv)))) - #`((lambda #,(map car bv) - #,@body) - #,@(map - (lambda (b) (subst-bindings - (cdr b) - let-bound)) - bv)))) + (with-syntax ([fail-var fail-sym] + [(bound-vars ...) (map car bv)] + [(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)] + [body body]) + (if fail-sym + #`(let/ec fail-cont + (let ([fail-var (lambda () (fail-cont #,(fail sf bv)))] + [bound-vars args] ...) + . body)) + #'(let ([bound-vars args] ...) . body)))) (lambda (sf bv) ;; mark this pattern as reached (set-cdr! car-patlist #t) @@ -113,6 +100,40 @@ (define test-list (render-test-list pat exp (lambda (x) x) stx)) (cons test-list success)) + ;;!(function gen + ;; (form (gen exp tsf patlist stx failure-func opt success-func) + ;; -> + ;; syntax) + ;; (contract (syntax list list syntax + ;; (() -> void) bool (list list -> syntax)) + ;; -> + ;; syntax)) + ;; This function is primarily called by gen-help and takes the the + ;; newly marked clauses and the failure-func which is really a + ;; variable-name which will bound to the failure in the runtime + ;; code. This function then This function + ;; then takes these lists of partially compiled tests and reorders + ;; them in an attempt to reduce the size of the final compiled + ;; match expression. Binding counts are also updated to help + ;; determind which supexpressions of the expression to be matched + ;; need to be bound by let expressions. After all of this the + ;; tests are "coupled" together for final compilation. + #;(define (gen exp tsf patlist stx failure-func opt success-func) + ;; iterate through list and render each pattern to a list of tests + ;; and success functions + (define rendered-list + (map (lambda (clause) (test-list-with-success-func + exp clause stx success-func)) + patlist)) + (update-counts rendered-list) + (tag-negate-tests rendered-list) + (update-binding-counts rendered-list) + ((meta-couple (reorder-all-lists rendered-list) + (lambda (sf bv) failure-func) + '() + '()) + '() '())) + ;;!(function gen-match ;; (form (gen-match exp tsf patlist stx [success-func]) ;; -> @@ -121,10 +142,8 @@ ;; (list list -> syntax-object)) ;; -> ;; syntax-object)) - ;;

gen-match is the gateway through which match, match-lambda, - ;; match-lambda*, - ;; match-let, match-let*, match-letrec, match-define access the match - ;; expression compiler. + ;;

gen-match is the gateway through which match accesses the match + ;; pattern compiler. ;; ;;

exp - the expression that is to be tested against the pattern. ;; This should normally be a piece of syntax that indirectly @@ -150,75 +169,45 @@ ;; of the recursion tree. The success function must take two arguments ;; and it should return a syntax object. (define gen-match - (opt-lambda (exp tsf patlist stx [success-func #f]) - - ;;!(function gen-help - ;; (form (gen-help exp tsf patlist stx [success-func]) -> - ;; syntax-object) - ;; (contract (syntax-object list list syntax-object - ;; (list list -> syntax-object)) - ;; -> - ;; syntax-object)) - ;; This function does some basic house keeping before forwarding - ;; the compilation to the gen function. It sets up the list of - ;; clauses so that one can mark that they have been "reached". It - ;; also wraps the final compilation in syntax which binds the - ;; match-failure function. - (define (gen-help opt) - (when (stx-null? patlist) - (match:syntax-err stx "null clause list")) - (let* ([marked-clauses (mark-patlist patlist)] - [compiled-match - #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) - #,(gen exp tsf marked-clauses - stx - #'(match-failure) - opt - success-func))]) - (unreachable marked-clauses stx) - compiled-match)) - - - - - - ;;!(function gen - ;; (form (gen exp tsf patlist stx failure-func opt success-func) - ;; -> - ;; syntax) - ;; (contract (syntax list list syntax - ;; (() -> void) bool (list list -> syntax)) - ;; -> - ;; syntax)) - ;; This function is primarily called by gen-help and takes the the - ;; newly marked clauses and the failure-func which is really a - ;; variable-name which will bound to the failure in the runtime - ;; code. This function then makes successive calls to - ;; test-list-with-success-func which gives us a list of partially - ;; compiled tests for each clause. I say partially compiled - ;; because the test structures containa a function that needs to - ;; be coupled with the other functions of the other test - ;; structures before actual compilation results. This function - ;; then takes these lists of partially compiled tests and reorders - ;; them in an attempt to reduce the size of the final compiled - ;; match expression. Binding counts are also updated to help - ;; determind which supexpressions of the expression to be matched - ;; need to be bound by let expressions. After all of this the - ;; tests are "coupled" together for final compilation. - (define (gen exp tsf patlist stx failure-func opt success-func) - ;; iterate through list and render each pattern to a list of tests - ;; and success functions - (define rendered-list - (map (lambda (clause) (test-list-with-success-func - exp clause stx success-func)) - patlist)) - (update-counts rendered-list) - (tag-negate-tests rendered-list) - (update-binding-counts rendered-list) - ((meta-couple (reorder-all-lists rendered-list) - (lambda (sf bv) failure-func) - '() - '()) - '() '())) - (gen-help #f))) + (opt-lambda (exp tsf patlist stx [success-func #f]) + (initer) + (when (stx-null? patlist) + (match:syntax-err stx "null clause list")) + (print-time "entering gen-match") + (let* (;; We set up the list of + ;; clauses so that one can mark that they have been "reached". + [marked-clauses (mark-patlist patlist)] + [failure-func #'(match-failure)] + ;; iterate through list and render each pattern to a list of partially compiled tests + ;; and success functions. + ;; These are partially compiled + ;; because the test structures containa a function that needs to + ;; be coupled with the other functions of the other test + ;; structures before actual compilation results. + [rendered-list (map (lambda (clause) (test-list-with-success-func + exp clause stx success-func)) + marked-clauses)] + [_ (begin + (print-time "finished render-list") + (update-counts rendered-list) + (tag-negate-tests rendered-list) + (update-binding-counts rendered-list))] + ;; couple the partially compiled tests together into the final result. + [compiled-exp + (begin + (print-time "starting coupling") + ((meta-couple (reorder-all-lists rendered-list) + (lambda (sf bv) failure-func) + '() + '()) + '() '()))] + ;; Also wrap the final compilation in syntax which binds the + ;; match-failure function. + [compiled-match + #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) + #,compiled-exp)]) + (print-time "finished coupling") + (unreachable marked-clauses stx) + (print-time "done") + compiled-match))) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/getbindings.ss b/collects/mzlib/private/match/getbindings.ss index 03676c6540..5686d5de8b 100644 --- a/collects/mzlib/private/match/getbindings.ss +++ b/collects/mzlib/private/match/getbindings.ss @@ -36,10 +36,9 @@ kf ks cert - [stx (syntax '())] - [opt #f]) + [stx (syntax '())]) (next-outer-helper p ae sf bv let-bound - (lambda (x) kf) (lambda (a b) ks) cert stx opt)) + (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) @@ -63,8 +62,7 @@ kf-func ks-func cert - [stx (syntax '())] - [opt #f]) + [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 diff --git a/collects/mzlib/private/match/match-expander.ss b/collects/mzlib/private/match/match-expander.ss index a02c41c6cf..bfc5cf072d 100644 --- a/collects/mzlib/private/match/match-expander.ss +++ b/collects/mzlib/private/match/match-expander.ss @@ -5,11 +5,12 @@ - ;; (define-match-expander id transformer-for-plt-match - ;; [transformer-for-match] - ;; [transformer-outside-of-match]) - ;; if only three args, the third is assumed to be the transformer-outside-of-match - ;; I wish I had keyword macro args + ;; (define-match-expander id [#:plt-match transformer-for-plt-match] + ;; [#:match transformer-for-match] + ;; [#:expression transformer-outside-of-match]) + + ;; There is also a legacy syntax, as follows: + ;; (define-match-expander id transformer-for-plt-match [[transformer-for-match] transformer-outside-of-match]) (define-syntax (define-match-expander stx) (define (lookup v alist) @@ -52,37 +53,16 @@ [nm #'std-xform])) (syntax-local-certifier))) #'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform (syntax-local-certifier))))))] + + ;; implement legacy syntax [(_ id plt-match-xform match-xform std-xform) - (if (identifier? (syntax std-xform)) - #`(define-syntax id (make-match-expander plt-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])) - (syntax-local-certifier))) - #'(define-syntax id (make-match-expander plt-match-xform match-xform std-xform (syntax-local-certifier))))] + #'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)] [(_ id plt-match-xform std-xform) - (if (identifier? (syntax std-xform)) - #`(define-syntax id (make-match-expander plt-match-xform - #f - (lambda (stx) - (syntax-case stx (set!) - #;[(set! id v) #'(set! std-xform v)] - [(nm args (... ...)) #'(std-xform args (... ...))] - [nm #'std-xform])) - (syntax-local-certifier))) - #'(define-syntax id (make-match-expander plt-match-xform #f std-xform (syntax-local-certifier))))] + #'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)] [(_ 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")) - (syntax-local-certifier)))] + #'(define-match-expander id #:plt-match plt-match-xform)] + ;; error checking [_ (match:syntax-err stx "Invalid use of define-match-expander")] )) diff --git a/collects/mzlib/private/match/match-helper.ss b/collects/mzlib/private/match/match-helper.ss index fd689cbdf7..58eadf9c67 100644 --- a/collects/mzlib/private/match/match-helper.ss +++ b/collects/mzlib/private/match/match-helper.ss @@ -55,9 +55,9 @@ ;; (values pred accessors mutators parental-chain)) ;; (contract (syntax-object) ;; -> - ;; (values (any -> bool) list list))) - ;; This function takes a syntax-object that is the name of a structure - ;; as well as a failure thunk. It returns three values. The first is + ;; (values (any -> bool) list list list))) + ;; This function takes a syntax-object that is the name of a structure. + ;; It returns four values. The first is ;; a predicate for the structure. The second is a list of accessors ;; in the same order as the fields of the structure declaration. The ;; third is a list of mutators for the structure also in the same @@ -82,6 +82,8 @@ (values (reverse accs) (reverse muts)))) + ;; this produces a list of all the super-types of this struct + ;; ending when it reaches the top of the hierarchy, or a struct that we can't access (define (get-lineage struct-name) (let ([super (list-ref (local-val struct-name) @@ -89,20 +91,18 @@ (cond [(equal? super #t) '()] ;; no super type exists [(equal? super #f) '()] ;; super type is unknown [else (cons super (get-lineage super))]))) + (define info-on-struct (local-val struct-name)) - (define (get-info info-on-struct) - (let-values ([(accs muts) - (handle-acc/mut-lists - (list-ref info-on-struct accessors-index) - (list-ref info-on-struct mutators-index))]) - (values accs muts - (list-ref info-on-struct pred-index)))) + (define (ref-info i) (list-ref info-on-struct i)) (unless (struct-declaration-info? info-on-struct) (failure-thunk)) - (let-values ([(accessors mutators pred) (get-info info-on-struct)] - [(parental-chain) (get-lineage struct-name)]) + (let*-values ([(acc-list) (ref-info accessors-index)] + [(mut-list) (ref-info mutators-index)] + [(pred) (ref-info pred-index)] + [(accessors mutators) (handle-acc/mut-lists acc-list mut-list)] + [(parental-chain) (get-lineage struct-name)]) (values pred accessors mutators (cons struct-name parental-chain))) ) @@ -467,4 +467,18 @@ (define match-equality-test (make-parameter equal?)) + ;; a helper for timing testing + + (define-values (print-time initer) + (let* ((t (current-milliseconds)) + (orig t)) + (values + (lambda (msg) + (void) + #;(let ((t* (current-milliseconds))) + (printf "~a: (total: ~a real: ~a diff: ~a)~n" msg (- t* orig) t* (- t* t)) + (set! t t*))) + (lambda () (void)#;(set! t (current-milliseconds)) #;(set! orig t))))) + + ) diff --git a/collects/mzlib/private/match/match-internal-func.ss b/collects/mzlib/private/match/match-internal-func.ss index ba4b46c9c3..ac059ecd65 100644 --- a/collects/mzlib/private/match/match-internal-func.ss +++ b/collects/mzlib/private/match/match-internal-func.ss @@ -55,7 +55,7 @@ #'(letrec ([name (match-lambda* ((list pat ...) . body))]) (name exp ...))] [(_ ([pat exp] ...) . body) - #'((match-lambda* ((list pat ...) . body)) exp ...)])) + #'(match (list exp ...) [(list pat ...) . body])])) (define-syntax (match-let* stx) (syntax-case stx () diff --git a/collects/mzlib/private/match/parse-quasi.scm b/collects/mzlib/private/match/parse-quasi.scm index 6d94713ec2..a779045a8e 100644 --- a/collects/mzlib/private/match/parse-quasi.scm +++ b/collects/mzlib/private/match/parse-quasi.scm @@ -52,46 +52,47 @@ (,@pat (q-error (syntax ,@pat) "unquote-splicing not nested in list")) ((x . y) - (let* ((list-type 'list) - (result + (let* ([list-type 'list] + [result (let loop ((l (syntax-e (syntax (x . y))))) ;(write l)(newline) - (cond ((null? l) '()) - ((and (stx-pair? (car l)) + (cond [(null? l) '()] + [(and (stx-pair? (car l)) (equal? (car (syntax-object->datum (car l))) 'unquote-splicing)) - (let ((first-car + (let ([first-car (syntax-case (car l) (unquote-splicing quasiquote) - (,@`p ;; have to parse forward here + [,@`p ;; have to parse forward here (let ((pq (parse-q (syntax p)))) (if (stx-list? pq) (cdr (syntax->list pq)) (q-error (syntax ,@`p) - "unquote-splicing not followed by list")))) - (,@p - (if (stx-list? (syntax p)) + "unquote-splicing not followed by list")))] + [,@p + (if (and (stx-list? (syntax p)) + (eq? (syntax-e (car (syntax->list #'p))) 'list)) (cdr (syntax->list (syntax p))) (begin ; (write (syntax-e (syntax p))) (q-error (syntax ,@p) - "unquote-splicing not followed by list"))))))) + "unquote-splicing not followed by list")))])]) (syntax-case (cdr l) (unquote unquote-splicing) - (,@p (q-error (syntax ,@p) - "unquote-splicing can not follow dot notation")) - (,p + [,@p (q-error (syntax ,@p) + "unquote-splicing can not follow dot notation")] + [,p (let ((res (parse-q (syntax ,p)))) (set! list-type 'list-rest) - `(,@first-car ,res))) - (p (or (stx-pair? (syntax p)) + `(,@first-car ,res))] + [p (or (stx-pair? (syntax p)) (stx-null? (syntax p))) (append first-car - (loop (syntax-e (syntax p))))) - (p ;; must be an atom - (let ((res (parse-q (syntax p)))) + (loop (syntax-e (syntax p))))] + [p ;; must be an atom + (let ([res (parse-q (syntax p))]) (set! list-type 'list-rest) - `(,@first-car ,res)))))) - (else + `(,@first-car ,res))]))] + [else (syntax-case (cdr l) (unquote unquote-splicing) (,@p (q-error (syntax p) "unquote-splicing can not follow dot notation")) @@ -107,7 +108,7 @@ (begin (set! list-type 'list-rest) (list (parse-q (car l)) - (parse-q (syntax p))))))))))) + (parse-q (syntax p))))))]))]) (quasisyntax/loc stx (#,list-type #,@result)))) (p (vector? (syntax-object->datum (syntax p))) diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index 763d57fc4e..26da29af66 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -223,8 +223,7 @@ (`quasi-pat (render-test-list (parse-quasi #'quasi-pat) ae cert stx)) - - ;; check for predicate patterns + ;; check for predicate patterns ;; could we check to see if a predicate is a procedure here? ((? pred?) (list (reg-test @@ -233,8 +232,8 @@ ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) ;; predicate patterns with binders are redundant with and patterns - ((? pred? pats ...) - (render-test-list #'(and (? pred?) pats ...) ae cert stx)) + [(? pred? pats ...) + (render-test-list #'(and (? pred?) pats ...) ae cert stx)] ;; syntax checking ((? anything ...) @@ -264,15 +263,8 @@ (if (zero? (length (syntax-e #'op))) "an operation pattern must have a procedure following the app" "there should be one pattern following the operator"))) - ((and . pats) - (let loop - ((p #'pats)) - (syntax-case p () - ;; empty and always succeeds - [() '()] ;(ks seensofar boundvars let-bound)) - [(pat . rest) - (append (render-test-list #'pat ae cert stx) - (loop #'rest))]))) + [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx)) + (syntax->list #'pats))] ((or . pats) (list (make-act diff --git a/collects/mzlib/private/match/test-structure.scm b/collects/mzlib/private/match/test-structure.scm index 94a1456ad3..0d43994575 100644 --- a/collects/mzlib/private/match/test-structure.scm +++ b/collects/mzlib/private/match/test-structure.scm @@ -115,6 +115,8 @@ (define (shape-test? test) (test-shape test)) + (define (negate-test? test) - (test-closest-shape-tst test)) + (test-closest-shape-tst test)) + ) \ No newline at end of file diff --git a/collects/mzlib/private/match/update-counts.scm b/collects/mzlib/private/match/update-counts.scm index 724d42e18f..ce1b72fb26 100644 --- a/collects/mzlib/private/match/update-counts.scm +++ b/collects/mzlib/private/match/update-counts.scm @@ -5,7 +5,8 @@ (provide update-counts) (require "test-structure.scm" - "match-helper.ss") + "match-helper.ss" + (lib "list.ss")) ;;!(function test-filter ;; (form (test-filter test-list) -> test-list) @@ -13,7 +14,10 @@ ;; This function filters out tests that do not need to be to have ;; their counts updated for reordering purposes. These are the ;; more complex patterns such as or-patterns or ddk patterns. - (define test-filter + + (define (test-filter tlist) + (filter (lambda (t) (not (= -1 (test-times-used t)))) tlist)) + #;(define test-filter (lambda (tlist) (if (null? tlist) '() @@ -54,13 +58,29 @@ (logical-equal? item cur)) lst))) - (define logical-equal? + (define (logical-equal? a b) + (or (equal? a b) #t + (and + ;; error checking + (list? a) + (list? b) + (list? (cdr a)) + (list? (cdr b)) + (null? (cddr a)) + (null? (cddr b)) + ;; end error checking + (eq? (car a) 'list?) + (eq? (car b) 'null?) + (equal? (cadr a) (cadr b))))) + ;; this implements the above code + + #;(define logical-equal? (lambda x (if (pair? x) (let ((exp8163 (cdr x))) (if (and (pair? exp8163) (null? (cdr exp8163))) (if (equal? (car exp8163) (car x)) - ((lambda (a) #t) (car x)) + #t (let ((exp8164 (car x))) (if (and (pair? exp8164) (equal? (car exp8164) 'list?)) (let ((exp8165 (cdr exp8164))) @@ -167,7 +187,7 @@ (if (null? tml) '() (begin - (map (lambda (t) + (for-each (lambda (t) (set-test-times-used! t 1) (set-test-used-set! t