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. -;; -;;
exp - the expression that is to be tested against the pattern. -;; This should normally be a piece of syntax that indirectly -;; represents the expression. Because if it is the syntax of the -;; expression itself it will be duplicated many times throughout -;; the generated match test. -;; -;;
tsf - is a list of tests-seen-so-far and is used to -;; prevent generating tests for the same condition twice -;; -;;
patlist - is a list of the pattern clauses of the match expr -;; these can be of either form (pat body ...) or -;; (pat (=> fail) body ...)x -;; -;;
stx is the original syntax of the match expression. -;; This is only used for error reporting. -;; -;;
success-func - an optional argument which allows one to
-;; specify how a successful match is treated. This made
-;; the creation of match-letrec and match-define macros simple.
-;; The reason for this function is that most of the information
-;; about a match (namely the bound match variables) is at the bottom
-;; 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])
- (include "test-structure.scm")
- ;(include "coupling-and-binding-new.scm")
- (include "coupling-and-binding.scm")
- (include "render-test-list.scm")
- (include "reorder-tests.scm")
- (include "update-counts.scm")
- (include "update-binding-counts.scm")
- (include "match-util.scm")
- (include "tag-negate-tests.scm")
- ;;!(function unreachable
- ;; (form (unreachable plist match-expr) -> void)
- ;; (contract (list syntax-object) -> void)
- ;; (contract plist -> (is a list of unreached pattern clauses))
- ;; (contract match-expr -> (is the origional match expr
- ;; the clauses came from)))
- ;; This function takes a list of unreached clauses and the original
- ;; match expression and prints a warning for each of the unreached
- ;; match clauses to the current error port
- (define unreachable
- (lambda (plist match-expr)
- (map
- (lambda (x)
- (if (not (cdr x))
- (fprintf
- (current-error-port)
- "Warning: unreachable match clause ~e in ~e~n"
- (syntax-object->datum (car x))
- (syntax-object->datum match-expr))))
- plist)))
-
- ;;!(function gen-match-opt
- ;; (form (gen-match exp tsf patlist stx [success-func])
- ;; ->
- ;; compiled-pattern)
- ;; (contract (syntax-object list list syntax-object
- ;; (list list -> syntax-object))
- ;; ->
- ;; syntax-object))
- ;; This function is left over from an experiment that explored the
- ;; idea that certain "shape" tests can be ommited if the input for
- ;; a match expression is known.
- ;; For example if one knows that the the match expression is only
- ;; ever going to be applied to a list of four items. Then it
- ;; would behoove us to eliminate the extraneous tests that verify
- ;; this.
- (define gen-match-opt
- (opt-lambda (exp tsf patlist stx [success-func #f])
- (gen-help exp tsf patlist stx #t success-func)))
-
- ;;!(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-lambda (exp tsf patlist stx opt [success-func #f])
- (when
- (stx-null? patlist)
- (match:syntax-err stx "null clause list"))
- (let* ((marked-clauses (mark-patlist patlist))
- (compiled-match
- (quasisyntax/loc stx
- (let ((match-failure
- (lambda ()
- (match:error #,exp (quote #,stx)))))
- #,(gen exp tsf marked-clauses
- stx
- (syntax (match-failure))
- opt
- success-func)))))
- (unreachable marked-clauses stx)
- compiled-match)))
-
- ;;!(function mark-patlist
- ;; (form (mark-patlist clauses) -> marked-clause-list)
- ;; (contract list -> list))
- ;; This function takes each clause from the match expression and
- ;; pairs it with the dummy value #f. This value will be set! when
- ;; the pattern matcher compiles a possible successful match for
- ;; the clause. If it is not set to #t then the clause is
- ;; unreachable which is an indication of programmer error.
- (define mark-patlist
- (lambda (clauses)
- (map (lambda (x) (cons x #f)) (syntax->list clauses))))
-
- ;;!(function test-list-with-success-func
- ;; (form (test-list-with-success-func exp car-patlist
- ;; stx success-func)
- ;; ->
- ;; (test-list success-func))
- ;; (contract (syntax-object pair syntax-object
- ;; (list list -> syntax-object))
- ;; ->
- ;; (list ((list list -> syntax) list ->
- ;; (list list -> syntax)))))
- ;; This function takes an exp which is to be matched, a marked
- ;; clause, and a syntax-object that is fro reporting errors. It
- ;; returns a pair the car of which is a list of test structs which
- ;; are in essense partially evaluated tests. The cdr of the
- ;; result is a function which takes a failure function and a list
- ;; of let-bound expressions and returns a success-function.
- (define test-list-with-success-func
- (opt-lambda (exp car-patlist stx [success-func #f])
- (let ((clause1 (car car-patlist)))
- (let-values (((pat body fail-sym)
- (syntax-case clause1 (=>)
- ((pat (=> fail-sym) body1 bodys ...)
- (values (syntax pat)
- (syntax (body1 bodys ...))
- (syntax fail-sym)))
- ((pat body1 bodys ...)
- (values (syntax pat)
- (syntax (body1 bodys ...)) #f))
- ((pat) (match:syntax-err
- (syntax pat)
- "missing action for pattern"))
- (pat (match:syntax-err
- (syntax pat)
- "syntax error in clause")))))
- (let* (
- (success
- (lambda (fail let-bound)
- (if (not success-func)
- (lambda (sf bv)
- ;; mark this pattern as reached
- (set-cdr! car-patlist #t)
- (if fail-sym
- (quasisyntax/loc
- stx
- (call/ec
- (lambda (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))))))
- (quasisyntax/loc
- stx
- ((lambda #,(map car bv)
- #,@body)
- #,@(map
- (lambda (b) (subst-bindings
- (cdr b)
- let-bound))
- bv)))))
- (lambda (sf bv)
- ;; mark this pattern as reached
- (set-cdr! car-patlist #t)
- (let ((bv (map
- (lambda (bind)
- (cons (car bind)
- (subst-bindings
- (cdr bind)
- let-bound)))
- bv)))
- (success-func sf bv))))))
- (test-list (render-test-list pat exp 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 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
- (opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
- ;; iterate through list and render each pattern to a list of tests
- ;; and success functions
- (let ((rendered-list
- (let loop ((clause-list patlist))
- (if (null? clause-list)
- '()
- (cons (test-list-with-success-func exp
- (car clause-list)
- stx
- success-func)
- (loop (cdr clause-list)))))))
- (update-counts rendered-list)
- (tag-negate-tests rendered-list)
- (update-binding-counts rendered-list)
- (let* ((rendered-list (reorder-all-lists rendered-list))
- (output
- (begin
- ;(pretty-print rendered-list)(newline)
- ((meta-couple rendered-list
- (lambda (sf bv) failure-func)
- '()
- '())
- '() '()))))
- output))))
- (gen-help exp tsf patlist stx #f success-func)))
-
diff --git a/collects/mzlib/private/plt-match/match-util.scm b/collects/mzlib/private/plt-match/match-util.scm
deleted file mode 100644
index ff290a8df5..0000000000
--- a/collects/mzlib/private/plt-match/match-util.scm
+++ /dev/null
@@ -1,404 +0,0 @@
-;; This library is used by match.ss
-;
-
-;;! (function stx-length
-;; (form (syntax-length syntax-obj) -> int)
-;; (contract syntax-object -> int)
-;; (example (syntax-length (syntax iraq war idiocy)) -> 3))
-;; Returns the length of the top-level syntax list.
-(define stx-length (lambda (syntax-obj)
- (length (syntax->list syntax-obj))))
-
-;;! (function stx-?
-;; (form (stx? test val) -> bool)
-;; (contract ((any -> bool) syntax-object) -> bool)
-;; (example (stx-? number? (syntax 4)) -> #t))
-;; Applies predicate test to the syntax object val and returns the resulting
-;; boolean value.
-(define stx-? (lambda (test val)
- (test (syntax-object->datum val))))
-
-;;!(function stx-equal?
-;; (form (stx-equal? a b) -> bool)
-;; (contract (syntax-object syntax-object) -> bool)
-;; (example (stx-equal? (syntax 5) (syntax 5)) -> #t))
-;; Check the equality of two syntax objects by after applying
-;; syntax-object->datum to the objects first. Checks equaltiy of
-;; syntax objects after they have had all syntax data stripped away.
-(define stx-equal? (lambda (a b)
- (equal? (syntax-object->datum a)
- (syntax-object->datum b))))
-
-;;!(function symbol-append
-;; (form (symbol-append . args) -> symbol)
-;; (contract ((symbol or number) ...) -> symbol)
-;; (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye))
-;; This function takes any number of arguments which can be either
-;; symbols or numbers and returns one symbol which is the
-;; concatenation of the input.
-(define symbol-append (lambda l
- (string->symbol
- (apply
- string-append
- (map (lambda (x)
- (cond
- ((symbol? x) (symbol->string x))
- ((number? x) (number->string x))
- (else x)))
- l)))))
-
-;;!(function struct-pred-accessors-mutators
-;; (form (struct-pred-accessors-mutators struct-name failure-thunk)
-;; ->
-;; (values pred accessors mutators parental-chain))
-;; (contract (syntax-object (any -> void))
-;; ->
-;; (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
-;; 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
-;; order. The last is a list of supertypes of this struct. The
-;; failure thunk is invoked if the struct-name is not bound to a
-;; structure.
-(define struct-pred-accessors-mutators
- (let ((accessors-index 3)
- (mutators-index 4)
- (pred-index 2)
- (super-type-index 5)
- (handle-acc-list
- (lambda (l)
- (letrec ((RC
- (lambda (ac-list)
- (cond ((null? ac-list) '())
- ((not (car ac-list)) '())
- (else (cons (car ac-list)
- (RC (cdr ac-list))))))))
- (reverse (RC l))))))
- (lambda (struct-name failure-thunk)
- (letrec ((get-lineage
- (lambda (struct-name)
- (let ((super
- (list-ref
- (syntax-local-value struct-name
- failure-thunk)
- super-type-index)))
- (cond ((equal? super #t) '())
- ((equal? super #f) '()) ;; not sure what to do in case where super-type is unknown
- (else
- (cons super (get-lineage super))))))))
- (let ((info-on-struct (syntax-local-value struct-name failure-thunk)))
- (if (struct-declaration-info? info-on-struct)
- (let ((accessors (handle-acc-list
- (list-ref info-on-struct accessors-index)))
- (mutators (handle-acc-list
- (list-ref info-on-struct mutators-index)))
- (pred (list-ref info-on-struct pred-index))
- (parental-chain (get-lineage struct-name)))
- (values pred accessors mutators (cons struct-name parental-chain)))
- (failure-thunk)))))))
-
-
-
-
-;;!(function get-exp-var
-;; (form (get-exp-var) -> syntax)
-;; (contract () -> syntax)
-;; (example (get-exp-var) -> (syntax exp754)))
-;; This function just produces unique identifiers for expressions.
-(define get-exp-var (lambda () #`#,(gensym 'exp)))
-
-;;!(function in
-;; (form (in e l) -> bool)
-;; (contract (s-exp list) -> bool)
-;; (example (in '(number? x) (list '(number? x))) -> #t))
-;; This function is responsible for determining which tests are
-;; redundant. If e can be determined to be true from the list of
-;; tests l then e is "in" l.
-(define in (lambda (e l)
- (or
- (ormap
- (lambda (el)
- (or (equal? e el)
- (and
- (eq? (car e) 'struct-pred)
- (eq? (car el) 'struct-pred)
- (member (caaddr e) (caddr el))
- (equal? (cadddr e) (cadddr el))))) l)
- (and (eq? (car e) 'list?)
- (or (member `(null? ,(cadr e)) l)
- (member `(pair? ,(cadr e)) l)))
- (and (eq? (car e) 'not)
- (let* ((srch (cadr e))
- (const-class (equal-test? srch)))
- ;(write srch)
- (cond
- ((equal? (car srch) 'struct-pred)
- (let mem ((l l))
- (if (null? l)
- #f
- (let ((x (car l)))
- (if (and (equal? (car x)
- 'struct-pred)
- (not (equal? (cadr x) (cadr srch)))
- ; the current struct type should not
- ; be a member of the parental-chain of
- (not (member (caaddr x) (caddr srch)))
- (equal? (cadddr x) (cadddr srch)))
- #t
- (mem (cdr l)))))))
- (const-class
- (let mem ((l l))
- (if (null? l)
- #f
- (let ((x (car l)))
- (or (and (equal?
- (cadr x)
- (cadr srch))
- (disjoint? x)
- (not (equal?
- const-class
- (car x))))
- (equal?
- x
- `(not (,const-class
- ,(cadr srch))))
- (and (equal?
- (cadr x)
- (cadr srch))
- (equal-test?
- x)
- (not (equal?
- (caddr
- srch)
- (caddr
- x))))
- (mem (cdr l)))))))
- ((disjoint? srch)
- (let mem ((l l))
- (if (null? l)
- #f
- (let ((x (car l)))
- (or (and (disjoint? x)
- (not (equal?
- (car x)
- (car srch)))
- (cond ((equal?
- (car srch)
- 'struct-pred)
- (equal?
- (cadr x)
- ;; we use cadddr here to access the expression
- ;; because struct predicates carry some extra baggage
- ;; They have the form (struct-pred 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 (render-test-list p ae stx)
- (include "special-generators.scm")
- (include "ddk-handlers.scm")
- (include "getter-setter.scm")
- (include "emit-assm.scm")
- (include "parse-quasi.scm")
- (include "pattern-predicates.scm")
-
- (define (append-if-necc sym stx)
- (syntax-case stx ()
- (() (syntax (list)))
- ((a ...)
- (quasisyntax/loc stx (#,sym a ...)))
- (p (syntax p))))
- (syntax-case*
- p
- (_ list quote quasiquote vector box ? app and or not struct set! var
- list-rest get! ... ___ unquote unquote-splicing
- list-no-order hash-table regexp pregexp) stx-equal?
- (_ '()) ;(ks sf bv let-bound))
- (pt
- (and (identifier? (syntax pt))
- (pattern-var? (syntax-object->datum (syntax pt)))
- (not (stx-dot-dot-k? (syntax pt))))
- (render-test-list (syntax/loc stx (var pt)) ae stx))
- ((var pt)
- (identifier? (syntax pt))
- (list (make-act `bind-var-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (let ((raw-id (syntax-object->datum (syntax pt))))
- (cond ((ormap (lambda (x)
- (if (equal? raw-id (syntax-object->datum (car x)))
- (cdr x) #f)) bv)
- => (lambda (bound-exp)
- (emit (lambda (exp)
- (quasisyntax/loc
- p
- (equal? #,exp #,(subst-bindings bound-exp let-bound))))
- ae
- let-bound
- sf bv kf ks)))
- (else
- (ks sf (cons (cons (syntax pt) ae) bv))))))))))
-
- ((list)
- (list
- (make-reg-test
- `(null? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp)
- (quasisyntax/loc p (null? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))))
- ('()
- (list
- (make-reg-test
- `(null? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp)
- (quasisyntax/loc p (null? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks)))))
- )
-
- (pt
- ;; could convert the syntax once
- (or (stx-? string? (syntax pt))
- (stx-? boolean? (syntax pt))
- (stx-? char? (syntax pt))
- (stx-? number? (syntax pt)))
- (list
- (make-reg-test
- `(equal? ,(syntax-object->datum ae)
- ,(syntax-object->datum (syntax pt)))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp pt)))
- ae
- let-bound
- sf bv kf ks))))))
-
- ;(pt
- ; (stx-? regexp? (syntax pt))
- ; (render-test-list (syntax/loc p (regex pt)) ae stx))
-
- ((quote _)
- (list
- (make-reg-test
- `(equal? ,(syntax-object->datum ae)
- ,(syntax-object->datum p))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
- ae
- let-bound
- sf bv kf ks))))))
- (`quasi-pat
- (render-test-list (parse-quasi (syntax quasi-pat)) ae stx))
- ('item
- (list (make-reg-test
- `(equal? ,(syntax-object->datum ae)
- ,(syntax-object->datum p))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
- ae
- let-bound
- sf bv kf ks))))))
- ;;('(items ...)
- ;;(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
- ((? pred? pat1 pats ...)
- (render-test-list (syntax (and (? pred?) pat1 pats ...)) ae stx))
- ;; could we check to see if a predicate is a procedure here?
- ((? pred?)
- (list (make-reg-test
- `(,(syntax-object->datum (syntax pred?))
- ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc p (pred? #,exp)))
- ae
- let-bound
- sf bv kf ks))))))
- ;; syntax checking
- ((? pred? ...)
- (match:syntax-err
- p
- (if (zero? (length (syntax-e (syntax (pred? ...)))))
- "a predicate pattern must have a predicate following the ?"
- "syntax error in predicate pattern")))
-
- ((regexp reg-exp)
- (render-test-list (quasisyntax/loc
- p
- (and (? string?)
- (? (lambda (x) (regexp-match reg-exp x)))))
- ae
- stx))
- ((pregexp reg-exp)
- (render-test-list (quasisyntax/loc
- p
- (and (? string?)
- (? (lambda (x) (pregexp-match-with-error
- reg-exp x)))))
- ae
- stx))
-
- ((regexp reg-exp pat)
- (render-test-list (quasisyntax/loc
- p
- (and (? string?)
- (app (lambda (x) (regexp-match reg-exp x)) pat)))
- ae
- stx))
-
- ((pregexp reg-exp pat)
- (render-test-list (quasisyntax/loc
- p
- (and (? string?)
- (app (lambda (x) (pregexp-match-with-error
- reg-exp x)) pat)))
- ae
- stx))
-
- ((app op pat)
- (render-test-list (syntax pat)
- (quasisyntax/loc p (op #,ae))
- stx))
- ;; syntax checking
- ((app op ...)
- (match:syntax-err
- p
- (if (zero? (length (syntax-e (syntax (op ...)))))
- "an operation pattern must have a procedure following the app"
- "there should be one pattern following the operator")))
- ((and pats ...)
- (let loop
- ((p (syntax (pats ...))))
- (syntax-case p ()
- (() '()) ;(ks seensofar boundvars let-bound))
- ((pat1 pats ...)
- (append (render-test-list (syntax pat1) ae stx)
- (loop (syntax (pats ...))))))))
-
- ((or pats ...)
- (list (make-act
- 'or-pat ;`(or-pat ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (or-gen ae (syntax-e (syntax (pats ...)))
- stx sf bv ks kf let-bound))))))
-
- ; backtracking or
-
- ; ((or pats ...)
- ; (let* ((pat-list (syntax->list (syntax (pats ...)))))
- ; (let* ((bound (getbindings (stx-car (syntax (pats ...)))))
- ; (bind-map
- ; (map (lambda (x)
- ; (cons x
- ; #`#,(gensym (syntax-object->datum x))))
- ; bound))
- ; (id (begin (set! or-id (add1 or-id)) (sub1 or-id))))
- ; (write id)(newline)
- ; (write (syntax-object->datum (syntax (pats ...))))(newline)
- ; (list
- ; (make-act
- ; 'or-pat
- ; ae
- ; (lambda (ks kf let-bound)
- ; (lambda (sf bv)
- ; (write id)(newline)
- ; (if (stx-null? (syntax (pats ...)))
- ; (kf sf bv)
- ; #`(let #,(map (lambda (b)
- ; #`(#,(cdr b) '()))
- ; bind-map)
- ; (if (or
- ; #,@(map (lambda (p)
- ; #`(#,(create-test-func
- ; p
- ; sf
- ; let-bound
- ; bind-map
- ; #f) #,(subst-bindings ae
- ; let-bound)))
- ; pat-list))
- ; #,(ks sf (append bind-map bv))
- ; #,(kf sf bv)))))))))))
-
- ((not pat)
- (list (make-act
- 'not-pat ;`(not-pat ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- ;; swap success and fail
- (next-outer (syntax pat) ae sf bv let-bound ks kf))))))
- ;; could try to catch syntax local value error and rethrow syntax error
-
- ((list-no-order pats ...)
- (if (stx-null? (syntax (pats ...)))
- (render-test-list (syntax/loc p (list)) ae 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 ...)))))
- (bind-map
- (map (lambda (x)
- (cons x
- #`#,(gensym (syntax-object->datum x))))
- bound)))
-
- (list
- (make-shape-test
- `(list? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp)
- (quasisyntax/loc stx (list? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (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)))
- #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))
- 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
- (make-shape-test
- `(hash-table? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc stx (hash-table? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (let ((mod-pat
- (lambda (pat)
- (syntax-case pat ()
- ((key value) (syntax (list key value)))
- (ddk
- (stx-dot-dot-k? (syntax ddk))
- (syntax ddk))
- (id
- (and (identifier? (syntax id))
- (pattern-var? (syntax-object->datum (syntax id)))
- (not (stx-dot-dot-k? (syntax id))))
- (syntax id))
- (p (match:syntax-err
- (syntax/loc stx p)
- "poorly formed hash-table pattern"))))))
- (make-act
- 'hash-table-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (let ((hash-name (gensym 'hash)))
- #`(let ((#,hash-name
- (hash-table-map #,(subst-bindings ae
- let-bound)
- (lambda (k v) (list k v)))))
- #,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
- #`#,hash-name
- sf
- ;; these tests have to be true
- ;;(append (list
- ;; '(pair? exp)
- ;; '(pair? (cdr exp))
- ;; '(null? (cdr (cdr exp))))
- ;; sf)
- bv
- let-bound
- kf
- ks)))))))))
-
- ((hash-table pats ...)
- (match:syntax-err
- p
- "improperly formed hash table pattern"))
-
- ((struct struct-name (fields ...))
- (identifier? (syntax struct-name))
- (let ((num-of-fields (stx-length (syntax (fields ...)))))
- (let-values (((pred accessors mutators parental-chain)
- (struct-pred-accessors-mutators
- (syntax struct-name)
- (lambda ()
- (match:syntax-err
- (syntax struct-name)
- "not a defined structure")))))
- (let ((dif (- (length accessors) num-of-fields)))
- (if (not (zero? dif))
- (match:syntax-err
- p
- (string-append
- (if (> dif 0) "not enough " "too many ")
- "fields for structure in pattern"))
- (cons
- (make-shape-test
- `(struct-pred ,(syntax-object->datum pred)
- ,(map syntax-object->datum parental-chain)
- ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp)
- (quasisyntax/loc stx (struct-pred #,pred #,parental-chain #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (let ((field-pats (syntax->list (syntax (fields ...)))))
- (let rloop ((n 0))
- (if (= n num-of-fields)
- '()
- (append
- (let ((cur-pat (list-ref field-pats n)))
- (syntax-case cur-pat (set! get!)
- ((set! setter-name)
- (list (make-act
- 'set!-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (ks sf
- (cons (cons (syntax setter-name)
- #`(lambda (y)
- (#,(list-ref
- mutators
- n)
- #,ae y)))
- bv)))))))
- ((get! getter-name)
- (list (make-act
- 'get!-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (ks sf
- (cons (cons (syntax getter-name)
- #`(lambda ()
- (#,(list-ref
- accessors
- n)
- #,ae)))
- bv)))))))
- (_
- (render-test-list
- cur-pat
- (quasisyntax/loc
- stx
- (#,(list-ref accessors n) #,ae))
- stx))))
- (rloop (+ 1 n))))))))))))
- ;; 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")))
- ((set! ident)
- (identifier? (syntax ident))
- (list (make-act
- 'set!-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (ks sf (cons (cons (syntax ident)
- (setter ae p let-bound))
- bv)))))))
- ;; syntax checking
- ((set! ident ...)
- (let ((x (length (syntax-e (syntax (ident ...))))))
- (match:syntax-err
- p
- (if (= x 1)
- "there should be an identifier after set! in pattern"
- (string-append "there should "
- (if (zero? x) "" "only ")
- "be one identifier after set! in pattern")))))
- ((get! ident)
- (identifier? (syntax ident))
- (list (make-act
- 'get!-pat
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (ks sf (cons (cons (syntax ident)
- (getter ae p let-bound))
- bv)))))))
- ((get! ident ...)
- (let ((x (length (syntax-e (syntax (ident ...))))))
- (match:syntax-err
- p
- (if (= x 1)
- "there should be an identifier after get! in pattern"
- (string-append "there should "
- (if (zero? x) "" "only ")
- "be one identifier after get! in pattern")))))
-
- ((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
- (make-shape-test
- `(list? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- ;;(write 'here)(write let-bound)(newline)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (list? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (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)
- stx let-bound)
- (handle-inner-ddk-list ae kf ks
- (syntax pat)
- (syntax dot-dot-k)
- (append-if-necc 'list
- (syntax (pat-rest ...)))
- stx
- let-bound))))))
-
- ((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
- (make-shape-test
- `(pair? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- ;;(write 'here)(write let-bound)(newline)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (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 ...))))
- stx
- let-bound)))))
-
- ;; 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
- (make-shape-test
- `(pair? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- ;;(write 'here)(write let-bound)(newline)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (append
- (render-test-list (syntax car-pat)
- (quasisyntax/loc (syntax car-pat) (car #,ae))
- stx) ;(add-a e)
- (render-test-list
- (syntax cdr-pat)
- (quasisyntax/loc (syntax cdr-pat) (cdr #,ae))
- stx))))
-
- ((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
- (make-shape-test
- `(pair? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- ;;(write 'here)(write let-bound)(newline)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (append
- (render-test-list (syntax car-pat)
- (quasisyntax/loc (syntax car-pat) (car #,ae))
- stx) ;(add-a e)
- (render-test-list
- (append-if-necc 'list-rest (syntax (cdr-pat ...)))
- (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
- stx))))
-
- ((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
- (make-shape-test
- `(pair? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- ;;(write 'here)(write let-bound)(newline)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (append
- (render-test-list (syntax car-pat)
- (quasisyntax/loc (syntax car-pat) (car #,ae))
- stx) ;(add-a e)
- (if (stx-null? (syntax (cdr-pat ...)))
- (list
- (make-shape-test
- `(null? (cdr ,(syntax-object->datum ae)))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp)
- (quasisyntax/loc p (null? #,exp)))
- (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae));ae
- let-bound
- sf
- bv
- kf
- ks)))))
- (render-test-list
- (append-if-necc 'list (syntax (cdr-pat ...)))
- (quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
- stx)))))
-
- ((vector pats ...)
- (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
- (list
- (make-shape-test
- `(vector? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- (make-act
- 'vec-ddk-pat
- ae
- (lambda (ks kf let-bound)
- (handle-ddk-vector ae kf ks
- (syntax/loc p #(pats ...))
- stx let-bound)))))
-
- ((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
- (make-shape-test
- `(vector? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
- ae
- let-bound
- sf
- bv
- kf
- ks))))
- ;; 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
- (syntax/loc p #(pats ...))
- stx let-bound)))))
-
- ((vector pats ...)
- (let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
- (vlen (vector-length syntax-vec)))
- (cons
- (make-shape-test
- `(vector? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
- ae
- let-bound
- sf bv kf ks))))
- (cons
- (make-shape-test
- `(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc
- stx
- (equal? (vector-length #,exp) #,vlen)))
- ae
- let-bound
- sf bv kf ks))))
- (let vloop ((n 0))
- (if (= n vlen)
- '()
- (append
- (render-test-list
- (vector-ref syntax-vec n)
- (quasisyntax/loc stx (vector-ref #,ae #,n))
- stx)
- (vloop (+ 1 n)))))))))
-
- ((box pat)
- (cons
- (make-shape-test
- `(box? ,(syntax-object->datum ae))
- ae
- (lambda (ks kf let-bound)
- (lambda (sf bv)
- (emit
- (lambda (exp) (quasisyntax/loc stx (box? #,exp)))
- ae
- let-bound
- sf bv kf ks))))
- (render-test-list
- (syntax pat)
- (quasisyntax/loc stx (unbox #,ae))
- stx)))
- (got-too-far
- (match:syntax-err
- (syntax/loc stx got-too-far)
- "syntax error in pattern"))))
diff --git a/collects/mzlib/private/plt-match/reorder-tests.scm b/collects/mzlib/private/plt-match/reorder-tests.scm
deleted file mode 100644
index 919a7fbf0b..0000000000
--- a/collects/mzlib/private/plt-match/reorder-tests.scm
+++ /dev/null
@@ -1,99 +0,0 @@
-;; This library is used by match.ss
-;; This requires the test data structure.
-
-(define-values (reorder-all-lists)
- (letrec
- (
- ;;!(function insertion-sort
- ;; (form (insertion-sort ls less-than?) -> list)
- ;; (contract (list (any any -> bool) -> list)))
- ;; This is the classic stable sort. Any stable sort will do.
- (insertion-sort
- (lambda (ls less-than?)
- (define (insert el ls)
- (define (ins ls)
- (cond ((null? ls) (list el))
- ((less-than? el (car ls))
- (cons el ls))
- (else (cons (car ls) (ins (cdr ls))))))
- (ins ls))
- (letrec ((IS (lambda (ls)
- (if (null? ls)
- '()
- (insert (car ls)
- (IS (cdr ls)))))))
- (IS ls))))
-
- ;;!(function make-test-order-func
- ;; (form (make-test-order-func whole-list) -> less-than?)
- ;; (contract list -> (any any -> bool)))
- ;; This function creates a test function which has access to the
- ;;whole list of test structures capured in the closure. This
- ;;function places tests that are used more ahead of those used
- ;;less. When tests are used an equal number of times the test whos
- ;;membership set has the greatest presence is placed ahead.
- (make-test-order-func
- (lambda (whole-list)
- (lambda (t1 t2)
- (let ((t1-tu (test-times-used t1))
- (t2-tu (test-times-used t2)))
- (cond ((> t1-tu t2-tu) #t)
- ;; these two new rules allow negate
- ;; tests to be placed properly
- ((and (= t1-tu t2-tu)
- (shape-test? t1)
- (not (shape-test? t2))
- (negate-test? t2))
- #t)
- ((and (= t1-tu t2-tu)
- (not (shape-test? t1))
- (negate-test? t1)
- (shape-test? t2))
- #f)
- ((and (= t1-tu t2-tu)
- (or (equal? (test-used-set t1) (test-used-set t2))
- (>= (number-of-similar (test-used-set t1)
- whole-list)
- (number-of-similar (test-used-set t2)
- whole-list))))
- #t)
- (else #f))))))
-
- ;;!(function number-of-similar
- ;; (form (number-of-similar set ls) -> integer)
- ;; (contract (list list) -> integer))
- ;; This function returns the number of tests that have a
- ;; membership set similar to set. A membership set is the set of
- ;; test-lists that have a similar tests as the test itself.
- (number-of-similar
- (lambda (set ls)
- (apply + (map (lambda (set2) (if (equal? set set2) 1 0))
- (map test-used-set ls)))))
-
- ;;!(function reorder-tests
- ;; (form (reorder-tests2 test-list) -> test-list)
- ;; (contract list -> list))
- ;; This function reorders one list of test structs.
- (reorder-tests
- (lambda (test-list)
- ;;(pretty-print test-list)(newline)
- (insertion-sort test-list (make-test-order-func test-list))))
-
- ;;!(function reorder-all-lists
- ;; (form (reorder-all-lists2 rendered-list) -> list)
- ;; (contract list -> list))
- ;; This function reorders all of the rendered-lists that have
- ;; success-functions attached to them.
- (reorder-all-lists
- (lambda (rendered-list)
- (if (null? rendered-list)
- '()
- (let ((success-func (cdr (car rendered-list)))
- (rot (reorder-tests (caar rendered-list))))
- ;(pretty-print rot)(newline)
- (cons (cons rot success-func)
- (reorder-all-lists (cdr rendered-list)))))))
- )
- (values reorder-all-lists)))
-
-
diff --git a/collects/mzlib/private/plt-match/special-generators.scm b/collects/mzlib/private/plt-match/special-generators.scm
deleted file mode 100644
index fc28ac0489..0000000000
--- a/collects/mzlib/private/plt-match/special-generators.scm
+++ /dev/null
@@ -1,150 +0,0 @@
-;; This library is used by match.ss
-
-;;!(function or-gen
-;; (form (or-gen exp orpatlist stx sf bv ks kf let-bound)
-;; ->
-;; syntax)
-;; (contract (syntax list syntax 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
- (lambda (exp orpatlist stx sf bv ks kf let-bound)
- (let ((rendered-list
- (map
- (lambda (pat)
- (cons (render-test-list pat exp 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)
- (let* ((rendered-list
- (reorder-all-lists rendered-list)
- )
- (output ((meta-couple rendered-list kf let-bound bv) sf bv)))
- output))))
-
-;;!(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 next-outer
- (opt-lambda (p
- ae ;; this is the actual expression
- sf
- bv
- let-bound
- kf
- ks
- [stx (syntax '())]
- [opt #f])
- (next-outer-helper p ae sf bv let-bound
- (lambda (x) kf) (lambda (a b) ks) stx opt)))
-
-;;!(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 next-outer-helper
- (opt-lambda (p
- ae ;; this is the actual expression
- sf
- bv
- let-bound
- kf-func
- ks-func
- [stx (syntax '())]
- [opt #f])
- ;; right now this does not bind new variables
- (let ((rendered-list (render-test-list p ae 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)
- (quasisyntax/loc
- p
- (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)))))))
-
-;;!(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)
- (let/cc out
- (next-outer
- pat-syntax
- (quote-syntax dummy)
- '()
- '()
- '()
- (lambda (sf bv) #'(dummy-symbol))
- (lambda (sf bv) (out (map car bv))))))
diff --git a/collects/mzlib/private/plt-match/tag-negate-tests.scm b/collects/mzlib/private/plt-match/tag-negate-tests.scm
deleted file mode 100644
index 393061d6b6..0000000000
--- a/collects/mzlib/private/plt-match/tag-negate-tests.scm
+++ /dev/null
@@ -1,99 +0,0 @@
-(define (tag-neg-test ls target-set)
- (easy-tag ls #f target-set))
-
-(define (easy-tag ls last-shape target-set)
- (cond ((null? ls) #f)
- ((let ((tst (car ls)))
- (and ;(not (action-test? tst))
- (not (or (shape-test? tst) (action-test? tst)))
- (equal? target-set (test-used-set-neg tst))))
- (begin
- (when (and last-shape (not (shape-test? (car ls))))
- (set-test-closest-shape-tst! (car ls) last-shape)
- (set-test-used-set! (car ls) last-shape)
- (set-test-times-used! (car ls) (length last-shape)))
- #t))
- ((shape-test? (car ls))
- (easy-tag (cdr ls) (test-used-set (car ls)) target-set))
- (else
- (easy-tag (cdr ls) last-shape target-set))))
-
-(define (tag-negate-tests ls-of-ls)
- (letrec ((gen-target-set-help
- (lambda (init length)
- (if (zero? length)
- '()
- (cons init
- (gen-target-set-help (add1 init)
- (sub1 length))))))
- (gen-target-set
- (lambda (length)
- (gen-target-set-help 2 length)))
- (tag-help
- (lambda (ls target-set)
- (if (null? target-set)
- '()
- (begin
- (tag-neg-test (car ls)
- (reverse target-set))
- (tag-help
- (cdr ls)
- (cdr target-set)))))))
- (tag-help (map car ls-of-ls) (gen-target-set (sub1 (length ls-of-ls))))))
-
-
-; (define (move-negates-to-tags ls-of-ls)
-; (map (lambda (l) (cons (move-neg-to-tag (car l))
-; (cdr l)))
-; ls-of-ls))
-
-
-; (define (move-neg-to-tag ls)
-; (let-values (((list-without-neg-tests neg-tests)
-; (let loop ((l ls)
-; (ntsf '()))
-; (cond ((null? l) (values '() ntsf))
-; ((negate-test? (car l))
-; (loop (cdr l) (append ntsf (list (car l)))))
-; (else
-; (let-values (((lwnt ntsf) (loop (cdr l) ntsf)))
-; (values (cons (car l) lwnt)
-; ntsf)))))))
-; ;(write 'lwnt--)(pretty-print list-without-neg-tests)
-; ;(write 'neg-test)(pretty-print neg-tests)
-; (letrec ((insert-negtest
-; (lambda (t-list neg-test)
-; (cond ((null? t-list)
-; '())
-; ((and (equal? (test-used-set (car t-list))
-; (test-closest-shape-tst neg-test))
-; (or (null? (cdr t-list))
-; (not (equal? (test-used-set (cadr t-list))
-; (test-closest-shape-tst neg-test)))))
-; (cons (car t-list)
-; (cons neg-test
-; (cdr t-list))))
-; ; ((equal? (test-tst (car t-list))
-; ; (test-closest-shape-tst neg-test))
-; ; (cons (car t-list)
-; ; (cons neg-test
-; ; (cdr t-list))))
-; (else
-; (cons (car t-list)
-; (insert-negtest (cdr t-list)
-; neg-test)))))))
-; (let loop2 ((t-list list-without-neg-tests)
-; (ntst neg-tests))
-; ;(write 't-list)(pretty-print t-list)
-; ;(write 'ntst ) (pretty-print ntst)
-; ;(write 'insert) (pretty-print (insert-negtest t-list (car ntst)) )
-; (cond ((null? ntst) t-list)
-; (else (insert-negtest t-list (car ntst))))))))
-; ; (cond ((null? ntst)
-; ; t-list)
-; ; (loop2 (insert-negtest t-list (car ntst))
-; ; (cdr ntst)))))))
-
-
-
-
\ No newline at end of file
diff --git a/collects/mzlib/private/plt-match/test-structure.scm b/collects/mzlib/private/plt-match/test-structure.scm
deleted file mode 100644
index 0601185510..0000000000
--- a/collects/mzlib/private/plt-match/test-structure.scm
+++ /dev/null
@@ -1,110 +0,0 @@
-;; This library is used by match.ss
-
-;; This is the major data structure of the compiler. It holds a
-;; great deal of information. This structure represents a
-;; partially compiled match test. This test is the basic unit of
-;; compilation. The order of these tests greatly affects the size
-;; of the final compiled match expression. it also affects the
-;; amount of time it takes to compile a match expression.
-;; the fields:
-;; tst - an S-exp of the test such as (equal exp 5). It can also
-;; be a name of a test that isn't meant to be compared to other
-;; tests such as 'list-ddk-pat.
-;; comp - a function that takes a success-function, a fail-function and
-;; a list of let bindings
-;; shape - a boolean that is true if the test tests the shape or type
-;; of the data rather than the value of the data
-;; times-used - the number of clauses that use this test. In reality
-;; the number of clauses in which this test will eliminate
-;; tests
-;; used-set - a list of numbers which designate the test-lists that
-;; in which this test will eliminate tests
-;; bind-exp-stx - the syntax of the actual expression that is being tested
-;; by this test ex. (syntax (car (cdr x)))
-;; bind-exp - the s-exp that is being tested by this test,
-;; easily obtained by taking the syntax-object->datum
-;; of bind-exp-stx
-;; bind-count - is the number of times in the bind-exp is found in the
-;; test list in which this test is a member
-(define-struct test (tst
- comp
- shape
- times-used
- used-set
- bind-exp-stx
- bind-exp
- bind-count
- times-used-neg
- used-set-neg
- closest-shape-tst
- equal-set)
- (make-inspector))
-
-;;!(function make-shape-test
-;; (form (make-shape-test test exp comp) -> test-struct)
-;; (contract (s-exp syntax (((list list -> syntax)
-;; (list list -> syntax) list)
-;; ->
-;; (list list -> syntax)))
-;; -> test))
-;; This function is essentially a constructor for a test struct.
-;; This constructor makes a "shape" test - test that tests for type
-;; rather than value.
-;; Arguments:
-;; test - s-exp of the test
-;; exp - the syntax of the expression being tested
-;; comp - the compilation function which will finish the compilation
-;; after tests have been reordered
-(define (make-shape-test test exp comp)
- (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
-
-;;!(function make-reg-test
-;; (form (make-shape-test test exp comp) -> test-struct)
-;; (contract (s-exp syntax (((list list -> syntax)
-;; (list list -> syntax) list)
-;; -> (list list -> syntax)))
-;; -> test))
-;; This function is essentially a constructor for a test struct.
-;; This constructor makes a "regular" test
-;; Arguments:
-;; test - s-exp of the test
-;; exp - the syntax of the expression being tested
-;; comp - the compilation function which will finish the compilation
-;; after tests have been reordered
-(define (make-reg-test test exp comp)
- (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 0 '() #f '()))
-
-;;!(function make-act-test
-;; (form (make-shape-test test exp comp) -> test-struct)
-;; (contract (s-exp syntax (((list list -> syntax)
-;; (list list -> syntax) list) -> (list list -> syntax)))
-;; -> test))
-;; This function is essentially a constructor for a test struct.
-;; This constructor makes an "action" test - an action test is not
-;; neccessarily a test so to speak but rather an action that needs to be
-;; taken in order to verify that a certain expression matches a pattern.
-;; A good example of this is the binding of a pattern variable.
-;; Arguments:
-;; act-name -
-;; exp - the syntax of the expression being tested
-;; comp - the compilation function which will finish the compilation
-;; after tests have been reordered
-(define (make-act act-name exp comp)
- (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 -1 '() #f '()))
-
-;;!(function action-test?
-;; (form (action-test? test) -> bool)
-;; (contract test -> bool))
-;; a predicate that returns true if a test is an action test
-(define (action-test? test)
- (= -1 (test-times-used test)))
-
-;;!(function shape-test?
-;; (form (shape-test? test) -> bool)
-;; (contract test -> bool))
-;; a predicate that returns true if a test is an shape test
-(define (shape-test? test)
- (test-shape test))
-
-(define (negate-test? test)
- (test-closest-shape-tst test))
diff --git a/collects/mzlib/private/plt-match/update-binding-counts.scm b/collects/mzlib/private/plt-match/update-binding-counts.scm
deleted file mode 100644
index d0e96c75c0..0000000000
--- a/collects/mzlib/private/plt-match/update-binding-counts.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-;; This library is used by match.ss
-
-(define-values (update-binding-counts update-binding-count)
- (letrec
- (
- ;;!(function update-binding-count
- ;; (form (update-binding-count render-list) -> list)
- ;; (contract list -> list))
- ;; This function is normally executed for its side effect of
- ;; setting the count for the number of times an expression used in
- ;; a test if found in the rest of the list of tests. This does
- ;; not only count occurrances of the exp in other tests but
- ;; whether the expression is also a sub expression in the other tests.
- ;; Arg:
- ;; render-list - a list of test structs
- (update-binding-count
- (lambda (render-list)
- (define (inc-bind-count test)
- (set-test-bind-count! test
- (add1 (test-bind-count test))))
- (if (null? render-list)
- '()
- (let ((cur-test (car render-list)))
- (update-binding-count
- (let loop ((l (cdr render-list)))
- (cond ((null? l) '())
- ((>= (test-bind-count cur-test) 2) l)
- ((and (valid-for-let-binding (test-bind-exp cur-test))
- (equal? (test-bind-exp cur-test)
- (test-bind-exp (car l))))
- (begin
- (inc-bind-count cur-test)
- (loop (cdr l))))
- ((sub-exp-contains (test-bind-exp cur-test)
- (test-bind-exp (car l)))
- (begin
- (inc-bind-count cur-test)
- (cons (car l) (loop (cdr l)))))
- (else (cons (car l) (loop (cdr l)))))))))))
-
- ;;!(function valid-for-let-binding
- ;; (form (valid-for-let-binding exp) -> bool)
- ;; (contract s-exp -> bool)
- ;; (example (valid-for-let-binding 'x) -> #f))
- ;; This function is a predicate that determins if an expression
- ;; should be considered for let binding.
- (valid-for-let-binding
- (lambda (exp)
- ;; it must be a pair
- ;; the index must be an integer
- '(match exp
- (('vector-ref _ n) (number? n))
- ((? pair?) #t)
- (_ #f))
- ;; the following is expanded fromt the above match expression
- (let ((x exp))
- (if (pair? x)
- (if (and (equal? (car x) 'vector-ref)
- (pair? (cdr x))
- (pair? (cdr (cdr x)))
- (null? (cdr (cdr (cdr x)))))
- ((lambda (n) (number? n)) (car (cdr (cdr x))))
- ((lambda () #t)))
- ((lambda () #f))))))
-
- ;;!(function sub-exp-contains
- ;; (form (sub-exp-contains exp1 exp2) -> bool)
- ;; (contract (s-exp s-exp) -> bool)
- ;; (example (sub-exp-contains '(cdr x) '(car (cdr x))) -> #t))
- ;; This function returns true if exp2 contains a sub-expression
- ;; that is equal? to exp1. For this function to work the subexp
- ;; must always be in the second position in a exp. This is a
- ;; convention that is followed throughout the match program.
- (sub-exp-contains
- (lambda (exp1 exp2)
- '(match exp2
- (() #f)
- ((_ sub-exp _ ...)
- (if (and (valid-for-let-binding sub-exp)
- (equal? sub-exp exp1))
- #t
- (sub-exp-contains exp1 sub-exp)))
- (_ #f))
- ;; The following was expanded from the above match expression
- (let ((x exp2))
- (if (null? x)
- ((lambda () #f))
- (if (and (pair? x) (pair? (cdr x)) (list? (cdr (cdr x))))
- ((lambda (sub-exp)
- (if (and (pair? sub-exp)
- (equal? sub-exp exp1))
- #t
- (sub-exp-contains exp1 sub-exp)))
- (car (cdr x)))
- ((lambda () #f)))))))
-
- ;;!(function update-binding-counts
- ;; (form (update-binding-counts render-lists) -> list)
- ;; (contract list -> list))
- ;; This function calls update-binding-count for each render list
- ;; in the list of render lists. This is used mainly for its side
- ;; affects. The result is of no consequence.
- (update-binding-counts
- (lambda (render-lists)
- (map update-binding-count (map car render-lists))))
- )
- (values update-binding-counts update-binding-count)))
diff --git a/collects/mzlib/private/plt-match/update-counts.scm b/collects/mzlib/private/plt-match/update-counts.scm
deleted file mode 100644
index c746938b25..0000000000
--- a/collects/mzlib/private/plt-match/update-counts.scm
+++ /dev/null
@@ -1,181 +0,0 @@
-;; This library is used by match.ss
-;; This requires the test data structure.
-
-(define-values (update-counts)
- (letrec
- (
- ;;!(function test-filter
- ;; (form (test-filter test-list) -> test-list)
- ;; (contract list -> list))
- ;; 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.
- (test-filter
- (lambda (tlist)
- (if (null? tlist)
- '()
- (if (= -1 (test-times-used (car tlist)))
- (test-filter (cdr tlist))
- (cons (car tlist)
- (test-filter (cdr tlist)))))))
-
-
- ;; !(function inverse-in
- ;; (form (inverse-in test test-list) -> bool)
- ;; (contract (s-exp list) -> bool))
- ;; This function checks to see if any of the members of the test-list
- ;; would be eliminated by the function if the test was in the test so far
- ;; list. This is the opposite of what the in function does.
- (inverse-in
- (lambda (test test-list)
- (or (pos-inverse-in test test-list)
- (neg-inverse-in test test-list))))
-
- (pos-inverse-in
- (lambda (test test-list)
- (let ((test-with-implied (cons test (implied test))))
- (ormap (lambda (t) (in t test-with-implied))
- test-list)
- )))
-
- (neg-inverse-in
- (lambda (test test-list)
- (let ((test-with-implied (cons test (implied test))))
- (ormap (lambda (t) (in `(not ,t) test-with-implied))
- test-list)
- )))
-
- (logical-member
- (lambda (item lst)
- (ormap (lambda (cur)
- (logical-equal? item cur))
- lst)))
-
- (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))
- (let ((exp8164 (car x)))
- (if (and (pair? exp8164) (equal? (car exp8164) 'list?))
- (let ((exp8165 (cdr exp8164)))
- (if (and (pair? exp8165) (null? (cdr exp8165)))
- (let ((exp8166 (car exp8163)))
- (if (and (pair? exp8166) (equal? (car exp8166) 'null?))
- (let ((exp8167 (cdr exp8166)))
- (if (and (pair? exp8167)
- (null? (cdr exp8167))
- (equal? (car exp8167) (car exp8165)))
- ((lambda (x) #t) (car exp8165))
- ((lambda (else) #f) x)))
- ((lambda (else) #f) x)))
- ((lambda (else) #f) x)))
- ((lambda (else) #f) x))))
- ((lambda (else) #f) x)))
- ((lambda (else) #f) x))))
-
- (truncate
- (lambda (pos used-set-neg)
- (cond ((null? used-set-neg)
- '())
- ((>= pos (car used-set-neg))
- (list pos))
- (else
- (cons (car used-set-neg)
- (truncate pos (cdr used-set-neg)))))))
-
- (truncate-neg
- (lambda (pos used-set-neg)
- (cond ((null? used-set-neg)
- '())
- ((>= pos (car used-set-neg))
- '())
- (else
- (cons (car used-set-neg)
- (truncate-neg pos (cdr used-set-neg)))))))
-
-
-
- ;;!(function update-count
- ;; (form (update-count test tests-rest pos) -> void)
- ;; (contract (test-struct list integer) -> void))
- ;; This function updates the test-times-used and test-used-set
- ;; fields of the test structs. These fields are essential to
- ;; determining the order of the tests.
- (update-count
- (lambda (test tests-rest pos mem-table)
- (let loop ((l tests-rest)
- (p (add1 pos)))
- (if (null? l)
- (begin
- ;; memoize
- (hash-table-get mem-table (test-tst test)
- (lambda ()
- (hash-table-put!
- mem-table
- (test-tst test) (list (test-used-set test)
- (test-used-set-neg test)))))
- )
- (let ((entry-pair
- (hash-table-get mem-table (test-tst test)
- (lambda ()
- (when (
- ;member
- logical-member
- ;inverse-in
- (test-tst test) (car l))
- (set-test-times-used! test (add1 (test-times-used test)))
- (set-test-used-set! test (cons p (test-used-set test)))
- (set-test-equal-set! test (cons p (test-equal-set test)))
- )
- (when (neg-inverse-in (test-tst test) (car l))
- (set-test-used-set-neg! test (cons p (test-used-set-neg test))))
- (loop (cdr l) (add1 p))
- ))))
- (when (and (list? entry-pair) (not (null? entry-pair)))
- (let ((trun-used (truncate pos (car entry-pair))))
- (set-test-used-set! test trun-used)
- (set-test-equal-set! test trun-used)
- (set-test-times-used! test (length trun-used))
- (set-test-used-set-neg! test (truncate-neg pos (cadr entry-pair)))))
- )))))
-
- ;;!(function update-counts
- ;; (form (update-counts render-list) -> void)
- ;; (contract list -> void))
- ;; This function essentially calls update-count on every test in
- ;; all of the test lists.
- (update-counts
- (lambda (render-list)
- (let* ((mem-table (make-hash-table 'equal))
- (test-master-list (map test-filter
- (map car render-list)))
- (test-so-far-lists ;; horrible name
- (map
- (lambda (tl)
- (let ((f (map test-tst (test-filter tl))))
- f))
- test-master-list)))
- (let loop ((tml test-master-list)
- (tsf test-so-far-lists)
- (pos 1))
- (if (null? tml)
- '()
- (begin
- (map (lambda (t)
- (set-test-times-used! t 1)
- (set-test-used-set!
- t
- (cons pos (test-used-set t)))
- (set-test-equal-set!
- t
- (cons pos (test-equal-set t)))
- (update-count t (cdr tsf) pos mem-table))
- (car tml))
- (loop (cdr tml) (cdr tsf) (add1 pos))))))))
- )
- (values update-counts)))
-
-