From b7127dc9c77f55bb6f787fbb58d4ebaa940f525f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 Mar 2008 23:54:58 +0000 Subject: [PATCH 01/10] Add new match implementation. Does not yet work: - some errors about car of () - some match-expander certification errors svn: r9049 --- collects/mzlib/match.ss | 194 +---------- collects/mzlib/plt-match.ss | 159 +-------- collects/scheme/match.ss | 4 +- collects/scheme/match/compiler.ss | 433 ++++++++++++++++++++++++ collects/scheme/match/define-forms.ss | 116 +++++++ collects/scheme/match/gen-match.ss | 45 +++ collects/scheme/match/legacy-match.ss | 12 + collects/scheme/match/match-expander.ss | 61 ++++ collects/scheme/match/match.ss | 12 + collects/scheme/match/parse-helper.ss | 85 +++++ collects/scheme/match/parse-legacy.ss | 135 ++++++++ collects/scheme/match/parse-quasi.ss | 84 +++++ collects/scheme/match/parse.ss | 243 +++++++++++++ collects/scheme/match/patterns.ss | 224 ++++++++++++ collects/scheme/match/split-rows.ss | 85 +++++ 15 files changed, 1543 insertions(+), 349 deletions(-) create mode 100644 collects/scheme/match/compiler.ss create mode 100644 collects/scheme/match/define-forms.ss create mode 100644 collects/scheme/match/gen-match.ss create mode 100644 collects/scheme/match/legacy-match.ss create mode 100644 collects/scheme/match/match-expander.ss create mode 100644 collects/scheme/match/match.ss create mode 100644 collects/scheme/match/parse-helper.ss create mode 100644 collects/scheme/match/parse-legacy.ss create mode 100644 collects/scheme/match/parse-quasi.ss create mode 100644 collects/scheme/match/parse.ss create mode 100644 collects/scheme/match/patterns.ss create mode 100644 collects/scheme/match/split-rows.ss diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 1cbc47dd5a..6bfea8a14c 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -1,192 +1,4 @@ -;; (documentation (name match)) -;; 
Pattern Matching Syntactic Extensions for Scheme
-;;
-;; Special thanks go out to:
-;; Robert Bruce Findler for support and bug detection.
-;; Doug Orleans for pointing out that pairs should be reused while
-;; matching lists.
-;;
-;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
-;; which in turn was adapted from code written by Bruce F. Duba, 1991.
-;;
-;; This macro package extends Scheme with several new expression forms.
-;; Following is a brief summary of the new forms.  See the associated
-;; LaTeX documentation for a full description of their functionality.
-;;
-;;
-;;         match expressions:
-;;
-;; exp ::= ...
-;;       | (match exp clause ...)
-;;       | (match-lambda clause ...) 
-;;       | (match-lambda* clause ...)
-;;       | (match-let ((pat exp) ...) body ...)
-;;       | (match-let var ((pat exp) ...) body ...)
-;;       | (match-let* ((pat exp) ...) body ...)
-;;       | (match-letrec ((pat exp) ...) body ...)
-;;       | (match-define pat exp)
-;;
-;; clause ::= (pat body) | (pat (=> identifier) exp)
-;;
-;;         patterns:                       matches:
-;;
-;; pat ::= 
-;;         identifier                      this binds an identifier if it 
-;;                                         doesn't conflict with
-;;                                         ..k, var, $, =, and, 
-;;                                         or, not, ?, set!, or get!
-;;       | _                               anything
-;;       | ()                              the empty list
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | 'sexp                           an s-expression
-;;       | 'symbol                         a symbol (special case of s-expr)
-;;       | (lvp_1 ... lvp_n)               list of n elements
-;;       | (pat ... pat_n . pat_{n+1})           list of n or more
-;;       | #(lvp_1 ... lvp_n)              vector of n elements
-;;       | #&pat                           box
-;;       | ($ struct-name pat_1 ... pat_n) a structure
-;;       | (= field pat)                   a field of a structure (field is 
-;;                                         an accessor)
-;;                                         Actually field can be any function 
-;;                                         which can be
-;;                                         applied to the data being matched.
-;;                                         Ex: (match 5 ((= add1 b) b)) => 6
-;;
-;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
-;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
-;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
-;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
-;;                                           pat_1 thru pat_n match
-;;       | (set! identifier)               anything, and binds setter
-;;       | (get! identifier)               anything, and binds getter
-;;       | `qp                             a quasi-pattern
-;;
-;; lvp ::= pat ooo                         greedily matches n or more of pat, 
-;;                                         each element must match pat
-;;       | pat                             matches pat
-;;
-;; ooo ::= ...                             zero or more
-;;       | ___                             zero or more
-;;       | ..k                             k or more
-;;       | __k                             k or more
-;;
-;;         quasi-patterns:                 matches:
-;;
-;; qp  ::= ()                              the empty list
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | identifier                      a symbol
-;;       | (qp_1 ... qp_n)                 list of n elements
-;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
-;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #(qp_1 ... qp_n)                vector of n elements
-;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #&qp                            box
-;;       | ,pat                            a pattern
-;;       | ,@(lvp . . . lvp-n)
-;;       | ,@(pat . . . pat_n . pat_{n+1})
-;;       | ,@`qp                           qp must evaluate to a list as 
-;;                                         so that this rule resembles the 
-;;                                         above two rules
-;;
-;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
-;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___) 
-;; cannot be used as pattern variables.
-;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(module match mzscheme - (provide - match - match-lambda - match-lambda* - match-let - match-let* - match-letrec - match-define - match-equality-test - exn:misc:match? - exn:misc:match-value - define-match-expander) - - ;; FIXME: match-helper and match-error should each be split - ;; into a compile-time part and a run-time part. - - (require-for-syntax "private/match/convert-pat.ss" - "private/match/match-helper.ss") - - (require-for-template mzscheme) - - (require (prefix plt: "private/match/match-internal-func.ss") - "private/match/match-expander.ss" - "private/match/match-helper.ss" - "private/match/match-error.ss" - "private/match/test-no-order.ss") - - (define-syntax match-definer - (syntax-rules () - [(match-definer name clauses ...) - (define-syntax (name stx) - (md-help syntax stx - (syntax-case stx () - clauses ...)))])) - - (match-definer match-lambda - [(k clause ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match-lambda new-clauses ...))]) - - (match-definer match-lambda* - [(k clause ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match-lambda* new-clauses ...))]) - - (match-definer match-let - [(k name (clauses ...) body ...) - (identifier? (syntax name)) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let name (new-clauses ...) body ...))] - [(k (clauses ...) body ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let (new-clauses ...) body ...))]) - - (match-definer match-let* - [(k (clauses ...) body ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let* (new-clauses ...) body ...))]) - - (match-definer match - [(_ exp clause ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match exp new-clauses ...))]) - - - (match-definer match-letrec - [(k (clauses ...) body ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-letrec (new-clauses ...) body ...))]) - - - (match-definer match-define - [(k pat exp) - (with-syntax ([new-pat (convert-pat #'pat)]) - #'(plt:match-define new-pat exp))]) - - - - ) - +#lang scheme/base +(require scheme/match/legacy-match) +(provide (all-from-out scheme/match/legacy-match)) \ No newline at end of file diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss index 4dceb09d48..fa392175b3 100644 --- a/collects/mzlib/plt-match.ss +++ b/collects/mzlib/plt-match.ss @@ -1,157 +1,4 @@ -;; (documentation (name plt-match)) -;; 
Pattern Matching Syntactic Extensions for Scheme
-;;
-;; All bugs or questions concerning this software should be directed to
-;; Bruce Hauman .  The latest version of this software
-;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
-;;
-;; Special thanks go out to:
-;; Robert Bruce Findler for support and bug detection.
-;; Doug Orleans for pointing out that pairs should be reused while
-;; matching lists.
-;;
-;;
-;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
-;; which in turn was adapted from code written by Bruce F. Duba, 1991.
-;;
-;; This software is in the public domain.  Feel free to copy,
-;; distribute, and modify this software as desired.  No warranties
-;; nor guarantees of any kind apply.  Please return any improvements
-;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
-;; in future releases.
-;;
-;; This macro package extends Scheme with several new expression forms.
-;; Following is a brief summary of the new forms.  See the associated
-;; LaTeX documentation for a full description of their functionality.
-;;
-;;
-;;         match expressions:
-;;
-;; exp ::= ...
-;;       | (match exp clause ...)
-;;       | (match-lambda clause ...) 
-;;       | (match-lambda* clause ...)
-;;       | (match-let ((pat exp) ...) body ...)
-;;       | (match-let var ((pat exp) ...) body ...)
-;;       | (match-let* ((pat exp) ...) body ...)
-;;       | (match-letrec ((pat exp) ...) body ...)
-;;       | (match-define pat exp)
-;;
-;; clause ::= (pat body) | (pat (=> identifier) exp)
-;;
-;;         patterns:                       matches:
-;;
-;; pat ::= 
-;;         identifier                      this binds an identifier if it 
-;;                                         doesn't conflict with ..k, __k or _
-;;       | _                               anything
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | 'sexp                           an s-expression
-;;       | 'symbol                         a symbol (special case of s-expr)
-;;       | (var id)                        allows one to use ..k or _ as 
-;;                                         identifiers
-;;       | (list lvp_1 ... lvp_n)               list of n elements
-;;       | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements
-;;                                         plus a last element which represents
-;;                                         the last cdr of the list
-;;       | (vector lvp_1 ... lvp_n)        vector of n elements
-;;       | (box pat)                       box
-;;       | (struct struct-name (pat_1 ... pat_n)) a structure
-;;       | (regexp exp)                     if regular expression exp matches
-;;       | (regexp exp pat)                 if result of regexp-match matches pat
-;;       | (pregexp exp)                    if pregexp.ss regular expression exp matches
-;;       | (pregexp exp pat)                if result of pregexp-match matches pat
-;;       | (list-no-order pat ...)         matches a list with no regard for 
-;;                                         the order of the
-;;                                         items in the list
-;;       | (list-no-order pat ... pat_n ooo) pat_n matches the remaining 
-;;                                           unmatched items
-;;       | (hash-table (pat_k pat_v) ...)  matches the elements of a hash table
-;;       | (hash-table (pat_k pat_v) ... (pat_kn pat_vn) ooo)  
-;;                                         pat_kn must match the remaining 
-;;                                         unmatched key elements
-;;                                         pat_vn must match the remaining 
-;;                                         unmatched value elements
-;;       | (app field pat)                 a field of a structure (field is 
-;;                                         an accessor)
-;;                                         Actually field can be any function 
-;;                                         which can be
-;;                                         applied to the data being matched.
-;;                                         Ex: (match 5 ((= add1 b) b)) => 6
-;;
-;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
-;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
-;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
-;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
-;;                                           pat_1 thru pat_n match
-;;       | (set! identifier)               anything, and binds setter
-;;       | (get! identifier)               anything, and binds getter
-;;       | `qp                             a quasi-pattern
-;;
-;; lvp ::= pat ooo                         greedily matches n or more of pat, 
-;;                                         each element must match pat
-;;       | pat                             matches pat
-;;
-;; ooo ::= ...                             zero or more
-;;       | ___                             zero or more
-;;       | ..k                             k or more
-;;       | __k                             k or more
-;;
-;;         quasi-patterns:                 matches:
-;;
-;; qp  ::= ()                              the empty list
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | identifier                      a symbol
-;;       | (qp_1 ... qp_n)                 list of n elements
-;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
-;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #(qp_1 ... qp_n)                vector of n elements
-;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #&qp                            box
-;;       | ,pat                            a pattern
-;;       | ,@(list lvp . . . lvp-n)
-;;       | ,@(list-rest lvp-1 . . . lvp-n pat)
-;;       | ,@`qp                           qp must evaluate to a list as 
-;;                                         so that this rule resembles the 
-;;                                         above two rules
-;;
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 
-
-(module plt-match mzscheme
-  (provide 
-   match
-   match-lambda
-   match-lambda*
-   match-let
-   match-let*
-   match-letrec
-   match-define
-   pregexp-match-with-error
-   exn:misc:match?
-   exn:misc:match-value
-   match-equality-test
-   define-match-expander) 
-  
-  (require "private/match/match-internal-func.ss"
-           "private/match/match-expander.ss"
-           "private/match/match-helper.ss"
-           "private/match/match-error.ss"
-	   "private/match/test-no-order.ss")
-  
-  )
-
-
-
+#lang scheme/base
 
+(require scheme/match/match)
+(provide (all-from-out scheme/match/match))
\ No newline at end of file
diff --git a/collects/scheme/match.ss b/collects/scheme/match.ss
index 7d7f8f02a3..e5407b47f4 100644
--- a/collects/scheme/match.ss
+++ b/collects/scheme/match.ss
@@ -1,8 +1,8 @@
 
 (module match scheme/base
-  (require mzlib/plt-match
+  (require scheme/match/match
            (for-syntax scheme/base))
-  (provide (except-out (all-from-out mzlib/plt-match)
+  (provide (except-out (all-from-out scheme/match/match)
                        define-match-expander)
            (rename-out [define-match-expander* define-match-expander]))
 
diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss
new file mode 100644
index 0000000000..d07523f194
--- /dev/null
+++ b/collects/scheme/match/compiler.ss
@@ -0,0 +1,433 @@
+#lang scheme/base
+
+(require (for-template scheme/base "patterns.ss" scheme/stxparam)
+         mzlib/trace
+         mzlib/etc
+         syntax/boundmap
+         syntax/stx
+         "patterns.ss"
+         "split-rows.ss"
+         scheme/struct-info
+         scheme/stxparam
+         (only-in srfi/1 delete-duplicates))
+
+(provide compile*)
+
+;; for non-linear patterns
+(define vars-seen (make-parameter null))
+
+(define (hash-on f elems #:equal? [eql #t])
+  (define ht (apply make-hash-table (if eql (list 'equal) null)))
+  ;; put all the elements e in the ht, indexed by (f e)
+  (for-each (lambda (r)
+              (define k (f r))
+              (hash-table-put! ht k (cons r (hash-table-get ht k (lambda () null)))))
+            ;; they need to be in the original order when they come out
+            (reverse elems))
+  ht)
+
+;; generate a clause of kind k
+;; for rows rows, with matched variable x and rest variable xs
+;; escaping to esc
+(define (gen-clause k rows x xs esc)
+  (define-syntax-rule (constant-pat predicate-stx)
+    (with-syntax 
+        ([rhs
+          (compile* (cons x xs)
+                    (map (lambda (row)
+                           (define-values (p ps) (Row-split-pats row))
+                           (define p* (Atom-p p))
+                           (make-Row (cons p* ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                         rows)
+                    esc)])
+      #`[(#,predicate-stx #,x) rhs]))
+  (cond
+    [(eq? 'box k) 
+     (with-syntax ([(v) (generate-temporaries #'(v))])
+       (with-syntax
+           ([body (compile* 
+                   (cons #'v xs)
+                   (map (lambda (r)
+                          (define-values (p1 ps) (Row-split-pats r))
+                          (make-Row (cons (Box-p p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
+                        rows)
+                   esc)])
+         #`[(box? #,x)
+            (let ([v (unbox #,x)])
+              body)]))]
+    [(eq? 'pair k)
+     (with-syntax ([(v1 v2) (generate-temporaries #'(v1 v2))])
+       (with-syntax
+           ([body (compile*
+                   (list* #'v1 #'v2 xs)
+                   (map (lambda (r)
+                          (define-values (p1 ps) (Row-split-pats r))
+                          (make-Row (list* (Pair-a p1) (Pair-d p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
+                        rows)
+                   esc)])
+         #`[(pair? #,x)
+            (let ([v1 (car #,x)]
+                  [v2 (cdr #,x)])
+              body)]))]
+    [(eq? 'string k)  (constant-pat #'string?)]
+    [(eq? 'number k)  (constant-pat #'number?)]
+    [(eq? 'symbol k)  (constant-pat #'symbol?)]
+    [(eq? 'keyword k) (constant-pat #'keyword?)]
+    [(eq? 'char k)    (constant-pat #'char?)]
+    [(eq? 'bytes k)   (constant-pat #'bytes?)]
+    [(eq? 'regexp k)  (constant-pat #'regexp?)]
+    [(eq? 'boolean k) (constant-pat #'boolean?)]
+    [(eq? 'null k)    (constant-pat #'null?)]
+    [(eq? 'vector k)
+     (let ()
+       (define ht (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
+       (with-syntax ([(clauses ...)
+                      (hash-table-map 
+                       ht
+                       (lambda (arity rows)
+                         (define ns (build-list arity values))
+                         (with-syntax ([(tmps ...) (generate-temporaries ns)])
+                           (with-syntax
+                               ([body (compile* (append (syntax->list #'(tmps ...)) xs)
+                                                (map (lambda (row)
+                                                       (define-values (p1 ps) (Row-split-pats row))
+                                                       (make-Row (append (Vector-ps p1) ps) 
+                                                                 (Row-rhs row)
+                                                                 (Row-unmatch row)
+                                                                 (Row-vars-seen row)))
+                                                     rows)
+                                                esc)]
+                                [(n ...) ns])
+                             #`[(#,arity) 
+                                (let ([tmps (vector-ref #,x n)] ...)
+                                  body)]))))])
+         #`[(vector? #,x)
+            (case (vector-length #,x)
+              clauses ...)]))]    
+    ;; it's a structure
+    [(box? k)     
+     ;; all the rows are structures with the same predicate
+     (let* ([s (Row-first-pat (car rows))]
+            [accs (Struct-accessors s)]
+            [pred (Struct-pred s)])
+       (with-syntax ([(tmps ...) (generate-temporaries accs)])
+         (with-syntax ([(accs ...) accs]
+                       [pred pred]
+                       [body (compile*
+                              (append (syntax->list #'(tmps ...)) xs)
+                              (map (lambda (row)
+                                     (define-values (p1 ps) (Row-split-pats row))
+                                     (make-Row (append (Struct-ps p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                                   rows)
+                              esc)])
+           #`[(pred #,x)
+              (let ([tmps (accs #,x)] ...)
+                body)])))]
+    [else (error 'compile "bad key: ~a" k)]))
+
+;; produces the syntax for a let clause
+(define (compile-one vars block esc)
+  (define-values (first rest-pats) (Row-split-pats (car block)))
+  (define x (car vars))
+  (define xs (cdr vars))
+  (cond 
+    ;; the Exact rule
+    [(Exact? first)
+     (let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)])
+       (with-syntax ([(clauses ...) (hash-table-map 
+                                     ht 
+                                     (lambda (k v)
+                                       #`[(equal? #,x '#,k) 
+                                          #,(compile* xs
+                                                      (map (lambda (row)                                                             
+                                                             (make-Row (cdr (Row-pats row))
+                                                                       (Row-rhs row)
+                                                                       (Row-unmatch row)
+                                                                       (Row-vars-seen row)))
+                                                           v)
+                                                      esc)]))])
+         #`(cond clauses ... [else (#,esc)])))]
+    ;; the Var rule
+    [(Var? first)
+     (let ([transform (lambda (row)
+                        (define-values (p ps) (Row-split-pats row))
+                        (define v (Var-v p))
+                        (define seen (Row-vars-seen row))
+                        ;; a new row with the rest of the patterns
+                        (cond 
+                          ;; if this was a wild-card variable, don't bind                                      
+                          [(Dummy? p) (make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))]
+                          ;; if we've seen this variable before, check that it's equal to the one we saw
+                          [(ormap (lambda (e) 
+                                    (let ([v* (car e)]
+                                          [id (cdr e)])
+                                      (and (bound-identifier=? v v*) id)))
+                                  seen)
+                           =>
+                           (lambda (id)
+                             (make-Row ps
+                                       #`(if ((match-equality-test) #,x #,id)
+                                             #,(Row-rhs row)
+                                             (fail))
+                                       (Row-unmatch row)
+                                       seen))]
+                          ;;otherwise, bind the matched variable to x, and add it to the list of vars we've seen
+                          [else (make-Row ps
+                                          #`(let ([#,v #,x]) #,(Row-rhs row))
+                                          (Row-unmatch row)
+                                          (cons (cons v x) (Row-vars-seen row)))]))])
+       ;; compile the transformed block
+       (compile* xs (map transform block) esc))]
+    ;; the Constructor rule
+    [(CPat? first)
+     (let ;; put all the rows in the hash-table, indexed by their constructor
+         ([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
+       (with-syntax ([(clauses ...) (hash-table-map ht (lambda (k v) (gen-clause k v x xs esc)))])
+         #`(cond clauses ... [else (#,esc)])))]
+    ;; the Or rule
+    [(Or? first)
+     ;; we only handle 1-row Ors atm - this is all the mixture rule should give us
+     (unless (null? (cdr block))
+       (error 'compile-one "Or block with multiple rows: ~a" block))
+     (let* ([row (car block)]
+            [pats (Row-pats row)]
+            ;; all the pattern alternatives
+            [qs (Or-ps (car pats))]
+            ;; the variables bound by this pattern - they're the same for the whole list
+            [vars (bound-vars (car qs))])
+       (with-syntax ([vars vars])
+         ;; do the or matching, and bind the results to the appropriate variables
+         #`(let/ec exit
+             (let ([esc* (lambda () (exit (#,esc)))])
+               (let-values ([vars #,(compile* (list x) (map (lambda (q) (make-Row (list q) #'(values . vars) #f (Row-vars-seen row)))
+                                                            qs)
+                                              #'esc*)])
+                 ;; then compile the rest of the row
+                 #,(compile* xs 
+                             (list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row) 
+                                             (let ([vs (syntax->list #'vars)])
+                                               (append (map cons vs vs) (Row-vars-seen row)))))
+                             esc))))))]
+    ;; the App rule
+    [(App? first)
+     ;; we only handle 1-row Apps atm - this is all the mixture rule should give us
+     (unless (null? (cdr block))
+       (error 'compile-one "App block with multiple rows: ~a" block))
+     (let* ([row (car block)]
+            [pats (Row-pats row)])
+       (with-syntax ([(t) (generate-temporaries #'(t))])
+         #`(let ([t (#,(App-expr first) #,x)])
+             #,(compile* (cons #'t xs)
+                         (list (make-Row (cons (App-p first) (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                         esc))))]
+    ;; the And rule
+    [(And? first)
+     ;; we only handle 1-row Ands atm - this is all the mixture rule should give us
+     (unless (null? (cdr block))
+       (error 'compile-one "And block with multiple rows: ~a" block))
+     (let* ([row (car block)]
+            [pats (Row-pats row)]
+            ;; all the patterns
+            [qs (And-ps (car pats))])
+       (compile* (append (map (lambda _ x) qs) xs)
+                 (list (make-Row (append qs (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                 esc))]
+    ;; the Not rule
+    [(Not? first)
+     ;; we only handle 1-row Nots atm - this is all the mixture rule should give us
+     (unless (null? (cdr block))
+       (error 'compile-one "Not block with multiple rows: ~a" block))
+     (let* ([row (car block)]
+            [pats (Row-pats row)]
+            ;; the single pattern
+            [q (Not-p (car pats))])
+       (with-syntax ([(f) (generate-temporaries #'(f))])
+         #`(let
+               ;; if q fails, we jump to here
+               ([f (lambda ()
+                     #,(compile* xs
+                                 (list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                               esc))])
+             #,(compile* (list x)
+                         ;; if q doesn't fail, we jump to esc and fail the not pattern
+                         (list (make-Row (list q) #`(#,esc) (Row-unmatch row) (Row-vars-seen row)))
+                         #'f))))]
+     [(Pred? first)
+      ;; multiple preds iff they have the identical predicate     
+     (with-syntax ([pred? (Pred-pred first)]
+                   [body (compile* xs
+                                   (map (lambda (row)
+                                          (define-values (_1 ps) (Row-split-pats row))
+                                          (make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                                        block)
+                                   esc)])
+       #`(cond [(pred? #,x) body] [else (#,esc)]))]
+     ;; Generalized sequences... slightly tested
+    [(GSeq? first)
+     (let* ([headss (GSeq-headss first)]
+            [mins (GSeq-mins first)]
+            [maxs (GSeq-maxs first)]
+            [onces? (GSeq-onces? first)]
+            [tail (GSeq-tail first)]
+            [k (Row-rhs (car block))]
+            [xvar (car (generate-temporaries (list #'x)))]
+            [complete-heads-pattern
+             (lambda (ps)
+               (define (loop ps pat)
+                 (if (pair? ps)
+                     (make-Pair (car ps)
+                                (loop (cdr ps) pat))
+                     pat))
+               (loop ps (make-Var xvar)))]
+            [heads
+             (for/list ([ps headss])
+               (complete-heads-pattern ps))]
+            [head-idss
+             (for/list ([heads headss])
+               (apply append (map bound-vars heads)))]
+            [hid-argss (map generate-temporaries head-idss)]
+            [hid-args (apply append hid-argss)]
+            [reps (generate-temporaries (for/list ([head heads]) 'rep))])
+       (with-syntax ([x xvar]
+                     [var0 (car vars)]
+                     [((hid ...) ...) head-idss]
+                     [((hid-arg ...) ...) hid-argss]
+                     [(rep ...) reps]
+                     [(maxrepconstraint ...)
+                      ;; FIXME: move to side condition to appropriate pattern
+                      (for/list ([repvar reps] [maxrep maxs])
+                        (if maxrep
+                            #`(< #,repvar #,maxrep)
+                            #`#t))]
+                     [(minrepclause ...)
+                      (for/list ([repvar reps] [minrep mins] #:when minrep)
+                        #`[(< #,repvar #,minrep)
+                           (fail)])]
+                     [((hid-rhs ...) ...)
+                      (for/list ([hid-args hid-argss] [once? onces?])
+                                (for/list ([hid-arg hid-args])
+                                          (if once?
+                                              #`(car (reverse #,hid-arg))
+                                              #`(reverse #,hid-arg))))]
+                     [(parse-loop failkv fail-tail) (generate-temporaries #'(parse-loop failkv fail-tail))])
+         (with-syntax ([(rhs ...)
+                        #`[(let ([hid-arg (cons hid hid-arg)] ...)
+                             (if maxrepconstraint
+                                 (let ([rep (add1 rep)])
+                                   (parse-loop x #,@hid-args #,@reps fail))
+                                 (begin
+                                   (fail))))
+                           ...]]
+                       [tail-rhs
+                        #`(cond minrepclause ...
+                                [else
+                                 (let ([hid hid-rhs] ... ...
+                                       [fail-tail fail])
+                                   #,(compile* (cdr vars) 
+                                               (list (make-Row rest-pats k (Row-unmatch (car block)) (Row-vars-seen (car block))))
+                                               #'fail-tail))])])
+           #`(let parse-loop ([x var0] [hid-arg null] ... ... [rep 0] ... [failkv #,esc])
+               #,(compile* (list #'x)
+                             (append
+                              (map (lambda (pats rhs) (make-Row pats rhs (Row-unmatch (car block)) null))
+                                   (map list heads)
+                                   (syntax->list #'(rhs ...)))
+                              (list (make-Row (list tail) #`tail-rhs (Row-unmatch (car block)) null)))
+                             #'failkv)))))]
+    ;; doesn't work, never called
+    #;
+     [(VectorSeq? first)
+     (let*-values ([(row) (car block)]
+                   [(p ps) (Row-split-pats row)]
+                   [(head) (VectorSeq-p p)]
+                   [(start) (VectorSeq-start p)]
+                   [(expr) (Row-rhs row)]
+                   [(count) (VectorSeq-count p)]
+                   [(head-vars) (bound-vars head)])
+       (with-syntax ([var0 (car vars)]
+                     [(x) (generate-temporaries #'(x))]
+                     [(hid ...) head-vars]
+                     [(hid-arg ...) (generate-temporaries head-vars)]
+                     [(parse-k parse-loop head-var tail-var fail reps len)
+                      (generate-temporaries
+                       #'(parse-k parse-loop head-var tail-var fail reps len))])
+         #`(if (vector? var0)
+               (let ([len (vector-length var0)])
+                 (define (parse-k hid ...)
+                   #,(compile* xs
+                               (list (make-Row ps expr))
+                               esc))                 
+                 (define (parse-loop reps hid-arg ...)
+                   (define (fail)
+                     (parse-k (reverse hid-arg) ...))
+                   (if (and 
+                        (< reps len)
+                        #,@(if (number? count)
+                               #`((reps . < . '#,(+ start count)))
+                               #'()))
+                       (let ([head-var (vector-ref var0 reps)])
+                         #,(compile*
+                            (list #'head-var)
+                            (list
+                             (make-Row (list head)
+                                       #`(parse-loop (add1 reps)
+                                                     (cons hid hid-arg) ...)))
+                            #'fail))
+                       (fail)))
+                 (let ([hid null] ...)
+                   (parse-loop #,start hid ...)))
+                 (#,esc))))]
+     [else (error 'compile "unsupported pattern: ~a~n" first)]))
+
+(define (compile* vars rows esc)
+  (define (let/wrap clauses body)
+    (if (stx-null? clauses) 
+        body
+        (quasisyntax (let* #,clauses #,body))))
+  (if (null? vars)
+      ;; if we have no variables, there are no more patterns to match
+      ;; so we just pick the first RHS
+      (let ([fns
+             (let loop ([blocks (reverse rows)] [esc esc] [acc null])
+               (cond
+                 ;; if we're done, return the blocks
+                 [(null? blocks) (reverse acc)]
+                 [else (with-syntax (;; f is the name this block will have
+                                     [(f) (generate-temporaries #'(f))]
+                                     ;; compile the block, with jumps to the previous esc
+                                     [c (with-syntax ([rhs #`(syntax-parameterize ([fail (make-rename-transformer (quote-syntax #,esc))])
+                                                                                  #,(Row-rhs (car blocks)))])
+                                          (if 
+                                           (Row-unmatch (car blocks))
+                                           #`(let/ec k
+                                               (let ([#,(Row-unmatch (car blocks)) (lambda () (k (#,esc)))])
+                                                 rhs))
+                                           #'rhs))])
+                         ;; then compile the rest, with our name as the esc
+                         (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))])
+        (with-syntax ([(fns ... [_ (lambda () body)]) fns])
+          (let/wrap #'(fns ...) #'body)))
+      
+      ;; otherwise, we split the matrix into blocks
+      ;; and compile each block with a reference to its continuation
+      (let ([fns
+             (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])                      
+               (cond 
+                 ;; if we're done, return the blocks
+                 [(null? blocks) (reverse acc)]
+                 [else (with-syntax (;; f is the name this block will have
+                                     [(f) (generate-temporaries #'(f))]
+                                     ;; compile the block, with jumps to the previous esc
+                                     [c (compile-one vars (car blocks) esc)])
+                         ;; then compile the rest, with our name as the esc
+                         (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))])
+        (with-syntax ([(fns ... [_ (lambda () body)]) fns])
+          (let/wrap #'(fns ...) #'body)))))
+
+
+
+
+
+
+
+;(trace compile* compile-one)
diff --git a/collects/scheme/match/define-forms.ss b/collects/scheme/match/define-forms.ss
new file mode 100644
index 0000000000..d1967c5845
--- /dev/null
+++ b/collects/scheme/match/define-forms.ss
@@ -0,0 +1,116 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base
+                     "parse.ss"
+                     "parse-helper.ss"
+                     "patterns.ss"
+                     "gen-match.ss"))
+
+(provide define-forms)
+
+(define-syntax-rule (define-forms parse-id 
+                      match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
+  (...
+   (begin
+     (provide match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
+     (define-syntax (match* stx)
+       (syntax-case stx ()
+         [(_ es . clauses)
+          (go parse-id stx #'es #'clauses (syntax-local-certifier))]))
+     
+     (define-syntax-rule (match arg [p . es] ...)
+       (match* (arg)
+               [(p) . es]
+               ...))     
+     
+     
+     (define-syntax (match-lambda stx)
+       (syntax-case stx ()
+         [(k . clauses)
+          (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
+     
+     (define-syntax (match-lambda* stx)
+       (syntax-case stx ()
+         [(k . clauses)
+          (syntax/loc stx (lambda exp (match exp . clauses)))]))
+     
+     (define-syntax (match-lambda** stx)
+       (syntax-case stx ()
+         [(k [(pats ...) . rhs] ...)
+          (let* ([pss (syntax->list #'((pats ...) ...))]
+                 [len (length (syntax->list (car pss)))])
+            (for/list ([ps pss])
+                      (unless (= (length (syntax->list ps)) len)
+                        (raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps)))
+            (with-syntax ([(vars ...) (generate-temporaries (car pss))])
+              (syntax/loc stx (lambda (vars ...) (match* (vars ...) [(pats ...) . rhs] ...)))))]))
+     
+     
+     
+     ;; there's lots of duplication here to handle named let
+     ;; some factoring out would do a lot of good
+     (define-syntax (match-let stx)
+       (syntax-case stx ()
+         ;; an empty body is an error
+         [(_ nm (clauses ...))
+          (identifier? #'nm)
+          (match:syntax-err stx "bad syntax (empty body)")]
+         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+         ;; with no bindings, there's nothing to do
+         [(_ name () body ...) 
+          (identifier? #'name)
+          (syntax/loc stx (let name () body ...))]
+         [(_ () body ...) (syntax/loc stx (let () body ...))]
+         ;; optimize the all-variable case            
+         [(_ ([pat exp]...) body ...)
+          (andmap pattern-var? (syntax->list #'(pat ...)))
+          (syntax/loc stx (let name ([pat exp] ...) body ...))]          
+         [(_ name ([pat exp]...) body ...)
+          (and (identifier? (syntax name))
+               (andmap pattern-var? (syntax->list #'(pat ...))))
+          (syntax/loc stx (let name ([pat exp] ...) body ...))]
+         ;; now the real cases
+         [(_ name ([pat exp] ...) . body)
+          (syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))]) 
+                            (name exp ...)))]
+         [(_ ([pat exp] ...) . body)
+          (syntax/loc stx (match* (exp ...) [(pat ...) . body]))]))
+     
+     (define-syntax (match-let* stx)
+       (syntax-case stx ()
+         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+         ((_ () body ...)
+          (syntax/loc stx (let* () body ...)))
+         ((_ ([pat exp] rest ...) body ...)
+          (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)])))
+         ))
+     
+     
+     
+     (define-syntax (match-letrec stx)
+       (syntax-case stx ()
+         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+         [(_ ([pat exp] ...) . body)
+          (andmap pattern-var?
+                  (syntax->list #'(pat ...)))
+          (syntax/loc stx (letrec ([pat exp] ...) . body))]
+         [(_ ([pat exp] ...) . body)
+          (syntax/loc stx (let ()
+                            (match-define pat exp) ...
+                            . body))]))
+     
+     
+     
+     (define-syntax (match-define stx)
+       (syntax-case stx ()
+         [(_ pat exp)
+          (pattern-var? #'pat)
+          (syntax/loc stx (define pat exp))]
+         [(_ pat rhs)
+          ;; FIXME - calls parse twice
+          (let ([p (parse-id #'pat (syntax-local-certifier))])
+            (with-syntax ([vars (bound-vars p)])
+              (syntax/loc stx
+                (define-values vars
+                  (match rhs
+                    [pat (values . vars)])))))])))))
\ No newline at end of file
diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss
new file mode 100644
index 0000000000..c9b2e4f92b
--- /dev/null
+++ b/collects/scheme/match/gen-match.ss
@@ -0,0 +1,45 @@
+#lang scheme/base
+
+(require "patterns.ss" "compiler.ss"
+         syntax/stx
+         (for-template scheme/base (only-in "patterns.ss" match:error)))
+
+(provide go)
+
+;; this parses the clauses using parse/cert, then compiles them
+;; go : syntax syntax syntax certifier -> syntax
+(define (go parse/cert stx exprs clauses cert)
+  (syntax-case clauses ()
+    [([pats . rhs] ...)
+     (let ([len (length (syntax->list exprs))])
+       (with-syntax ([(xs ...) (generate-temporaries exprs)]
+                     [(exprs ...) exprs]
+                     [(fail) (generate-temporaries #'(fail))])
+         (with-syntax ([body (compile* (syntax->list #'(xs ...))
+                                       (map (lambda (pats rhs)
+                                              (unless (= len (length (syntax->list pats)))
+                                                (raise-syntax-error 'match 
+                                                                    (format "wrong number of match clauses, expected ~a and got ~a" 
+                                                                            len (length (syntax->list pats)))
+                                                                    pats))
+                                              (syntax-case* rhs (=>)
+                                                (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
+                                                [((=> unm) . rhs)
+                                                 (make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats))
+                                                           #`(begin . rhs) 
+                                                           #'unm
+                                                           null)]
+                                                [_
+                                                 (make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats))
+                                                           #`(begin . #,rhs)
+                                                           #f
+                                                           null)]))
+                                            (syntax->list #'(pats ...))
+                                            (syntax->list #'(rhs ...)))
+                                       #'fail)]
+                       [orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))])
+           (quasisyntax/loc stx
+             (let ([xs exprs]
+                   ...)
+               (let ([fail (lambda () #,(syntax/loc stx (match:error orig-expr)))])
+                 body))))))]))
\ No newline at end of file
diff --git a/collects/scheme/match/legacy-match.ss b/collects/scheme/match/legacy-match.ss
new file mode 100644
index 0000000000..2b58962124
--- /dev/null
+++ b/collects/scheme/match/legacy-match.ss
@@ -0,0 +1,12 @@
+#lang scheme/base
+
+(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?)
+         (only-in "match-expander.ss" define-match-expander)
+         "define-forms.ss"
+         (for-syntax "parse-legacy.ss" "gen-match.ss")
+         (for-syntax (only-in "patterns.ss" match-...-nesting)))
+
+(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?)
+
+(define-forms parse/legacy/cert
+  match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
\ No newline at end of file
diff --git a/collects/scheme/match/match-expander.ss b/collects/scheme/match/match-expander.ss
new file mode 100644
index 0000000000..2dffbe66b5
--- /dev/null
+++ b/collects/scheme/match/match-expander.ss
@@ -0,0 +1,61 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base)
+         (for-syntax "patterns.ss"))
+
+(provide define-match-expander)
+
+(define-syntax (define-match-expander stx)
+  (define (lookup v alist)
+    (cond [(assoc v alist) => cadr]
+          [else #f]))
+  (define (parse args)
+    (let loop ([args args]
+               [alist '()])
+      (if (null? args) 
+          alist
+          (let* ([stx-v (car args)]
+                 [v (syntax-e stx-v)])
+            (cond
+              [(not (keyword? v))
+               (raise-syntax-error #f "Argument must be a keyword" stx stx-v)]
+              [(not (memq v '(#:expression #:plt-match #:match)))
+               (raise-syntax-error #f (format "Keyword argument ~a is not a correct keyword" v) stx stx-v)]
+              [else                
+               (loop (cddr args)
+                     (cons (list v (cadr args))
+                           alist))])))))
+  (syntax-case stx ()
+    [(_ id kw . rest)
+     (keyword? (syntax-e #'kw))
+     (let* ([args (syntax->list #'(kw . rest))]
+            [parsed-args (parse args)])
+       (with-syntax
+           ([legacy-xform (lookup '#:match parsed-args)]
+            [match-xform (lookup '#:plt-match parsed-args)]
+            [macro-xform (or (lookup '#:expression parsed-args)
+                             #'(lambda (stx)
+                                 (raise-syntax-error #f "This match expander must be used inside match" stx)))])
+         (if (identifier? #'macro-xform)
+             (syntax/loc stx
+               (define-syntax id (make-match-expander match-xform
+                                                      legacy-xform
+                                                      (lambda (stx)
+                                                        (syntax-case stx (set!)
+                                                          [(nm args (... ...)) #'(macro-xform args (... ...))]
+                                                          [nm #'macro-xform]))
+                                                      (syntax-local-certifier))))
+             (syntax/loc stx 
+               (define-syntax id (make-match-expander match-xform legacy-xform macro-xform (syntax-local-certifier)))))))]
+    
+    ;; implement legacy syntax
+    [(_ id plt-match-xform match-xform std-xform)
+     #'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)]
+    [(_ id plt-match-xform std-xform)
+     #'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
+    [(_ id plt-match-xform) 
+     #'(define-match-expander id #:plt-match plt-match-xform)]
+    
+    ;; error checking
+    [_ (raise-syntax-error #f "Invalid use of define-match-expander" stx)]
+    ))
\ No newline at end of file
diff --git a/collects/scheme/match/match.ss b/collects/scheme/match/match.ss
new file mode 100644
index 0000000000..52ceb9567a
--- /dev/null
+++ b/collects/scheme/match/match.ss
@@ -0,0 +1,12 @@
+#lang scheme/base
+
+(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?)
+         (only-in "match-expander.ss" define-match-expander)
+         "define-forms.ss"
+         (for-syntax "parse.ss" "gen-match.ss")
+         (for-syntax (only-in "patterns.ss" match-...-nesting)))
+
+(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?)
+
+(define-forms parse/cert
+  match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
\ No newline at end of file
diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss
new file mode 100644
index 0000000000..d41d63bcbe
--- /dev/null
+++ b/collects/scheme/match/parse-helper.ss
@@ -0,0 +1,85 @@
+#lang scheme/base
+
+(require (for-template scheme/base)
+         syntax/boundmap
+         syntax/stx
+         scheme/struct-info
+         "patterns.ss"
+         "compiler.ss"
+         (only-in srfi/1 delete-duplicates))
+
+(provide ddk? parse-literal all-vars pattern-var? match:syntax-err)
+
+
+
+;; raise an error, blaming stx
+(define (match:syntax-err stx msg)
+  (raise-syntax-error #f msg stx))
+
+;; pattern-var? : syntax -> bool
+;; is p an identifier representing a pattern variable?
+(define (pattern-var? p)
+  (and (identifier? p)
+       (not (ddk? p))))
+
+;; ddk? : syntax -> number or boolean
+;; if #f is returned, was not a ddk identifier
+;; if #t is returned, no minimum
+;; if a number is returned, that's the minimum
+(define (ddk? s*)
+  (define (./_ c)
+    (or (equal? c #\.)
+        (equal? c #\_)))
+  (let ([s (syntax->datum s*)])
+    (and (symbol? s)
+         (if (memq s '(... ___)) #t
+             (let* ((s (symbol->string s)))                    
+               (and (3 . <= . (string-length s))
+                    (./_ (string-ref s 0))
+                    (./_ (string-ref s 1))                    
+                    (let ([n (string->number (substring s 2))])
+                      (cond 
+                        [(not n) #f]
+                        [(zero? n) #t]
+                        [(exact-nonnegative-integer? n) n]
+                        [else (raise-syntax-error 'match "invalid number for ..k pattern" s*)]))))))))
+
+
+;; parse-literal : scheme-val -> pat option
+;; is v is a literal, return a pattern matching it
+;; otherwise, return #f
+(define (parse-literal v)
+  (if (or (number? v) 
+          (string? v) 
+          (keyword? v)
+          (symbol? v) 
+          (bytes? v) 
+          (regexp? v)
+          (boolean? v)
+          (char? v))
+      (make-Exact v)
+      #f))
+
+;; (listof pat) syntax -> void
+;; check that all the ps bind the same set of variables
+(define (all-vars ps stx)
+  (when (null? ps)
+    (error 'bad))
+  (let* ([first-vars (bound-vars (car ps))]
+         [l (length ps)]
+         [ht (make-free-identifier-mapping)])
+    (for-each (lambda (v) (free-identifier-mapping-put! ht v 1)) first-vars)
+    (for-each (lambda (p) 
+                (for-each (lambda (v) 
+                            (cond [(free-identifier-mapping-get ht v (lambda () #f)) 
+                                   =>
+                                   (lambda (n)
+                                     (free-identifier-mapping-put! ht v (add1 n)))]
+                                  [else (raise-syntax-error 'match "variable not bound in all or patterns" stx v)]))
+                          (bound-vars p)))
+              (cdr ps))
+    (free-identifier-mapping-for-each
+     ht
+     (lambda (v n)
+       (unless (= n l)
+         (raise-syntax-error 'match "variable not bound in all or patterns" stx v))))))
\ No newline at end of file
diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss
new file mode 100644
index 0000000000..7b21b816b9
--- /dev/null
+++ b/collects/scheme/match/parse-legacy.ss
@@ -0,0 +1,135 @@
+#lang scheme/base
+
+(require (for-template scheme/base)
+         syntax/boundmap
+         syntax/stx
+         scheme/struct-info
+         "patterns.ss"
+         "compiler.ss"         
+         "parse-helper.ss"
+         "parse-quasi.ss"
+         (only-in srfi/1 delete-duplicates))
+
+(provide parse/legacy/cert)
+
+(define (parse/legacy/cert stx cert)
+  (define (parse stx) (parse/legacy/cert stx cert))
+  (syntax-case* stx (not $ ? and or = quasiquote quote)
+    (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
+    
+    [(expander args ...)
+       (and (identifier? #'expander)
+            ;; for debugging
+            (syntax-transforming?)
+            (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
+       (let* ([expander (syntax-local-value (cert #'expander))]
+              [transformer (match-expander-legacy-xform expander)])
+         (unless transformer
+           (raise-syntax-error #f "This expander only works with the standard match syntax" #'expander))
+         (let* ([introducer (make-syntax-introducer)]
+                [certifier (match-expander-certifier expander)]
+                [mstx (introducer (syntax-local-introduce stx))]
+                [mresult (transformer mstx)]
+                [result (syntax-local-introduce (introducer mresult))]
+                [cert* (lambda (id) (certifier (cert id) #f introducer))])
+           (parse/legacy/cert result cert*)))]
+    [(and p ...)
+     (make-And (map parse (syntax->list #'(p ...))))]
+    [(or p ...)
+     (let ([ps (map parse (syntax->list #'(p ...)))])
+       (all-vars ps stx)
+       (make-Or ps))]
+    [(not p ...)
+     ;; nots are conjunctions of negations
+     (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
+       (make-And ps))]
+    [bx 
+     (box? (syntax-e #'bx))
+     (make-Box (parse (unbox (syntax-e #'bx))))]
+    [#(es ...)
+     (ormap ddk? (syntax->list #'(es ...)))
+     (make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (es ...))))))]
+    [#(es ...)
+     (make-Vector (map parse (syntax->list #'(es ...))))]    
+      
+    [($ s . pats)
+     (let* ([fail (lambda () 
+                    (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
+            [v (syntax-local-value (cert #'s) fail)])
+       (unless (struct-info? v)
+         (fail))
+       (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
+         ;; 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 
+                         (extract-struct-info (syntax-local-value struct-name))
+                         5)])
+             (cond [(equal? super #t) '()] ;; no super type exists
+                   [(equal? super #f) '()] ;; super type is unknown
+                   [else (cons super (get-lineage super))])))
+         (let* (;; the accessors come in reverse order
+                [acc (reverse acc)]
+                ;; remove the first element, if it's #f
+                [acc (if (not (car acc)) (cdr acc) acc)])
+           (make-Struct id pred (get-lineage #'s) acc 
+                        (if (eq? '_ (syntax-e #'pats))
+                            (map make-Dummy acc)
+                            (let* ([ps (syntax->list #'pats)])
+                              (unless (= (length ps) (length acc))
+                                (raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
+                                                                   (syntax->datum #'s) (length acc) (length ps))
+                                                    stx #'pats))
+                              (map parse ps)))))))]
+    [(? p q1 qs ...)
+     (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
+    [(? p)
+     (make-Pred (cert #'p))]
+    [(= f p)
+     (make-App #'f (parse (cert #'p)))]
+    [(quasiquote p)
+     (parse-quasi #'p cert parse/legacy/cert)]
+    [(quote ())
+     (make-Null (make-Dummy stx))]
+    [(quote (a . b))
+     (make-Pair (parse (syntax/loc stx (quote a)))
+                (parse (syntax/loc stx (quote b))))]
+    [(quote vec)
+     (vector? (syntax-e #'vec))
+     (make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
+                            (parse (quasisyntax/loc stx (quote #,e)))))]
+    [(quote bx)
+     (vector? (syntax-e #'bx))
+     (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
+    [(quote v)
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [() (make-Null (make-Dummy #f))]
+    [(..)
+     (ddk? #'..)
+     (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
+    [(p .. . rest)
+     (ddk? #'..)
+     (let* ([count (ddk? #'..)]
+            [min (if (number? count) count #f)]
+            [max (if (number? count) count #f)])
+       (make-GSeq 
+        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+          (list (list (parse #'p))))
+        (list min)
+        ;; no upper bound
+        (list #f)
+        ;; patterns in p get bound to lists
+        (list #f)
+        (parse (syntax/loc stx rest))))]
+    [(e . es)
+     (make-Pair (parse #'e) (parse (syntax/loc stx es)))]  
+    [x
+     (identifier? #'x)
+     (cond [(eq? '_ (syntax-e #'x))
+            (make-Dummy #'x)]
+           [(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
+           [else (make-Var #'x)])]
+    [v
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "syntax error in pattern" stx))]))
diff --git a/collects/scheme/match/parse-quasi.ss b/collects/scheme/match/parse-quasi.ss
new file mode 100644
index 0000000000..d3cc095295
--- /dev/null
+++ b/collects/scheme/match/parse-quasi.ss
@@ -0,0 +1,84 @@
+#lang scheme/base
+
+(require (for-template scheme/base)
+         syntax/boundmap
+         syntax/stx
+         scheme/struct-info
+         "patterns.ss"
+         "compiler.ss"
+         "parse-helper.ss"
+         (only-in srfi/1 delete-duplicates))
+
+(provide parse-quasi)
+
+;; is pat a pattern representing a list?
+(define (null-terminated? pat)
+  (cond [(Pair? pat)
+         (null-terminated? (Pair-d pat))]
+        [(GSeq? pat)
+         (null-terminated? (GSeq-tail pat))]
+        [(Null? pat) #t]
+        [else #f]))
+
+;; combine a null-terminated pattern with another pattern to match afterwards
+(define (append-pats p1 p2)
+  (cond [(Pair? p1)
+         (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))]
+        [(GSeq? p1)
+         (make-GSeq (GSeq-headss p1)
+                    (GSeq-mins p1)
+                    (GSeq-maxs p1)
+                    (GSeq-onces? p1) 
+                    (append-pats (GSeq-tail p1) p2))]
+        [(Null? p1) p2]
+        [else (error 'match "illegal input to append-pats")]))
+
+;; parse stx as a quasi-pattern
+;; parse/cert parses unquote
+(define (parse-quasi stx cert parse/cert)
+  (define (pq s) (parse-quasi s cert parse/cert))
+  (syntax-case stx (quasiquote unquote quote unquote-splicing)
+    [(unquote p) (parse/cert #'p cert)]       
+    [((unquote-splicing p) . rest)
+     (let ([pat (parse/cert #'p cert)]
+           [rpat (pq #'rest)])
+       (if (null-terminated? pat)
+           (append-pats pat rpat)
+           (raise-syntax-error 'match "non-list pattern inside unquote-splicing" stx #'p)))]
+    [(p dd)
+     (ddk? #'dd)
+     (let* ([count (ddk? #'..)]
+            [min (if (number? count) count #f)]
+            [max (if (number? count) count #f)])
+       (make-GSeq 
+        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+          (list (list (pq #'p))))
+        (list min)
+        ;; no upper bound
+        (list #f)
+        ;; patterns in p get bound to lists
+        (list #f)
+        (make-Null (make-Dummy #f))))]
+    [(a . b) (make-Pair (pq #'a) (pq #'b))]
+    ;; the hard cases
+    [#(p ...)
+     (ormap (lambda (p)
+              (or (ddk? p)
+                  (syntax-case p (unquote-splicing)
+                    [(unquote-splicing . _) #t]
+                    [_ #f])))
+            (syntax->list #'(p ...)))
+     (make-And (list
+                (make-Pred #'vector?)
+                (make-App #'vector->list
+                          (pq (quasisyntax/loc stx (p ...))))))]
+    [#(p ...)
+     (make-Vector (map pq (syntax->list #'(p ...))))]
+    [bx
+     (box? (syntax-e #'bx))
+     (make-Box (pq (unbox (syntax-e #'bx))))]
+    [()
+     (make-Null (make-Dummy #f))]
+    [v
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "syntax error in quasipattern" stx))]))
\ No newline at end of file
diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
new file mode 100644
index 0000000000..3f6d48bc6d
--- /dev/null
+++ b/collects/scheme/match/parse.ss
@@ -0,0 +1,243 @@
+#lang scheme/base
+
+(require (for-template scheme/base)
+         syntax/boundmap
+         syntax/stx
+         scheme/struct-info
+         "patterns.ss"
+         "compiler.ss"
+         "parse-helper.ss"
+         "parse-quasi.ss"
+         "match-expander.ss"
+         (only-in srfi/1 delete-duplicates))
+
+(provide parse/cert)
+
+;; parse : syntax -> Pat
+;; compile stx into a pattern, using the new syntax
+(define (parse/cert stx cert)
+  (define (parse stx) (parse/cert stx cert))
+  (syntax-case* stx (not var struct box cons list vector ? and or quote app regexp pregexp
+                         list-rest list-no-order hash-table quasiquote)
+    (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
+    
+    [(expander args ...)
+       (and (identifier? #'expander)
+            (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
+       (let* ([expander (syntax-local-value (cert #'expander))]
+              [transformer (match-expander-match-xform expander)])
+         (unless transformer
+           (raise-syntax-error #f "This expander only works with the legacy match syntax" #'expander))
+         (let* ([introducer (make-syntax-introducer)]
+                [certifier (match-expander-certifier expander)]
+                [mstx (introducer (syntax-local-introduce stx))]
+                [mresult (transformer mstx)]
+                [result (syntax-local-introduce (introducer mresult))]
+                [cert* (lambda (id) (certifier (cert id) #f introducer))])
+           (parse/cert result cert*)))]
+    [(var v)
+     (identifier? #'v)
+     (make-Var #'v)]
+    [(and p ...)
+     (make-And (map parse (syntax->list #'(p ...))))]
+    [(or p ...)
+     (let ([ps (map parse (syntax->list #'(p ...)))])
+       (all-vars ps stx)
+       (make-Or ps))]
+    [(not p ...)
+     ;; nots are conjunctions of negations
+     (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
+       (make-And ps))]
+    [(regexp r)
+     (make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
+    [(regexp r p)
+     (make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
+    [(pregexp r)
+     (make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r 
+                                                       (lambda (e) (regexp-match (if (pregexp? r)
+                                                                                     r
+                                                                                     (pregexp r))
+                                                                                 e)))
+                                                     (make-Pred #'values))))]
+    [(pregexp r p)
+     (make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r 
+                                                       (lambda (e) (regexp-match (if (pregexp? r)
+                                                                                     r
+                                                                                     (pregexp r))
+                                                                                 e)))
+                                                     (parse #'p))))]
+    [(box e) (make-Box (parse #'e))]    
+    [(vector es ...)
+     (ormap ddk? (syntax->list #'(es ...)))
+     (make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (list es ...))))))]
+    [(vector es ...)
+     (make-Vector (map parse (syntax->list #'(es ...))))]
+    [(hash-table p ... dd)
+     (ddk? #'dd)
+     (make-And 
+      (list 
+       (make-Pred #'hash-table?) 
+       (make-App 
+        #'(lambda (e) (hash-table-map e list))
+        (with-syntax ([(elems ...) (map (lambda (p)
+                                          (syntax-case p ()
+                                            [(a b) #'(list a b)]
+                                            [x
+                                             (identifier? #'x)
+                                             #'x]))
+                                        (syntax->list #'(p ...)))])
+          (parse (syntax/loc stx (list-no-order elems ... dd)))))))]
+    [(hash-table p ...)
+    (ormap ddk? (syntax->list #'(p ...)))
+    (raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx 
+                        (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
+    [(hash-table p ...)
+    (make-And 
+      (list 
+       (make-Pred #'hash-table?) 
+       (make-App 
+        #'(lambda (e) (hash-table-map e list))
+        (with-syntax ([(elems ...) (map (lambda (p)
+                                          (syntax-case p ()
+                                            [(a b) #'(list a b)]
+                                            [x
+                                             (identifier? #'x)
+                                             #'x]))
+                                        (syntax->list #'(p ...)))])
+          (parse (syntax/loc stx (list-no-order elems ...)))))))]
+    [(hash-table . _)
+     (raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
+    [(list-no-order p ... lp dd)
+     (ddk? #'dd)     
+     (let* ([count (ddk? #'dd)]
+            [min (if (number? count) count #f)]
+            [max (if (number? count) count #f)]
+            [ps (syntax->list #'(p ...))])
+       (make-GSeq
+        (cons (list (parse #'lp))
+              (for/list ([p ps])
+                        (list (parse p))))
+        (cons min (map (lambda _ 1) ps))
+        (cons max (map (lambda _ 1) ps))
+        ;; vars in lp are lists, vars elsewhere are not
+        (cons #f (map (lambda _ #t) ps))
+        (make-Null (make-Dummy #f))))]
+    [(list-no-order p ...)
+     (ormap ddk? (syntax->list #'(p ...)))
+     (raise-syntax-error 'match "dot dot k can only appear at the end of unordered match patterns" stx 
+                         (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
+    [(list-no-order p ...)
+     (let ([ps (syntax->list #'(p ...))])
+       (make-GSeq
+        (for/list ([p ps])
+                  (list (parse p)))
+        (map (lambda _ 1) ps)
+        (map (lambda _ 1) ps)
+        ;; all of these patterns get bound to only one thing
+        (map (lambda _ #t) ps)
+        (make-Null (make-Dummy #f))))]
+    [(list) (make-Null (make-Dummy stx))]
+    [(list ..)
+     (ddk? #'..)
+     (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
+    [(list p .. . rest)
+     (ddk? #'..)
+     (let* ([count (ddk? #'..)]
+            [min (if (number? count) count #f)]
+            [max (if (number? count) count #f)])
+       (make-GSeq 
+        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+          (list (list (parse #'p))))
+        (list min)
+        ;; no upper bound
+        (list #f)
+        ;; patterns in p get bound to lists
+        (list #f)
+        (parse (syntax/loc stx (list . rest)))))]
+    [(list e es ...)
+     (make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
+    [(list-rest e)
+     (parse #'e)]
+    [(list-rest p dd . rest)
+     (ddk? #'dd)
+     (let* ([count (ddk? #'dd)]
+            [min (if (number? count) count #f)])
+       (make-GSeq 
+        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+          (list (list (parse #'p))))
+        (list min)
+        ;; no upper bound
+        (list #f)
+        ;; patterns in p get bound to lists
+        (list #f)
+        (parse (syntax/loc stx (list-rest . rest)))))]
+    [(list-rest e . es)
+     (make-Pair (parse #'e) (parse (syntax/loc #'es (list-rest . es))))]
+    [(cons e1 e2) (make-Pair (parse #'e1) (parse #'e2))]
+    [(struct s pats)
+     (let* ([fail (lambda () 
+                    (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
+            [v (syntax-local-value (cert #'s) fail)])
+       (unless (struct-info? v)
+         (fail))
+       (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
+         ;; 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 
+                         (extract-struct-info (syntax-local-value struct-name))
+                         5)])
+             (cond [(equal? super #t) '()] ;; no super type exists
+                   [(equal? super #f) '()] ;; super type is unknown
+                   [else (cons super (get-lineage super))])))
+         (let* (;; the accessors come in reverse order
+                [acc (reverse acc)]
+                ;; remove the first element, if it's #f
+                [acc (if (not (car acc)) (cdr acc) acc)])
+           (make-Struct id pred (get-lineage #'s) acc 
+                        (if (eq? '_ (syntax-e #'pats))
+                            (map make-Dummy acc)
+                            (let* ([ps (syntax->list #'pats)])
+                              (unless (= (length ps) (length acc))
+                                (raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
+                                                                   (syntax->datum #'s) (length acc) (length ps))
+                                                    stx #'pats))
+                              (map parse ps)))))))]
+    [(? p q1 qs ...)
+     (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
+    [(? p)
+     (make-Pred (cert #'p))]
+    [(app f p)
+     (make-App #'f (parse (cert #'p)))]
+    [(quasiquote p)
+     (parse-quasi #'p cert parse/cert)]
+    [(quote ())
+     (make-Null (make-Dummy stx))]
+    [(quote (a . b))
+     (make-Pair (parse (syntax/loc stx (quote a)))
+                (parse (syntax/loc stx (quote b))))]
+    [(quote vec)
+     (vector? (syntax-e #'vec))
+     (make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
+                            (parse (quasisyntax/loc stx (quote #,e)))))]
+    [(quote bx)
+     (vector? (syntax-e #'bx))
+     (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
+    [(quote v)
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [x
+     (identifier? #'x)
+     (cond [(eq? '_ (syntax-e #'x))
+            (make-Dummy #'x)]
+           [(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
+           [else (make-Var #'x)])]
+    [v
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "syntax error in pattern" stx))]))
+
+;(trace parse)
+
+
+
+
diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss
new file mode 100644
index 0000000000..0e7246bc1f
--- /dev/null
+++ b/collects/scheme/match/patterns.ss
@@ -0,0 +1,224 @@
+#lang scheme/base
+
+(require syntax/boundmap
+         mzlib/trace
+         scheme/stxparam
+         scheme/contract
+         (for-syntax scheme/base))
+
+(provide (except-out (all-defined-out)
+                     struct-key-ht
+                     get-key
+                     (struct-out Row)
+                     (struct-out exn:misc:match))
+         exn:misc:match?)
+
+(define-struct (exn:misc:match exn:fail) (value))
+  
+(define (match:error val) (raise (make-exn:misc:match (format "match: no matching clause for ~e" val)
+                                                      (current-continuation-marks)
+                                                      val)))
+
+
+(define-struct Pat () #:transparent)
+;; v is an identifier
+(define-struct (Var Pat) (v)
+  #:transparent
+  #:property
+  prop:custom-write (lambda (v p w?)
+                      (fprintf p "(Var ~a)" (syntax-e (Var-v v)))))
+(define-struct (Dummy Var) ()
+  #:transparent
+  #:property
+  prop:custom-write (lambda (v p w?)
+                      (fprintf p "_")))
+
+;; constructor patterns
+(define-struct (CPat Pat) () #:transparent)
+
+;; start is what index to start at
+(define-struct (Vector CPat) (ps) #:transparent)
+
+(define-struct (VectorSeq Pat) (p count start) #:transparent)
+
+(define-struct (Pair CPat) (a d) #:transparent)
+
+(define-struct (Box CPat) (p) #:transparent)
+
+;; p is a pattern to match against the literal
+(define-struct (Atom CPat) (p) #:transparent)
+(define-struct (String Atom) () #:transparent)
+(define-struct (Number Atom) () #:transparent)
+(define-struct (Symbol Atom) () #:transparent)
+(define-struct (Keyword Atom) () #:transparent)
+(define-struct (Char Atom) () #:transparent)
+(define-struct (Bytes Atom) () #:transparent)
+(define-struct (Regexp Atom) () #:transparent)
+(define-struct (Boolean Atom) () #:transparent)
+(define-struct (Null Atom) () #:transparent)
+
+;; expr is an expression
+;; p is a pattern
+(define-struct (App Pat) (expr p) #:transparent)
+
+;; pred is an expression
+(define-struct (Pred Pat) (pred) #:transparent)
+
+;; pred is an identifier
+;; super is an identifier, or #f
+;; accessors is a listof identifiers (NB in reverse order from the struct info)
+;; ps is a listof patterns
+(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
+
+;; both fields are lists of pats
+(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
+
+;; ps are patterns
+(define-struct (Or Pat) (ps) #:transparent)
+(define-struct (And Pat) (ps) #:transparent)
+;; p is a pattern
+(define-struct (Not Pat) (p) #:transparent)
+
+;; headss : listof listof pattern
+;; mins : listof option number
+;; maxs : listof option number
+;; onces? : listof boolean -- is this pattern being bound only once (take the car of the variables)
+;; tail : pattern
+(define-struct (GSeq Pat) (headss mins maxs onces? tail) #:transparent)
+
+;; match with equal?
+;; v is a quotable scheme value
+(define-struct (Exact Pat) (v) #:transparent)
+
+;; pats is a Listof Pat
+;; rhs is an expression
+;; unmatch is an identifier
+;; vars-seen is a listof identifiers
+(define-struct Row (pats rhs unmatch vars-seen) #:transparent
+  #:property
+  prop:custom-write (lambda (v p w?)
+                      (fprintf p "(Row ~a )" (Row-pats v))))
+
+
+
+(define struct-key-ht (make-free-identifier-mapping))
+(define (get-key id)
+  (free-identifier-mapping-get 
+   struct-key-ht id
+   (lambda ()
+     (let ([k (box-immutable (syntax-e id))])
+       (free-identifier-mapping-put! struct-key-ht id k)
+       k))))
+
+;; pat-key returns either an immutable box, or a symbol., or #f
+;; the result is a box iff the argument was a struct pattern
+;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor
+;; the result is #f if p is not a constructor pattern
+(define (pat-key p)
+  (cond
+    [(Struct? p) (get-key (Struct-id p))]
+    [(Box? p) 'box]
+    [(Vector? p) 'vector]
+    [(Pair? p) 'pair]
+    [(String? p) 'string]
+    [(Symbol? p) 'symbol]
+    [(Number? p) 'number]
+    [(Bytes? p) 'bytes]
+    [(Char? p) 'char]
+    [(Regexp? p) 'regexp]
+    [(Keyword? p) 'keyword]
+    [(Boolean? p) 'boolean]
+    [(Null? p) 'null]
+    [else #f]))
+
+;(trace pat-key)
+
+;; Row-first-pat : Row -> Pat
+;; Row must not have empty list of pats
+(define (Row-first-pat r)
+  (car (Row-pats r)))
+
+(define (Row-split-pats r)
+  (define p (Row-pats r))
+  (values (car p) (cdr p)))
+
+
+;; merge : (liftof (listof id)) -> (listof id)
+;;  merges lists of identifiers, removing module-identifier=?
+;;  duplicates
+(define (merge l)
+  (cond
+    [(null? l) null]
+    [(null? (cdr l)) (car l)]
+    [else (let ([m (make-module-identifier-mapping)])
+            (for-each (lambda (ids)
+                        (for-each (lambda (id)
+                                    (module-identifier-mapping-put! m id #t))
+                                  ids))
+                      l)
+            (module-identifier-mapping-map m (lambda (k v) k)))]))
+;; bound-vars : Pat -> listof identifiers
+(define (bound-vars p)
+  (cond
+    [(Dummy? p) null]
+    [(Pred? p) null]
+    [(Var? p) (list (Var-v p))]
+    [(Or? p)
+     (bound-vars (car (Or-ps p)))]
+    [(Box? p)
+     (bound-vars (Box-p p))]
+    [(Atom? p) null]
+    [(Pair? p)
+     (merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
+    [(GSeq? p)
+     (merge (cons
+             (bound-vars (GSeq-tail p))
+             (for/list ([pats (GSeq-headss p)])
+                       (merge (for/list ([pat pats])
+                                        (bound-vars pat))))))]
+    [(Vector? p)
+     (merge (map bound-vars (Vector-ps p)))]
+    [(Struct? p)
+     (merge (map bound-vars (Struct-ps p)))]
+    [(App? p)
+     (bound-vars (App-p p))]
+    [(Not? p) null]
+    [(And? p)
+     (merge (map bound-vars (And-ps p)))]
+    [(Exact? p) null]
+    [else (error 'match "bad pattern: ~a" p)]))
+
+(define match-...-nesting (make-parameter 0))
+(define match-equality-test (make-parameter equal?))
+
+(define-syntax-parameter fail
+  (lambda (stx)
+    (raise-syntax-error #f
+                        "used out of context: not in match pattern"
+                        stx)))
+
+#|
+;; EXAMPLES
+
+(define p-x (make-Var #'x))
+(define p-y (make-Var #'y))
+(define p-d (make-Dummy #'_))
+
+(define p-cons (make-Pair p-x p-y))
+(define p-vec (make-Vector (list p-x p-y p-d)))
+
+(define r1 (make-Row (list p-x) #'#f #f null))
+(define r2 (make-Row (list p-y) #'#f #f null))
+(define r3 (make-Row (list p-cons) #'#f #f null))
+(define r4 (make-Row (list p-vec p-d) #'#f #f null))
+|#
+
+(provide/contract (struct Row ([pats (listof Pat?)]
+                               [rhs syntax?]
+                               [unmatch (or/c identifier? false/c)]
+                               [vars-seen (listof (cons/c identifier? identifier?))])))
+
+(define-struct match-expander (match-xform legacy-xform macro-xform certifier)
+  #:property prop:procedure (struct-field-index macro-xform))
+
+(provide (struct-out match-expander))
\ No newline at end of file
diff --git a/collects/scheme/match/split-rows.ss b/collects/scheme/match/split-rows.ss
new file mode 100644
index 0000000000..d955f207c2
--- /dev/null
+++ b/collects/scheme/match/split-rows.ss
@@ -0,0 +1,85 @@
+#lang scheme/base
+
+(require "patterns.ss")
+
+(provide split-rows)
+
+;; split-rows : Listof[Row] -> Listof[Listof[Row]]
+;; takes a matrix, and returns a list of matricies
+;; each returned matrix does not require the mixture rule to do compilation of the first column.
+(define (split-rows rows [acc null])
+  (define (loop/var matched-rows prev-mats rows)
+    (cond [(null? rows)
+           (reverse (cons (reverse matched-rows) prev-mats))]
+          [else
+           (let* ([r (car rows)]
+                  [p (Row-first-pat r)]
+                  [rs (cdr rows)])
+             (cond
+               [(Row-unmatch r)
+                (split-rows rows (cons (reverse matched-rows) prev-mats))]
+               [(Var? p)
+                (loop/var (cons r matched-rows) prev-mats rs)]
+               [else 
+                (split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
+  (define (loop/con matched-rows prev-mats struct-key rows)
+    (cond [(null? rows)
+           (reverse (cons (reverse matched-rows) prev-mats))]
+          [else
+           (let* ([r (car rows)]
+                  [p (Row-first-pat r)]
+                  [rs (cdr rows)])
+             (cond
+               [(Row-unmatch r)
+                (split-rows rows (cons (reverse matched-rows) prev-mats))]
+               [(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
+                ;(printf "struct-keys were equal: ~a~n" struct-key)
+                (loop/con (cons r matched-rows) prev-mats struct-key rs)]
+               [(and (Struct? p) (not struct-key))
+                ;(printf "no struct-key so far: ~a~n" struct-key)
+                (loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
+               [(and (CPat? p) (not (Struct? p)))
+                ;(printf "wasn't a struct: ~a~n" p)
+                (loop/con (cons r matched-rows) prev-mats struct-key rs)]               
+               [else (split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
+  (define (loop/exact matched-rows prev-mats rows)
+    (cond [(null? rows)
+           (reverse (cons (reverse matched-rows) prev-mats))]
+          [else
+           (let* ([r (car rows)]
+                  [p (Row-first-pat r)]
+                  [rs (cdr rows)])
+             (cond
+               [(Row-unmatch r)
+                (split-rows rows (cons (reverse matched-rows) prev-mats))]               
+               [(Exact? p)
+                (loop/exact (cons r matched-rows) prev-mats rs)]         
+               [else (split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
+  (cond 
+    [(null? rows) (reverse acc)]
+    [else
+     (let* ([r (car rows)]
+            [p (Row-first-pat r)]
+            [rs (cdr rows)])
+       (cond
+         [(Row-unmatch r)
+          (split-rows rs (cons (list r) acc))]
+         [(Var? p)
+          (loop/var (list r) acc rs)]
+         [(Exact? p)
+          (loop/exact (list r) acc rs)]
+         [(CPat? p)
+          (if (Struct? p)
+              (begin
+                ;(printf "found a struct: ~a~n" (pat-key r))
+                (loop/con (list r) acc (pat-key p) rs))
+              (loop/con (list r) acc #f rs))]
+         [else (split-rows rs (cons (list r) acc))]))]))
+
+(require mzlib/trace)
+;(trace split-rows)
+
+;; EXAMPLES:
+#|
+(define mat1 (list r1 r2 r3))
+(define mat2 (list r1 r3 r2 r1))|#
\ No newline at end of file

From 3552f7f73bfbc8c57615608c0f3e49225f44f663 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 01:37:55 +0000
Subject: [PATCH 02/10] handle empty structs

svn: r9055
---
 collects/scheme/match/parse.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
index 3f6d48bc6d..499f7435c3 100644
--- a/collects/scheme/match/parse.ss
+++ b/collects/scheme/match/parse.ss
@@ -193,7 +193,7 @@
          (let* (;; the accessors come in reverse order
                 [acc (reverse acc)]
                 ;; remove the first element, if it's #f
-                [acc (if (not (car acc)) (cdr acc) acc)])
+                [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
            (make-Struct id pred (get-lineage #'s) acc 
                         (if (eq? '_ (syntax-e #'pats))
                             (map make-Dummy acc)

From c914aab4ea5d0a6d8a477226e81a6df9dbe836f1 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 01:40:13 +0000
Subject: [PATCH 03/10] add orig-stx parameter

svn: r9056
---
 collects/scheme/match/gen-match.ss | 3 ++-
 collects/scheme/match/patterns.ss  | 1 +
 2 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss
index c9b2e4f92b..44a89b941a 100644
--- a/collects/scheme/match/gen-match.ss
+++ b/collects/scheme/match/gen-match.ss
@@ -9,6 +9,7 @@
 ;; this parses the clauses using parse/cert, then compiles them
 ;; go : syntax syntax syntax certifier -> syntax
 (define (go parse/cert stx exprs clauses cert)
+  (parameterize ([orig-stx stx])
   (syntax-case clauses ()
     [([pats . rhs] ...)
      (let ([len (length (syntax->list exprs))])
@@ -42,4 +43,4 @@
              (let ([xs exprs]
                    ...)
                (let ([fail (lambda () #,(syntax/loc stx (match:error orig-expr)))])
-                 body))))))]))
\ No newline at end of file
+                 body))))))])))
diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss
index 0e7246bc1f..904d5f5bff 100644
--- a/collects/scheme/match/patterns.ss
+++ b/collects/scheme/match/patterns.ss
@@ -19,6 +19,7 @@
                                                       (current-continuation-marks)
                                                       val)))
 
+(define orig-stx (make-parameter #f))
 
 (define-struct Pat () #:transparent)
 ;; v is an identifier

From 0ee6afc2a1e3b28aff21a60d50d2e39624ecb0ce Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 01:48:19 +0000
Subject: [PATCH 04/10] same stupid bug in the old syntax

svn: r9057
---
 collects/scheme/match/gen-match.ss    | 3 ++-
 collects/scheme/match/parse-legacy.ss | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss
index 44a89b941a..eac1de5174 100644
--- a/collects/scheme/match/gen-match.ss
+++ b/collects/scheme/match/gen-match.ss
@@ -16,6 +16,7 @@
        (with-syntax ([(xs ...) (generate-temporaries exprs)]
                      [(exprs ...) exprs]
                      [(fail) (generate-temporaries #'(fail))])
+	 ;(printf "here in go ~a~n" (list (syntax-line (orig-stx)) (syntax-source (orig-stx))))
          (with-syntax ([body (compile* (syntax->list #'(xs ...))
                                        (map (lambda (pats rhs)
                                               (unless (= len (length (syntax->list pats)))
@@ -43,4 +44,4 @@
              (let ([xs exprs]
                    ...)
                (let ([fail (lambda () #,(syntax/loc stx (match:error orig-expr)))])
-                 body))))))])))
+                 body))))))])))
\ No newline at end of file
diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss
index 7b21b816b9..0dda80ffde 100644
--- a/collects/scheme/match/parse-legacy.ss
+++ b/collects/scheme/match/parse-legacy.ss
@@ -71,7 +71,7 @@
          (let* (;; the accessors come in reverse order
                 [acc (reverse acc)]
                 ;; remove the first element, if it's #f
-                [acc (if (not (car acc)) (cdr acc) acc)])
+                [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
            (make-Struct id pred (get-lineage #'s) acc 
                         (if (eq? '_ (syntax-e #'pats))
                             (map make-Dummy acc)

From a3076b864899a1d7040b41fafa3390deeffb6a96 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 02:11:50 +0000
Subject: [PATCH 05/10] certify in one more place

svn: r9058
---
 collects/scheme/match/parse-legacy.ss | 2 +-
 collects/scheme/match/parse.ss        | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss
index 0dda80ffde..7cd585bfdb 100644
--- a/collects/scheme/match/parse-legacy.ss
+++ b/collects/scheme/match/parse-legacy.ss
@@ -72,7 +72,7 @@
                 [acc (reverse acc)]
                 ;; remove the first element, if it's #f
                 [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
-           (make-Struct id pred (get-lineage #'s) acc 
+           (make-Struct id pred (get-lineage (cert #'s)) acc 
                         (if (eq? '_ (syntax-e #'pats))
                             (map make-Dummy acc)
                             (let* ([ps (syntax->list #'pats)])
diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
index 499f7435c3..a7f3e83ef0 100644
--- a/collects/scheme/match/parse.ss
+++ b/collects/scheme/match/parse.ss
@@ -194,7 +194,7 @@
                 [acc (reverse acc)]
                 ;; remove the first element, if it's #f
                 [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
-           (make-Struct id pred (get-lineage #'s) acc 
+           (make-Struct id pred (get-lineage (cert #'s)) acc 
                         (if (eq? '_ (syntax-e #'pats))
                             (map make-Dummy acc)
                             (let* ([ps (syntax->list #'pats)])

From 709741fc96777a02628ba545594ce5e04d2464ad Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 02:27:13 +0000
Subject: [PATCH 06/10] fix or pattern

svn: r9059
---
 collects/typed-scheme/private/subtype.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss
index 52342b291f..71e515e2a0 100644
--- a/collects/typed-scheme/private/subtype.ss
+++ b/collects/typed-scheme/private/subtype.ss
@@ -99,7 +99,7 @@
     (match (list s t)
       ;; top for functions is above everything
       [(list _ (top-arr:)) A0]
-      [(list (arr: s1 s2 #f thn-eff els-eff) (arr: t1 t2 #f (or '() thn-eff) (or '() els-eff)))
+      [(list (arr: s1 s2 #f thn-eff els-eff) (arr: t1 t2 #f thn-eff  els-eff))
        (let ([A1 (subtypes* A0 t1 s1)])
          (subtype* A1 s2 t2))]
       [(list (arr: s1 s2 s3 thn-eff els-eff) (arr: t1 t2 t3 thn-eff* els-eff*))

From eedaebefafaf4a83b346b000d1784966bc472d5d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 02:29:49 +0000
Subject: [PATCH 07/10] remove debugging printf

svn: r9060
---
 collects/scheme/match/gen-match.ss | 1 -
 1 file changed, 1 deletion(-)

diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss
index eac1de5174..7611f5e9e0 100644
--- a/collects/scheme/match/gen-match.ss
+++ b/collects/scheme/match/gen-match.ss
@@ -16,7 +16,6 @@
        (with-syntax ([(xs ...) (generate-temporaries exprs)]
                      [(exprs ...) exprs]
                      [(fail) (generate-temporaries #'(fail))])
-	 ;(printf "here in go ~a~n" (list (syntax-line (orig-stx)) (syntax-source (orig-stx))))
          (with-syntax ([body (compile* (syntax->list #'(xs ...))
                                        (map (lambda (pats rhs)
                                               (unless (= len (length (syntax->list pats)))

From 63df5e13f784baef61ddcda0d6dd584cd03f9fac Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 17:07:59 +0000
Subject: [PATCH 08/10] add matchable?

svn: r9067
---
 collects/scheme/match/parse-helper.ss |  6 ++++--
 collects/scheme/match/parse.ss        | 10 +++++-----
 2 files changed, 9 insertions(+), 7 deletions(-)

diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss
index d41d63bcbe..e80b4acbba 100644
--- a/collects/scheme/match/parse-helper.ss
+++ b/collects/scheme/match/parse-helper.ss
@@ -8,9 +8,11 @@
          "compiler.ss"
          (only-in srfi/1 delete-duplicates))
 
-(provide ddk? parse-literal all-vars pattern-var? match:syntax-err)
-
+(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
+         matchable?)
 
+(define (matchable? e)
+  (or (string? e) (bytes? e)))
 
 ;; raise an error, blaming stx
 (define (match:syntax-err stx msg)
diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
index a7f3e83ef0..e430aee5c2 100644
--- a/collects/scheme/match/parse.ss
+++ b/collects/scheme/match/parse.ss
@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require (for-template scheme/base)
+(require (for-template scheme/base "parse-helper.ss")
          syntax/boundmap
          syntax/stx
          scheme/struct-info
@@ -49,18 +49,18 @@
      (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
        (make-And ps))]
     [(regexp r)
-     (make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
+     (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
     [(regexp r p)
-     (make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
+     (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
     [(pregexp r)
-     (make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r 
+     (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r 
                                                        (lambda (e) (regexp-match (if (pregexp? r)
                                                                                      r
                                                                                      (pregexp r))
                                                                                  e)))
                                                      (make-Pred #'values))))]
     [(pregexp r p)
-     (make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r 
+     (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r 
                                                        (lambda (e) (regexp-match (if (pregexp? r)
                                                                                      r
                                                                                      (pregexp r))

From a37fe34a4877c3b6d58b1a1e2636a5c4c0102b0f Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Sat, 22 Mar 2008 17:10:09 +0000
Subject: [PATCH 09/10] Factor out match expander code. Improve error message.

svn: r9068
---
 collects/scheme/match/define-forms.ss | 11 ++++++-----
 collects/scheme/match/parse-helper.ss | 24 ++++++++++++++++++++++--
 collects/scheme/match/parse-legacy.ss | 21 ++++++---------------
 collects/scheme/match/parse.ss        | 17 ++++-------------
 4 files changed, 38 insertions(+), 35 deletions(-)

diff --git a/collects/scheme/match/define-forms.ss b/collects/scheme/match/define-forms.ss
index d1967c5845..a75643183d 100644
--- a/collects/scheme/match/define-forms.ss
+++ b/collects/scheme/match/define-forms.ss
@@ -36,14 +36,15 @@
      
      (define-syntax (match-lambda** stx)
        (syntax-case stx ()
-         [(k [(pats ...) . rhs] ...)
-          (let* ([pss (syntax->list #'((pats ...) ...))]
-                 [len (length (syntax->list (car pss)))])
+         [(k [pats . rhs] ...)
+          (let* ([pss (syntax->list #'(pats ...))]
+                 [ps1 (car pss)]
+                 [len (length (syntax->list ps1))])
             (for/list ([ps pss])
                       (unless (= (length (syntax->list ps)) len)
-                        (raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps)))
+                        (raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps ps1)))
             (with-syntax ([(vars ...) (generate-temporaries (car pss))])
-              (syntax/loc stx (lambda (vars ...) (match* (vars ...) [(pats ...) . rhs] ...)))))]))
+              (syntax/loc stx (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
      
      
      
diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss
index e80b4acbba..c23bd62836 100644
--- a/collects/scheme/match/parse-helper.ss
+++ b/collects/scheme/match/parse-helper.ss
@@ -8,12 +8,32 @@
          "compiler.ss"
          (only-in srfi/1 delete-duplicates))
 
-(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
-         matchable?)
+(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable?)
+
+;; transform a match-expander application
+;; parse/cert : stx certifier -> pattern
+;; cert : certifier
+;; expander : identifier
+;; stx : the syntax of the match-expander application
+;; accessor : match-expander -> syntax transformer/#f
+;; error-msg : string
+;; produces a parsed pattern
+(define (match-expander-transform parse/cert cert expander stx accessor error-msg)  
+  (let* ([expander (syntax-local-value (cert expander))]
+         [transformer (accessor expander)])   
+    (unless transformer (raise-syntax-error #f error-msg #'expander))
+    (let* ([introducer (make-syntax-introducer)]
+           [certifier (match-expander-certifier expander)]
+           [mstx (introducer (syntax-local-introduce stx))]
+           [mresult (transformer mstx)]
+           [result (syntax-local-introduce (introducer mresult))]
+           [cert* (lambda (id) (certifier (cert id) #f introducer))])
+      (parse/cert result cert*))))
 
 (define (matchable? e)
   (or (string? e) (bytes? e)))
 
+
 ;; raise an error, blaming stx
 (define (match:syntax-err stx msg)
   (raise-syntax-error #f msg stx))
diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss
index 7cd585bfdb..bfff1639cb 100644
--- a/collects/scheme/match/parse-legacy.ss
+++ b/collects/scheme/match/parse-legacy.ss
@@ -18,21 +18,12 @@
     (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     
     [(expander args ...)
-       (and (identifier? #'expander)
-            ;; for debugging
-            (syntax-transforming?)
-            (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
-       (let* ([expander (syntax-local-value (cert #'expander))]
-              [transformer (match-expander-legacy-xform expander)])
-         (unless transformer
-           (raise-syntax-error #f "This expander only works with the standard match syntax" #'expander))
-         (let* ([introducer (make-syntax-introducer)]
-                [certifier (match-expander-certifier expander)]
-                [mstx (introducer (syntax-local-introduce stx))]
-                [mresult (transformer mstx)]
-                [result (syntax-local-introduce (introducer mresult))]
-                [cert* (lambda (id) (certifier (cert id) #f introducer))])
-           (parse/legacy/cert result cert*)))]
+     (and (identifier? #'expander)
+          ;; for debugging
+          (syntax-transforming?)
+          (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
+     (match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform 
+                               "This expander only works with the standard match syntax")]
     [(and p ...)
      (make-And (map parse (syntax->list #'(p ...))))]
     [(or p ...)
diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
index e430aee5c2..fddf182cd0 100644
--- a/collects/scheme/match/parse.ss
+++ b/collects/scheme/match/parse.ss
@@ -22,19 +22,10 @@
     (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     
     [(expander args ...)
-       (and (identifier? #'expander)
-            (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
-       (let* ([expander (syntax-local-value (cert #'expander))]
-              [transformer (match-expander-match-xform expander)])
-         (unless transformer
-           (raise-syntax-error #f "This expander only works with the legacy match syntax" #'expander))
-         (let* ([introducer (make-syntax-introducer)]
-                [certifier (match-expander-certifier expander)]
-                [mstx (introducer (syntax-local-introduce stx))]
-                [mresult (transformer mstx)]
-                [result (syntax-local-introduce (introducer mresult))]
-                [cert* (lambda (id) (certifier (cert id) #f introducer))])
-           (parse/cert result cert*)))]
+     (and (identifier? #'expander)
+          (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
+     (match-expander-transform parse/cert cert #'expander stx match-expander-match-xform 
+                                 "This expander only works with the legacy match syntax")]
     [(var v)
      (identifier? #'v)
      (make-Var #'v)]

From ae4acf1d517beeb7673edb12cff77add32ebf89c Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt 
Date: Tue, 25 Mar 2008 18:26:39 +0000
Subject: [PATCH 10/10] Remove old match implementation. Fix typed-scheme to
 work w/ new match. Factor out lots of common code. Implement (mcons ..)
 patterns

svn: r9086
---
 collects/mzlib/private/match/convert-pat.ss   | 134 ----
 .../private/match/coupling-and-binding.scm    | 185 ------
 collects/mzlib/private/match/ddk-handlers.ss  | 555 ----------------
 .../mzlib/private/match/define-struct.scm     | 113 ----
 collects/mzlib/private/match/emit-assm.scm    |  94 ---
 collects/mzlib/private/match/gen-match.ss     | 157 -----
 collects/mzlib/private/match/getbindings.ss   | 141 ----
 .../mzlib/private/match/getter-setter.scm     |  82 ---
 collects/mzlib/private/match/match-error.ss   |  81 ---
 .../private/match/match-expander-struct.ss    |   7 -
 .../mzlib/private/match/match-expander.ss     |  69 --
 collects/mzlib/private/match/match-helper.ss  | 482 --------------
 .../private/match/match-internal-func.ss      | 104 ---
 collects/mzlib/private/match/observe-step.ss  |  43 --
 collects/mzlib/private/match/parse-quasi.scm  | 135 ----
 .../mzlib/private/match/render-helpers.ss     | 171 -----
 collects/mzlib/private/match/render-sigs.ss   |  12 -
 .../private/match/render-test-list-impl.ss    | 616 ------------------
 .../mzlib/private/match/render-test-list.scm  |  19 -
 .../mzlib/private/match/reorder-tests.scm     | 102 ---
 .../mzlib/private/match/simplify-patterns.ss  | 190 ------
 .../mzlib/private/match/struct-helper.scm     | 235 -------
 collects/mzlib/private/match/syntax-utils.ss  |  45 --
 .../mzlib/private/match/tag-negate-tests.scm  | 103 ---
 collects/mzlib/private/match/test-no-order.ss |  39 --
 .../mzlib/private/match/test-structure.scm    | 120 ----
 .../private/match/update-binding-counts.scm   | 109 ----
 .../mzlib/private/match/update-counts.scm     | 148 -----
 collects/scheme/match/compiler.ss             |  62 +-
 collects/scheme/match/parse-helper.ss         |  91 ++-
 collects/scheme/match/parse-legacy.ss         |  66 +-
 collects/scheme/match/parse.ss                | 146 +----
 collects/scheme/match/patterns.ss             |   4 +
 collects/typed-scheme/private/base-env.ss     |   6 +-
 34 files changed, 160 insertions(+), 4506 deletions(-)
 delete mode 100644 collects/mzlib/private/match/convert-pat.ss
 delete mode 100644 collects/mzlib/private/match/coupling-and-binding.scm
 delete mode 100644 collects/mzlib/private/match/ddk-handlers.ss
 delete mode 100644 collects/mzlib/private/match/define-struct.scm
 delete mode 100644 collects/mzlib/private/match/emit-assm.scm
 delete mode 100644 collects/mzlib/private/match/gen-match.ss
 delete mode 100644 collects/mzlib/private/match/getbindings.ss
 delete mode 100644 collects/mzlib/private/match/getter-setter.scm
 delete mode 100644 collects/mzlib/private/match/match-error.ss
 delete mode 100644 collects/mzlib/private/match/match-expander-struct.ss
 delete mode 100644 collects/mzlib/private/match/match-expander.ss
 delete mode 100644 collects/mzlib/private/match/match-helper.ss
 delete mode 100644 collects/mzlib/private/match/match-internal-func.ss
 delete mode 100644 collects/mzlib/private/match/observe-step.ss
 delete mode 100644 collects/mzlib/private/match/parse-quasi.scm
 delete mode 100644 collects/mzlib/private/match/render-helpers.ss
 delete mode 100644 collects/mzlib/private/match/render-sigs.ss
 delete mode 100644 collects/mzlib/private/match/render-test-list-impl.ss
 delete mode 100644 collects/mzlib/private/match/render-test-list.scm
 delete mode 100644 collects/mzlib/private/match/reorder-tests.scm
 delete mode 100644 collects/mzlib/private/match/simplify-patterns.ss
 delete mode 100644 collects/mzlib/private/match/struct-helper.scm
 delete mode 100644 collects/mzlib/private/match/syntax-utils.ss
 delete mode 100644 collects/mzlib/private/match/tag-negate-tests.scm
 delete mode 100644 collects/mzlib/private/match/test-no-order.ss
 delete mode 100644 collects/mzlib/private/match/test-structure.scm
 delete mode 100644 collects/mzlib/private/match/update-binding-counts.scm
 delete mode 100644 collects/mzlib/private/match/update-counts.scm

diff --git a/collects/mzlib/private/match/convert-pat.ss b/collects/mzlib/private/match/convert-pat.ss
deleted file mode 100644
index ef44e16211..0000000000
--- a/collects/mzlib/private/match/convert-pat.ss
+++ /dev/null
@@ -1,134 +0,0 @@
-(module convert-pat mzscheme
-  (require "match-error.ss"
-           "match-helper.ss"
-           "match-expander-struct.ss"
-           "observe-step.ss")
-  
-  (require-for-template mzscheme
-			"match-error.ss")
-  
-  (provide convert-pat handle-clauses convert-pats)
-  
-  ;; these functions convert the patterns from the old syntax 
-  ;; to the new syntax
-  
-  (define (handle-clause stx)
-    (syntax-case stx ()
-      [(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))]))
-  
-  (define (handle-clauses stx) (syntax-map handle-clause stx))
-  
-  
-  (define (convert-pats stx)
-    (with-syntax ([new-pats (syntax-map convert-pat stx)])
-      #'new-pats))
-  
-  (define (imp-list? stx)
-    (define datum (syntax-e stx))
-    (define (keyword? x)
-      (memq (syntax-object->datum x)
-            '(quote quasiquote ? = and or not $ set! get!)))
-    (let/ec out
-      (let loop ([x datum])
-        (cond [(null? x) (out #f)]
-              [(or (not (pair? x))
-                   (and (list? x)
-                        (keyword? (car x))))
-               (list 
-                (quasisyntax/loc stx #,x))]
-              [else (cons (car x) (loop (cdr x)))]))))
-  
-  (define (convert-quasi stx)
-    (syntax-case stx (unquote quasiquote unquote-splicing)
-      [,pat (quasisyntax/loc stx ,#,(convert-pat (syntax pat)))]
-      [,@pat (quasisyntax/loc stx ,@#,(convert-pat (syntax pat)))]
-      [(x . y)
-       (quasisyntax/loc 
-           stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y))))]
-      [pat
-       (vector? (syntax-e stx))
-       (quasisyntax/loc 
-           stx 
-         #,(list->vector (map convert-quasi 
-                              (vector->list (syntax-e stx)))))]
-      [pat
-       (box? (syntax-e stx))
-       (quasisyntax/loc 
-           stx #,(box (convert-quasi (unbox (syntax-e stx)))))]
-      [pat stx]))
-  
-  (define (convert-pat stx)
-    (convert-pat/cert stx (lambda (x) x)))
-  
-  (define (convert-pat/cert stx cert)
-    (let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
-      (syntax-case* 
-	  stx
-        (_ ? = and or not $ set! get! quasiquote 
-           quote unquote unquote-splicing) stx-equal?
-	[(expander . args)
-	 (and (identifier? #'expander)
-	      (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
-	 (let* ([expander (syntax-local-value (cert #'expander) (lambda () #f))]
-		[xformer (match-expander-match-xform expander)])
-	   (if (not xformer)
-	       (match:syntax-err #'expander
-				 "This expander only works with plt-match.ss.")
-	       (let* ([introducer (make-syntax-introducer)]
-                      [certifier (match-expander-certifier expander)]
-                      [mstx (introducer stx)]
-                      [mresult (xformer mstx)]
-                      [result (introducer mresult)]
-                      [cert* (lambda (id) (certifier (cert id) #f introducer))])
-                 (observe-step stx mstx mresult result)
-                 (convert-pat/cert result cert*))))]
-	[p
-	 (dot-dot-k? (syntax-object->datum #'p))
-	 stx]
-	[_ stx]
-	[() (syntax/loc stx (list))]
-	['() (syntax/loc stx (list))]
-	['item stx]
-	[p (constant-data? (syntax-e stx)) stx]
-	[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
-	[(? pred . a)
-	 (with-syntax ([pred (cert #'pred)]
-		       [pats (syntax-map convert-pat #'a)])
-	   (syntax/loc stx (? pred . pats)))]
-	[`pat (quasisyntax/loc stx `#,(convert-quasi #'pat))]
-	[(= op pat) (quasisyntax/loc stx (app #,(cert #'op) #,(convert-pat #'pat)))]
-	[(and . pats)
-	 (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
-	   (syntax/loc stx (and . new-pats)))]
-	[(or . pats)
-	 (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
-	   (syntax/loc stx (or . new-pats)))]
-	[(not . pats)
-         (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
-	   (syntax/loc stx (not . new-pats)))]
-	[($ struct-name . fields)
-	 (with-syntax ([struct-name (cert #'struct-name)]
-		       [new-fields (syntax-map convert-pat #'fields)])
-	   (syntax/loc stx (struct struct-name new-fields)))]
-	[(get! id) (with-syntax ([id (cert #'id)])
-		     (syntax/loc stx (get! id)))]
-	[(set! id) (with-syntax ([id (cert #'id)])
-		     (syntax/loc stx (set! id)))]
-	[(quote p) stx]
-        [(car-pat . cdr-pat)
-         (let ([l (imp-list? stx)])
-           (if l (quasisyntax/loc stx (list-rest #,@(map convert-pat l)))
-               (quasisyntax/loc stx (list #,@(syntax-map convert-pat stx)))))]
-        [pt
-	 (vector? (syntax-e stx))
-	 (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
-	   (syntax/loc stx (vector . new-pats)))]
-	[pt
-	 (box? (syntax-e stx))
-	 (quasisyntax/loc stx (box #,(convert-pat (unbox (syntax-e stx)))))]
-	[pt
-	 (identifier? stx)
-	 (cert stx)]
-	[got-too-far 
-	 (match:syntax-err stx "syntax error in pattern")])))
-  )
diff --git a/collects/mzlib/private/match/coupling-and-binding.scm b/collects/mzlib/private/match/coupling-and-binding.scm
deleted file mode 100644
index 9f4dc19245..0000000000
--- a/collects/mzlib/private/match/coupling-and-binding.scm
+++ /dev/null
@@ -1,185 +0,0 @@
-
-(module coupling-and-binding mzscheme
-  ;; This library is used by match.ss
-  
-  (provide couple-tests meta-couple subst-bindings)
-  
-  (require "test-structure.scm"
-	   "match-helper.ss"
-	   mzlib/pretty
-           mzlib/list)
-  
-  (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)
-  ;;                ->
-  ;;                ((list list) -> syntax))
-  ;;          (contract (list
-  ;;                     ((((list list) -> syntax) list) -> 
-  ;;                      ((list list) -> syntax))
-  ;;                     (list -> ((list list) -> syntax))
-  ;;                     list)
-  ;;                    ->
-  ;;                    ((list list) -> syntax)))
-  ;; This is a major function of the compiler.  This function
-  ;; couples a list of tests together.  Here is where state is
-  ;; passed around to the various partially compiled tests so that
-  ;; 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)]
-               [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 (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)
-  ;;          (contract (syntax list) -> syntax)
-  ;;          (example (subst-bindings (syntax (car (cdr x))) 
-  ;;                                   (list (list '(cdr x) 
-  ;;                                                (syntax (cdr x)) 
-  ;;                                                'exp5)))
-  ;;                   -> (syntax (car 'exp5))))
-  ;; This function substitutes let bound variables names for the
-  ;; expressions that they represent.
-  (define (subst-bindings 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)
-  ;;          (contract (syntax list) -> syntax)
-  ;;          (example (subst-bindings (syntax (car (cdr x))) 
-  ;;                                   (list (list '(cdr x) 
-  ;;                                         (syntax (cdr x)) 
-  ;;                                         'exp5)))
-  ;;                   -> (syntax (car 'exp5))))
-  ;; 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)])
-         (if binding 
-             #`(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 (binding-exp e)))
-  
-  ;;!(function get-bind
-  ;;          (form (get-bind exp let-bound) -> binding)
-  ;;          (contract (any list) -> list))
-  ;; This function looks up the binding for a given expression exp
-  ;; in the binding list let-bound.  If the binding is found then the
-  ;; binding is returned if not then #f is returned.
-  (define (get-bind exp let-bound)
-    (cond [(memf (equal-bind-get (syntax-object->datum exp)) let-bound) => car]
-          [else #f]))
-  
-  ;;!(function exp-already-bound?
-  ;;          (form (exp-already-bound? exp let-bound) -> binding)
-  ;;          (contract (any list) -> boolean))
-  ;; This function looks up the binding for a given expression exp
-  ;; in the binding list let-bound.  If the binding is found then #t
-  ;; binding is returned if not then #f is returned.
-  (define (exp-already-bound? exp let-bound)
-    (ormap (equal-bind-get exp) let-bound))
-  
-  ;;!(function meta-couple
-  ;;          (form (meta-couple rendered-list failure-func 
-  ;;                             let-bound bvsf)
-  ;;                ->
-  ;;                ((list list) -> syntax))
-  ;;          (contract (list ((list list) -> syntax) list list)
-  ;;                    ->
-  ;;                    ((list list) -> syntax)))
-  ;; This function takes a list of rendered clauses which also have
-  ;; success functions attached and couples the whole lot together
-  ;; 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
-        (let* ([failed 
-                (lambda (let-bound)
-                  (lambda (sf bv)
-                    ((meta-couple (cdr rendered-list) 
-                                  failure-func 
-                                  let-bound 
-                                  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 mzlib/trace)
-  ;(trace meta-couple)
-  ;(trace couple-tests)
-  )
diff --git a/collects/mzlib/private/match/ddk-handlers.ss b/collects/mzlib/private/match/ddk-handlers.ss
deleted file mode 100644
index 2b2ad1dabe..0000000000
--- a/collects/mzlib/private/match/ddk-handlers.ss
+++ /dev/null
@@ -1,555 +0,0 @@
-(module ddk-handlers mzscheme
-  
-  (provide ddk-handlers@)
-  
-  (require "match-error.ss"
-           "match-helper.ss"
-           "coupling-and-binding.scm"
-           "render-helpers.ss"
-           "render-sigs.ss"
-           syntax/stx
-           mzlib/unit
-           mzlib/trace)
-  
-  (require-for-template mzscheme
-			"test-no-order.ss")
-  
-  (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))
-                           #,(let ([new-var (gensym 'exp)])
-                               #`(let ([#,new-var (car #,exp-name)])
-                                   #,(next-outer* #'the-pat
-                                                 #`#,new-var
-                                                 sf
-                                                 ;(append (map cons bound new-vars) bv)  
-                                                 bv
-                                                 ;; we always start
-                                                 ;; over with the old
-                                                 ;; bindings
-                                                 let-bound
-                                                 kf
-                                                 (lambda (let-bound)
-                                                   (lambda (sf bv) 
-                                                     ;(printf "let-bound is: ~a~n" let-bound)
-                                                     ;(printf "bv is: ~a ~a~n"
-                                                     ;        (map syntax-e (map car bv))
-                                                     ;        (map syntax-object->datum (map cdr bv)))
-                                                     #`(#,loop-name
-                                                        (cdr #,exp-name)
-                                                        #,@(map
-                                                            (lambda
-                                                                (b-var
-                                                                 bindings-var)
-                                                              (subst-bindings
-                                                               #`(cons
-                                                                  #,(get-bind-val
-                                                                     b-var
-                                                                     bv)
-                                                                  #,bindings-var)
-                                                               let-bound))
-                                                            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
-                                           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))
-                                            #,(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) ;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@
-    )
-  
-  )
diff --git a/collects/mzlib/private/match/define-struct.scm b/collects/mzlib/private/match/define-struct.scm
deleted file mode 100644
index b929ec041d..0000000000
--- a/collects/mzlib/private/match/define-struct.scm
+++ /dev/null
@@ -1,113 +0,0 @@
-
-(module define-struct mzscheme
-  (require-for-syntax "struct-helper.scm")
-  (provide define-struct*)
-  
-  (define-syntax (define-struct* stx)
-    (syntax-case stx ()
-      [(_ type [field-decl ...] decl ...)
-       (let* ([field-decls (map (mk-parse-field-decl #'type) (syntax->list #'(field-decl ...)))]
-              [decls (map parse-decl (syntax->list #'(decl ...)))]
-              [info (create-info #'type decls field-decls)])
-         (let ([init-field-k (length (info-init-fields info))]
-               [auto-field-k (length (info-auto-fields info))])
-           #`(begin
-               #,(if (info-include-define-values? info)
-                     #`(define-values #,(info-defined-names info)
-                         (let-values 
-                             ([(struct:x make-x x? x-ref x-set!)
-                               (make-struct-type 'type
-                                                 #,(info-super info)
-                                                 #,init-field-k
-                                                 #,auto-field-k
-                                                 #,(info-auto-v info)
-                                                 #,(info-props info)
-                                                 #,(info-insp info)
-                                                 #,(info-proc-spec info)
-                                                 #,(info-imm-k-list info)
-                                                 #,(info-guard info))])
-                           (values struct:x
-                                   make-x
-                                   x?
-                                   #,@(if (info-include-x-ref? info) #'(x-ref) #'())
-                                   #,@(if (info-include-x-set!? info) #'(x-set!) #'())
-                                   #,@(map (lambda (ref-field ref-posn)
-                                             #`(make-struct-field-accessor 
-                                                x-ref
-                                                #,ref-posn
-                                                '#,ref-field))
-                                           (info-ref-fields info)
-                                           (info-ref-posns info))
-                                   #,@(map (lambda (mut-field mut-posn)
-                                             #`(make-struct-field-mutator
-                                                x-set!
-                                                #,mut-posn
-                                                '#,mut-field))
-                                           (info-mut-fields info)
-                                           (info-mut-posns info)))))
-                     #'(begin))
-               #,(if (info-include-replacers? info)
-                     #`(define-struct-replacers type #,(info-name:constructor info)
-                         #,(map field-decl-field (info-init-fields info))
-                         #,(map field-decl-ref (info-init-fields info)))
-                     #'(begin))
-               #,(if (info-include-clone? info)
-                     (with-syntax ([(field-ref ...) (map field-decl-ref (info-init-fields info))])
-                       #`(define (#,(datum->syntax-object #'type (sym+ 'clone- #'type)) obj)
-                           (let ([field-ref (field-ref obj)] ...)
-                             (#,(info-name:constructor info) field-ref ...))))
-                     #'(begin))
-               #;#,(if (info-include-static-info? info)
-                       #`(define-syntax type
-                           (list-immutable
-                            (quote-syntax #,(info-name:struct-record info))
-                            (quote-syntax #,(info-name:constructor info))
-                            (quote-syntax #,(info-name:predicate info))
-                            (list-immutable
-                             #,@(map (lambda (ref) #`(quote-syntax #,ref))
-                                     (info-field-refs info)))
-                            (list-immutable
-                             #,@(map (lambda (mut) #`(quote-syntax #,mut))
-                                     (info-field-muts info)))
-                            ;; FIXME
-                            #t))
-                       #'(begin)))))]))
-  
-  (define-syntax (define-struct-replacers stx)
-    (syntax-case stx ()
-      [(_ type constructor (field ...) (accessor ...))
-       (with-syntax 
-           ([(replace ...)
-             (map (lambda (f) (datum->syntax-object #'type (sym+ 'replace- #'type '- f)))
-                  (syntax->list #'(field ...)))]
-            [all-field-bindings #'([field (accessor obj)] ...)]
-            [all-fields #'(field ...)])
-         #'(begin (define (replace obj newval)
-                    (let all-field-bindings
-                      (let ([field newval])
-                        (constructor . all-fields))))
-                  ...))]))
-  
-  )
-#|
-
-(require struct)
-(require mzlib/pretty)
-(print-struct #t)
-
-(define-syntax go
-  (syntax-rules ()
-    [(_ form)
-     (begin #;(pretty-print (syntax-object->datum (expand-once #'form)))
-            form)]))
-(go (define-struct* A 
-      [x (y (immutable)) (z (auto)) (w (auto))]
-      transparent (auto-value 'foo)))
-(go (define-struct* B
-      [q (r (immutable)) c]
-      (procedure (lambda (self) (list (B-q self) (B-r self))))
-      transparent clone replace))
-
-(define a1 (make-A 'athens 'sparta))
-(define b1 (make-B 'three 'fifty (lambda _ 'loch-ness)))
-|#
diff --git a/collects/mzlib/private/match/emit-assm.scm b/collects/mzlib/private/match/emit-assm.scm
deleted file mode 100644
index 5e9377af45..0000000000
--- a/collects/mzlib/private/match/emit-assm.scm
+++ /dev/null
@@ -1,94 +0,0 @@
-;; This library is used by match.ss
-
-(module emit-assm mzscheme
-  (provide emit assm)
-  
-  (require "match-helper.ss"
-	   "coupling-and-binding.scm")
-  
-  (require-for-template mzscheme)
-  
-  ;;!(function emit
-  ;;          (form (emit act-test-func ae let-bound sf bv kf ks)
-  ;;                ->
-  ;;                syntax)
-  ;;          (contract ((syntax -> syntax)
-  ;;                     syntax
-  ;;                     list
-  ;;                     list
-  ;;                     list
-  ;;                     (list list -> syntax)
-  ;;                     (list list -> syntax))
-  ;;                    ->
-  ;;                    syntax))
-  ;; emit's true function is to manage the tests-seen-so-far lists
-  ;; it decides whether a new test needs to be added to the list
-  ;; or whether this condition has already been tested for and if
-  ;; it is true emit calls the success function. If it has been
-  ;; 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 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 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
-            (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))])]))
-  )
diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss
deleted file mode 100644
index 7bf2ced030..0000000000
--- a/collects/mzlib/private/match/gen-match.ss
+++ /dev/null
@@ -1,157 +0,0 @@
-(module gen-match mzscheme
-  
-  (provide gen-match)
-  
-  (require mzlib/etc
-           syntax/stx
-           "match-helper.ss"
-           "match-error.ss"           
-           "coupling-and-binding.scm"		      
-           "update-counts.scm"
-           "update-binding-counts.scm"
-           "render-test-list.scm"
-           "render-helpers.ss"
-           "reorder-tests.scm"
-           "tag-negate-tests.scm"
-	   "simplify-patterns.ss"
-           "convert-pat.ss")
-  
-  (require-for-template mzscheme
-			mzlib/etc
-			"match-error.ss")
-  
-  ;; mark-patlist : listof[x] -> listof[(cons x #f)]
-  ;; 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 clauses)
-    (syntax-map (lambda (x) (mcons x #f)) clauses))
-  
-  ;; parse-clause : syntax -> syntax syntax maybe[syntax]
-  ;; takes in a pattern
-  ;; returns three values representing the pattern, the body and the failure symbol
-  
-  (define (parse-clause clause)
-    (syntax-case* clause (=>) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
-      [(pat) (match:syntax-err clause
-                               "missing action for pattern")]
-      [(pat (=> fail-sym)) 
-       (match:syntax-err clause
-                         "missing action for pattern")]
-      [(pat (=> fail-sym) body ...)
-       (values #'pat
-               #'(body ...)
-               #'fail-sym)]
-      [(pat body ...)
-       (values #'pat
-               #'(body ...) 
-               #f)]      
-      [pat (match:syntax-err #'pat
-                             "syntax error in clause")]))
-  
-  ;; test-list-with-success-func : syntax (cons syntax boolean) syntax success-func -> (cons test-list success-func)
-  ;; This function takes an exp which is to be matched, a marked
-  ;; clause, and a syntax-object that is for 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 exp pat/mark stx success-func)
-    (define-values (pat body fail-sym) (parse-clause (mcar pat/mark)))
-    (define (success fail let-bound)
-      (if (not success-func)
-          (lambda (sf bv)
-            ;; mark this pattern as reached
-            (set-mcdr! pat/mark #t)
-            (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-mcdr! pat/mark #t)
-            (let ((bv (map
-                       (lambda (bind)
-                         (cons (car bind)
-                               (subst-bindings
-                                (cdr bind)
-                                let-bound)))
-                       bv)))
-              (success-func sf bv)))))
-    (define test-list 
-      (let* ([cert (lambda (x) x)]
-	     [simplified-pat (simplify pat cert)])
-	(render-test-list simplified-pat exp cert stx)))
-    (cons test-list success))
-  
-  ;; gen-match : syntax list list syntax success-func -> syntax
-  
-  ;; 
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
-  ;; 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 ...)
-  ;;
-  ;; 
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/opt (gen-match exp patlist stx [success-func #f])
-    (begin-with-definitions
-      (when (stx-null? patlist)
-        (match:syntax-err stx "null clause list"))
-      ;; We set up the list of
-      ;; clauses so that one can mark that they have been "reached".
-      (define marked-clauses (mark-patlist patlist))
-      (define 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. 
-      (define rendered-list (map (lambda (clause) (test-list-with-success-func 
-                                                   exp clause stx success-func)) 
-                                 marked-clauses))
-      (update-counts rendered-list)
-      (tag-negate-tests rendered-list)
-      (update-binding-counts rendered-list)
-      ;; couple the partially compiled tests together into the final result.
-      (define compiled-exp 
-        ((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.
-      (define compiled-match
-        #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
-            #,compiled-exp))
-      (unreachable marked-clauses stx)
-      compiled-match))
-  )
diff --git a/collects/mzlib/private/match/getbindings.ss b/collects/mzlib/private/match/getbindings.ss
deleted file mode 100644
index c50378fca4..0000000000
--- a/collects/mzlib/private/match/getbindings.ss
+++ /dev/null
@@ -1,141 +0,0 @@
-(module getbindings mzscheme
-  (provide getbindings@)
-  
-  (require "coupling-and-binding.scm"
-           "update-binding-counts.scm"           
-           "render-helpers.ss"
-           "render-sigs.ss"
-           mzlib/unit)
-    
-  (require-for-template mzscheme)
-   
-  (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))
-    
-    (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 b)) 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@
-    )
-  )
diff --git a/collects/mzlib/private/match/getter-setter.scm b/collects/mzlib/private/match/getter-setter.scm
deleted file mode 100644
index f3b246da3c..0000000000
--- a/collects/mzlib/private/match/getter-setter.scm
+++ /dev/null
@@ -1,82 +0,0 @@
-;; This library is used by match.ss
-
-(module getter-setter mzscheme
-  (provide getter setter)
-  (require "coupling-and-binding.scm"
-           "match-helper.ss"
-           "match-error.ss"
-           syntax/stx)
-  (require-for-template mzscheme
-			"match-error.ss")
-  
-  ;;!(function setter
-  ;;          (form (setter e ident let-bound) -> syntax)
-  ;;          (contract (syntax syntax list) -> syntax)
-  ;;          (example (setter (syntax (mcar x)) (syntax here) '())
-  ;;                   ->
-  ;;          (syntax (lambda (y) (set-mcar! x y)))))
-  ;; This function takes an expression and returns syntax which
-  ;; represents a function that is able to set the value that the
-  ;; expression points to.
-  (define (setter e ident let-bound)
-    (define (subst e) (subst-bindings e let-bound))
-    (define (mk-setter s cxt) (datum->syntax-object cxt (symbol-append 'set- s '!)))
-    (syntax-case e (vector-ref unbox car cdr mcar mcdr)
-      [p
-       (not (stx-pair? #'p))
-       (match:syntax-err
-        ident
-        "set! pattern should be nested inside of a vector, box, or struct")]
-      [(vector-ref vector index)
-       #`(let ((x #,(subst #'vector)))
-           (lambda (y) (vector-set! x index y)))]
-      [(unbox boxed)
-       #`(let ((x #,(subst #'boxed)))
-           (lambda (y) (set-box! x y)))]
-      [(car exp)
-       (match:syntax-err
-        ident
-        "set! cannot be used within list")]
-      [(cdr exp)
-       (match:syntax-err
-        ident
-        "set! cannot be used within list")]
-      [(mcar exp)
-       #`(let ((x #,(subst #'exp)))
-           (lambda (y) (set-mcar! x y)))]
-      [(mcdr exp)
-       #`(let ((x #,(subst #'exp)))
-           (lambda (y) (set-mcdr! x y)))]
-      [(acc exp)
-       (let ([a (assq (syntax-object->datum #'acc) get-c---rs)])
-         (if a
-             #`(let ((x (#,(cadr a) #,(subst #'exp))))
-                 (lambda (y) (#,(mk-setter (cddr a) #'acc) x y)))
-             #`(let ((x #,(subst #'exp)))
-                 (lambda (y) 
-                   (#,(mk-setter (syntax-object->datum #'acc) #'acc) x y)))))]))
-  
-  ;;!(function getter
-  ;;          (form (getter e ident let-bound) -> syntax)
-  ;;          (contract (syntax syntax list) -> syntax)
-  ;;          (example (getter (syntax (car x)) (syntax here) '())
-  ;;                   ->
-  ;;          (syntax (lambda () (car x)))))
-  ;; This function takes an expression and returns syntax which
-  ;; represents a function that is able to get the value that the
-  ;; expression points to.
-  (define (getter e ident let-bound)
-    (define (subst e) (subst-bindings e let-bound))
-    (syntax-case e (vector-ref unbox car cdr)
-      [p
-       (not (stx-pair? #'p))
-       (match:syntax-err 
-        ident
-        "get! pattern should be nested inside of a list, vector or box")]
-      [(vector-ref vector index)
-       #`(let ((x #,(subst #'vector)))
-           (lambda () (vector-ref x index)))]
-      [(acc exp)
-       #`(let ((x #,(subst #'exp)))
-           (lambda () (acc x)))]))
-)
diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss
deleted file mode 100644
index 5c05e4a30b..0000000000
--- a/collects/mzlib/private/match/match-error.ss
+++ /dev/null
@@ -1,81 +0,0 @@
-(module match-error mzscheme
-  (provide (all-defined))
-  
-  (require mzlib/pregexp)
-  
-  (define-struct (exn:misc:match exn:fail) (value))
-  
-  (define match:error
-    (case-lambda
-      ((val)
-       (raise
-        (make-exn:misc:match
-         (format "match: no matching clause for ~e" val)
-         (current-continuation-marks)
-         val)))
-      ((val expr)
-       (raise
-        (make-exn:misc:match
-         (format "match: no matching clause for ~e: ~s" val expr)
-         (current-continuation-marks)
-         val)))))
-  
-  ;;! (function match:syntax-err
-  ;;          (form (match:syntax-err object message . detail) -> void)
-  ;;          (contract (any string . any) -> void)
-  ;;          (example (match:syntax-err (syntax here) "Bad error" (vector))
-  ;;                   -> void)
-  ;;          (contract object -> (normally a syntax object that
-  ;;                               that helps determine the source location
-  ;;                               of the error)))
-  ;; This function is used to report malformed match expressions.
-  
-  (define match:syntax-err (lambda (obj msg . detail)
-                             (apply
-                              raise-syntax-error
-                              'match
-                              msg
-                              obj
-                              detail)))
-  
-  (define (match:internal-err obj msg  . detail)
-    (apply raise-syntax-error '|internal match error| msg obj detail))
-  
-  
-  
-  ;;!(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 (mcdr x))
-             (fprintf
-              (current-error-port)
-              "Warning: unreachable match clause ~e in ~e~n"
-              (syntax-object->datum (mcar x))
-              (syntax-object->datum match-expr))))
-       plist)))
-  
-   ;; this makes pregexp errors a little more friendly
-  (define (pregexp-match-with-error regex str)
-    (if (or (string? regex)
-	    (bytes? regex)
-	    (regexp? regex)
-	    (byte-regexp? regex))
-        (pregexp-match regex str)
-        (error 'match:pregex 
-               (string-append 
-                "this pattern expects either a string, byte string, regexp or byte regexp,"
-                " given " (format "~e" regex) "; "
-                "other argument was " (format "~e" str)))))
-     
-  
-  )
diff --git a/collects/mzlib/private/match/match-expander-struct.ss b/collects/mzlib/private/match/match-expander-struct.ss
deleted file mode 100644
index ef326b0d3c..0000000000
--- a/collects/mzlib/private/match/match-expander-struct.ss
+++ /dev/null
@@ -1,7 +0,0 @@
-  (module match-expander-struct mzscheme
-    (require "define-struct.scm")
-    (provide (all-defined))
-    #;(provide (struct match-expander (match-xform std-xform)))
-    (define-struct* match-expander (plt-match-xform match-xform std-xform certifier) 
-      (procedure-field std-xform))
-    )
diff --git a/collects/mzlib/private/match/match-expander.ss b/collects/mzlib/private/match/match-expander.ss
deleted file mode 100644
index 697f4c2071..0000000000
--- a/collects/mzlib/private/match/match-expander.ss
+++ /dev/null
@@ -1,69 +0,0 @@
-(module match-expander mzscheme
-  (provide (all-defined))
-  (require-for-syntax "match-expander-struct.ss"
-                      "match-error.ss")
-  
-
-  
-  ;; (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)
-      (cond [(assoc v alist) => cadr]
-            [else #f]))
-    (define (parse args)
-      (let loop ([args args]
-                 [alist '()])
-        (if (null? args) 
-            alist
-            (let* ([stx-v (car args)]
-                   [v (syntax-e stx-v)])
-              (cond
-                [(not (keyword? v))
-                 (match:syntax-err stx-v "Argument must be a keyword")]
-                [(not (member v '(#:expression #:plt-match #:match)))
-                 (match:syntax-err stx-v "Keyword argument is not a correct keyword")]
-                [else                
-                 (loop (cddr args)
-                       (cons (list v (cadr args))
-                             alist))])))))
-    (syntax-case stx ()
-      [(_ id kw . rest)
-       (keyword? (syntax-e #'kw))
-       (let* ([args (syntax->list #'(kw . rest))]
-              [parsed-args (parse args)])
-         (with-syntax
-             ([match-xform (lookup #:match parsed-args)]
-              [plt-match-xform (lookup #:plt-match parsed-args)]
-              [std-xform (or (lookup #:expression parsed-args)
-                             #'(lambda (stx)
-                                 (match:syntax-err stx "This match expander must be used inside match")))])
-           (if (identifier? #'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))))))]
-
-      ;; implement legacy syntax
-      [(_ id plt-match-xform match-xform std-xform)
-       #'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)]
-      [(_ id plt-match-xform std-xform)
-       #'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
-      [(_ id plt-match-xform) 
-       #'(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
deleted file mode 100644
index 2f6c23e3c6..0000000000
--- a/collects/mzlib/private/match/match-helper.ss
+++ /dev/null
@@ -1,482 +0,0 @@
-(module match-helper mzscheme
-  
-  (provide (all-defined)
-           (all-from "syntax-utils.ss"))
-  
-  (require syntax/struct
-           "syntax-utils.ss"
-           "match-error.ss"
-           mzlib/list)
-  
-  (require-for-template mzscheme)
-  
-  ;; define a syntax-transformer in terms of a two-argument function  
-  (define-syntax define-proc 
-    (syntax-rules ()
-      [(_ nm func)
-       (define-syntax (nm stx) (func stx stx))]))
-  
-  ;; bind an identifier to be syntax/loc with a particular location, in an expression
-  (define-syntax md-help
-    (syntax-rules ()
-      [(md-help id stx e)
-       (let-syntax ([id (syntax-rules () [(id arg) (syntax/loc stx arg)])])
-         e)]))
-  
-  (define (constant-data? v)
-    (or
-     (string? v)
-     (boolean? v)
-     (char? v)
-     (number? v)
-     (keyword? v)
-     (bytes? v)))
-  
-  
-  ;;!(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 . l)
-    (define (data->string x)
-      (cond
-        [(symbol? x) (symbol->string x)]
-        [(number? x) (number->string x)]
-        [else x]))      
-    (string->symbol (apply string-append (map data->string l))))
-  
-  ;;!(function struct-pred-accessors-mutators
-  ;;          (form (struct-pred-accessors-mutators struct-name)
-  ;;                ->
-  ;;                (values pred accessors mutators parental-chain))
-  ;;          (contract (syntax-object)
-  ;;                     ->
-  ;;                     (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
-  ;; order.  The last is a list of supertypes of this struct. An
-  ;; error is raised if the struct-name is not bound to a
-  ;; structure.
-  (define (struct-pred-accessors-mutators struct-name)
-    (define accessors-index 3)
-    (define mutators-index 4)
-    (define pred-index 2)
-    (define super-type-index 5)
-    (define (failure-thunk)
-      (match:syntax-err struct-name 
-                        "not a defined structure"))
-    (define (local-val sn) (syntax-local-value sn failure-thunk))
-    ;; accessor/mutator lists are stored in reverse order, and can contain #f
-    ;; we only filter out a mutator if the accessor is also false.
-    ;; this function returns 2 lists of the same length if the inputs were the same length
-    (define (handle-acc/mut-lists accs muts)
-      (let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (map list accs muts))]
-                    [(accs muts) (values (map car filtered-lists)
-                                         (map cadr filtered-lists))])
-        (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 
-                    (extract-struct-info (local-val struct-name))
-                    super-type-index)])
-        (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 (let ([v (local-val struct-name)])
-                             (unless (struct-declaration-info? v) 
-                               (failure-thunk))
-                             (extract-struct-info v)))
-    
-    (define (ref-info i) (list-ref info-on-struct i))
-    
-    (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)))
-    )
-  
-  
-  
-  
-  
-  
-  ;;!(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 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) '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   )
-                                        (cadddr srch)))
-                                      ((equal?
-                                        (car x)
-                                        'struct-pred)
-                                       (equal? 
-                                        (cadr srch)
-                                        ;; we use cadddr here to access the expression
-                                        ;; because struct predicates carry some extra baggage
-                                        (cadddr x)))
-                                      (else (equal?
-                                             (cadr x)
-                                             (cadr srch)))))
-                           (mem (cdr l)))))))
-              ((eq? (car srch) 'list?) 
-               (let mem ((l l))
-                 (if (null? l)
-                     #f
-                     (let ((x (car l)))
-                       (or (and (equal?
-                                 (cadr x)
-                                 (cadr srch))
-                                (disjoint?
-                                 x)
-                                (not (memq (car x)
-                                           '(list?
-                                             pair?
-                                             null?))))
-                           (mem (cdr l)))))))
-              ((vec-structure? srch) 
-               (let mem ((l l))
-                 (if (null? l)
-                     #f
-                     (let ((x (car l)))
-                       (or (and (equal?
-                                 (cadr x)
-                                 (cadr srch))
-                                (or (disjoint?
-                                     x)
-                                    (vec-structure?
-                                     x))
-                                (not (equal?
-                                      (car x)
-                                      'vector?))
-                                (not (equal?
-                                      (car x)
-                                      (car srch))))
-                           (equal?
-                            x
-                            `(not (vector?
-                                   ,(cadr srch))))
-                           (mem (cdr l)))))))
-              (else #f))))))
-  
-  ;;!(function equal-test?
-  ;;          (form (equal-test? tst) -> (or symbol
-  ;;                                         #f))
-  ;;          (contract s-exp -> (or symbol
-  ;;                                         #f))
-  ;;          (example (equal-test? '(equal? x 5))
-  ;;                   -> 'number?)
-  ;;          (example (equal-test? '(symbol? x))
-  ;;                   -> #f))
-  ;; This function returns false if the s-exp does not represent an
-  ;; "equal?" test.  If it does then this function returns a
-  ;; predicate for the data type that the test is testing.
-  (define (equal-test? tst)
-    (and (eq? (car tst) 'equal?)
-         (let ((p (caddr tst)))
-           (cond
-             ((string? p) 'string?)
-             ((boolean? p) 'boolean?)
-             ((char? p) 'char?)
-             ((number? p) 'number?)
-             ((and (pair? p)
-                   (pair? (cdr p))
-                   (null? (cddr p))
-                   (eq? 'quote (car p))
-                   (symbol? (cadr p))) 'symbol?)
-             (else #f)))))
-  
-  (define match:disjoint-predicates
-    '(struct-pred null? pair? symbol? boolean? number? string? char?
-                  procedure? vector?
-                  box? promise?)) 
-  
-  (define match:vector-structures '())
-  
-  ;;!(function disjoint?
-  ;;          (form (disjoint? tst))
-  ;;          (contract s-exp -> bool)
-  ;;          (example (disjoint? 'pair?) -> #t))
-  ;; This function retirns true if the predicate is disjoint.
-  (define (disjoint? tst)
-    (memq (car tst) match:disjoint-predicates))
-  
-  (define (vec-structure? tst)
-    (memq (car tst) match:vector-structures))
-
-  ;;!(function add-a
-  ;;          (form (add-a exp-syntax) -> syntax)
-  ;;          (contract syntax -> syntax)
-  ;;          (example (add-a (syntax (cdr x))) -> (syntax (cadr x))))
-  ;; Add car operation, ie. given (c...r x), return (ca...r x).
-  (define add-a
-    (lambda (exp-syntax)
-      (syntax-case exp-syntax ()
-        ((car-thing exp)
-         (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
-           (if new
-               (quasisyntax/loc exp-syntax (#,(cadr new) exp))
-               (syntax/loc exp-syntax (car (car-thing exp))))))
-        (exp (syntax/loc exp-syntax (car exp))))))
-  
-  ;;!(function add-d
-  ;;          (form (add-d exp-syntax) -> syntax)
-  ;;          (contract syntax -> syntax)
-  ;;          (example (add-a (syntax (cdr x))) -> (syntax (cddr x))))
-  ;; Add cdr operation, ie. given (c...r x), return (cd...r x).
-  (define add-d
-    (lambda (exp-syntax)
-      (syntax-case exp-syntax ()
-        ((car-thing exp)
-         (let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
-           (if new
-               (quasisyntax/loc exp-syntax (#,(cddr new) exp))
-               (syntax/loc exp-syntax (cdr (car-thing exp))))))
-        (exp (syntax/loc exp-syntax (cdr exp))))))
-  
-  (define c---rs '((car caar . cdar)
-                   (cdr cadr . cddr)
-                   (caar caaar . cdaar)
-                   (cadr caadr . cdadr)
-                   (cdar cadar . cddar)
-                   (cddr caddr . cdddr)
-                   (caaar caaaar . cdaaar)
-                   (caadr caaadr . cdaadr)
-                   (cadar caadar . cdadar)
-                   (caddr caaddr . cdaddr)
-                   (cdaar cadaar . cddaar)
-                   (cdadr cadadr . cddadr)
-                   (cddar caddar . cdddar)
-                   (cdddr cadddr . cddddr)))
-  
-  (define get-c---rs '((caar car . car)
-                       (cadr cdr . car)
-                       (cdar car . cdr)
-                       (cddr cdr . cdr)
-                       (caaar caar . car)
-                       (caadr cadr . car)
-                       (cadar cdar . car)
-                       (caddr cddr . car)
-                       (cdaar caar . cdr)
-                       (cdadr cadr . cdr)
-                       (cddar cdar . cdr)
-                       (cdddr cddr . cdr)
-                       (caaaar caaar . car)
-                       (caaadr caadr . car)
-                       (caadar cadar . car)
-                       (caaddr caddr . car)
-                       (cadaar cdaar . car)
-                       (cadadr cdadr . car)
-                       (caddar cddar . car)
-                       (cadddr cdddr . car)
-                       (cdaaar caaar . cdr)
-                       (cdaadr caadr . cdr)
-                       (cdadar cadar . cdr)
-                       (cdaddr caddr . cdr)
-                       (cddaar cdaar . cdr)
-                       (cddadr cdadr . cdr)
-                       (cdddar cddar . cdr)
-                       (cddddr cdddr . cdr)))
-  
-  ;;!(function stx-dot-dot-k?
-  ;;          (form (stx-dot-dot-k? syn) -> bool)
-  ;;          (contract syntax -> bool)
-  ;;          (example (stx-dot-dot-k? (syntax ..3)) -> #t))
-  ;; This function is a predicate that returns true if the argument
-  ;; is syntax represents a ... or ___ syntax where the last dot or
-  ;; underscore can be an integer
-  (define stx-dot-dot-k?
-    (lambda (syn)
-      (dot-dot-k? (syntax-object->datum syn))))
-  
-  ;;!(function implied
-  ;;          (form (implied test) -> list)
-  ;;          (contract s-exp -> list))
-  ;; This function is given a s-expression for a test and returns a
-  ;; list of tests that are implied by that test.  The implied test
-  ;; would have to be true if the argument is true.
-  (define (implied test)
-    (let* ((pred (car test))
-           (exp (cadr test)))
-      (cond
-        ((equal? pred 'equal?)
-         (let ((ex (caddr test)))
-           (cond ((string? ex)
-                  (list `(string? ,ex)))
-                 ((boolean? ex)
-                  (list `(boolean? ,exp)))
-                 ((char? ex)
-                  (list `(char? ,exp)))
-                 ((number? ex)
-                  (list `(number? ,exp)))
-                 ((and (pair? ex)
-                       (eq? 'quote (car ex)))
-                  (list `(symbol? ,exp)))
-                 (else '()))))
-        ((equal? pred 'null?)
-         (list `(list? ,exp)))
-        (else '()))))
-  
-  
-  ;;! (function pattern-var?
-  ;;    (form (pattern-var? pattern-element) -> bool)
-  ;;    (contract syntax -> bool)
-  ;;    (example (pattern-var? #'x) -> #t)
-  ;;    )
-  ;; This function takes a syntax object and determines if it
-  ;; qualifies as a pattern variable.
-  (define (pattern-var? x)
-    (let ([x (syntax-object->datum x)])
-      (and (symbol? x)
-           (not (dot-dot-k? x))
-           (not (memq x '(_
-                          quasiquote
-                          quote
-                          unquote
-                          unquote-splicing
-                          ;                      hash-table
-                          ;                      list-no-order
-                          ;                       list-rest
-                          ;                       list
-                          ;                       app
-                          ;                       struct
-                          ;                       var
-                          ;                       vector
-                          ;                       box
-                          ;                       ?
-                          ;                       and
-                          ;                       or
-                          ;                       not
-                          ;                       set!
-                          ;                       get!
-                          ))))))
-  
-  ;;!(function dot-dot-k?
-  ;;          (form (dot-dot-k? s) -> bool)
-  ;;          (contract any -> bool)
-  ;;          (example (dot-dot-k? '..3) -> 3))
-  ;; This function is a predicate that returns the number of elements required 
-  ;; by the pattern
-  ;; (dot-dot-k? '..3) -> 3
-  ;; (dot-dot-k? '...) -> 0
-  (define (dot-dot-k? s)
-    (define (./_ c)
-      (or (equal? c #\.)
-          (equal? c #\_)))
-    (and (symbol? s)
-         (if (memq s '(... ___)) 0
-             (let* ((s (symbol->string s)))                    
-               (and (<= 3 (string-length s))
-                    (./_ (string-ref s 0))
-                    (./_ (string-ref s 1))                    
-                    (string->number
-                     (substring s 2)))))))
-  
-  
-  (define node-count (make-parameter 0))
-  
-  (define convert-patterns? (make-parameter #f))
-  
-  (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
deleted file mode 100644
index 69bbbd3be3..0000000000
--- a/collects/mzlib/private/match/match-internal-func.ss
+++ /dev/null
@@ -1,104 +0,0 @@
-(module match-internal-func mzscheme
-  
-  (provide (all-defined))
-  
-  (require-for-syntax "gen-match.ss"                      
-                      "match-helper.ss"
-                      "match-error.ss") 
-  
-  (require mzlib/etc           
-           mzlib/list
-           "match-expander.ss"
-           "match-error.ss")
-  
-  
-  (define-syntax (match stx)
-    (syntax-case stx ()
-      [(_ exp . clauses)       
-       (with-syntax ([body (gen-match #'x #'clauses stx)])
-         (syntax/loc stx (let ([x exp]) body)))]))
-  
-  (define-syntax (match-lambda stx)
-    (syntax-case stx ()
-      [(k . clauses)
-       (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
-  
-  (define-syntax (match-lambda* stx)
-    (syntax-case stx ()
-      [(k . clauses)
-       (syntax/loc stx (lambda exp (match exp . clauses)))]))
-  
-  ;; there's lots of duplication here to handle named let
-  ;; some factoring out would do a lot of good
-  (define-syntax (match-let stx)
-    (syntax-case stx ()
-      ;; an empty body is an error
-      [(_ nm (clauses ...))
-       (identifier? #'nm)
-       (match:syntax-err stx "bad syntax (empty body)")]
-      [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
-      ;; with no bindings, there's nothing to do
-      [(_ name () body ...) 
-       (identifier? #'name)
-       (syntax/loc stx (let name () body ...))]
-      [(_ () body ...) (syntax/loc stx (let () body ...))]
-      ;; optimize the all-variable case            
-      [(_ ([pat exp]...) body ...)
-       (andmap pattern-var? (syntax->list #'(pat ...)))
-       (syntax/loc stx (let name ([pat exp] ...) body ...))]           
-      [(_ name ([pat exp]...) body ...)
-       (and (identifier? (syntax name))
-            (andmap pattern-var? (syntax->list #'(pat ...))))
-       (syntax/loc stx (let name ([pat exp] ...) body ...))]
-      ;; now the real cases
-      [(_ name ([pat exp] ...) . body)
-       (syntax/loc stx (letrec ([name (match-lambda* ((list pat ...) . body))]) 
-                         (name exp ...)))]
-      [(_ ([pat exp] ...) . body)
-       (syntax/loc stx (match (list exp ...) [(list pat ...) . body]))]))
-  
-  (define-syntax (match-let* stx)
-    (syntax-case stx ()
-      [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
-      ((_ () body ...)
-       (syntax/loc stx (let* () body ...)))
-      ((_ ([pat exp] rest ...) body ...)
-       (if (pattern-var? (syntax pat))
-           (syntax/loc stx (let ([pat exp])
-               (match-let* (rest ...) body ...)))
-           (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))))
-       ))
-  
-  (define-syntax (match-letrec stx)
-    (syntax-case stx ()
-      [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
-      [(_ ([pat exp] ...) . body)
-       (andmap pattern-var?
-               (syntax->list #'(pat ...)))
-       (syntax/loc stx (letrec ([pat exp] ...) . body))]
-      [(_ ([pat exp] ...) . body)
-       (syntax/loc stx (let ()
-           (match-define (list pat ...) (list exp ...))
-           . body))]))
-  
-  (define-syntax (match-define stx)
-    (syntax-case stx ()
-      [(_ pat exp)
-       (identifier? #'pat)
-       (syntax/loc stx (define pat exp))]
-      [(_ pat exp)
-       (let ([**match-bound-vars** '()])
-         (with-syntax ([compiled-match
-                        (gen-match #'the-exp                        
-                                   #'((pat never-used))
-                                   stx
-                                   (lambda (sf bv)
-                                     (set! **match-bound-vars** bv)
-                                     (with-syntax ([((vars . vals) ...) (reverse bv)])
-                                       #'(values vals ...))))]
-                       [(vars ...) (map car (reverse **match-bound-vars**))])
-           (syntax/loc stx
-             (define-values (vars ...)
-               (let ([the-exp exp])
-                 compiled-match)))))]))
-  )
diff --git a/collects/mzlib/private/match/observe-step.ss b/collects/mzlib/private/match/observe-step.ss
deleted file mode 100644
index 55bbb8d1a8..0000000000
--- a/collects/mzlib/private/match/observe-step.ss
+++ /dev/null
@@ -1,43 +0,0 @@
-(module observe-step mzscheme
-  (provide observe-step)
-  
-  (define current-expand-observe
-    (dynamic-require ''#%expobs 'current-expand-observe))
-  
-  (define (observe-step pre mpre mpost post)
-    (define (call-obs ev . args) 
-      (let ([obs values #;(current-expand-observe)])
-        (if obs 
-            (let ([evn (case ev
-                         [(visit) 0]
-                         [(enter-prim) 6]
-                         [(prim-stop) 100]
-                         [(exit-prim) 7]
-                         [(return) 2]
-                         [(macro-enter) 8]
-                         [(macro-exit) 9]
-                         [(macro-pre) 21]
-                         [(macro-post) 22]
-                         [(local-enter) 130]
-                         [(local-exit) 131]
-                         [(local-pre) 132]
-                         [(local-post) 133])])
-              (apply obs evn args)))))
-    
-    (call-obs 'local-enter pre)
-    (call-obs 'local-pre pre)
-    (call-obs 'visit pre)
-    (call-obs 'macro-enter pre)
-    (call-obs 'macro-pre mpre)
-    (call-obs 'macro-post mpost)
-    (call-obs 'macro-exit post)
-    (call-obs 'visit post)
-    (call-obs 'enter-prim post)
-    (call-obs 'prim-stop #f)
-    (call-obs 'exit-prim post)
-    (call-obs 'return post)
-    (call-obs 'local-post post)
-    (call-obs 'local-exit post)
-    )
-
-  )
diff --git a/collects/mzlib/private/match/parse-quasi.scm b/collects/mzlib/private/match/parse-quasi.scm
deleted file mode 100644
index 58e914fd29..0000000000
--- a/collects/mzlib/private/match/parse-quasi.scm
+++ /dev/null
@@ -1,135 +0,0 @@
-;; This library is used by match.ss
-(module parse-quasi mzscheme
-  (provide (all-defined))
-  (require "match-error.ss"
-           "match-helper.ss"
-           mzlib/etc
-           syntax/stx)
-  
-  (require-for-template mzscheme
-                        "match-error.ss")
-
-  ;; Raise an error from a quasi-pattern
-  (define q-error 
-    (opt-lambda (syn [msg ""])
-      (match:syntax-err
-       syn
-       (string-append "syntax error in quasi-pattern: " msg))))     
-  
-  ;;!(function parse-quasi
-  ;;          (form (parse-quasi syn) -> syntax)
-  ;;          (contract syntax -> syntax))
-  ;; This function parses a quasi pattern in to a regular pattern
-  ;; and returns it.  This function does not parse the quasi pattern
-  ;; recursively in order to find nested quasi patterns.  It only
-  ;; parses the top quasi pattern.
-  (define (parse-quasi stx)    
-    (define parse-q
-      (lambda (phrase)
-        ;(write phrase)(newline)
-        (syntax-case phrase (quasiquote unquote unquote-splicing)
-          (p
-           (let ((pat (syntax-object->datum (syntax p))))
-             (or (constant-data? pat)
-                 (dot-dot-k? pat)))
-           (syntax p))
-          (p
-           (stx-null? (syntax p))
-           (syntax/loc stx (list)))
-          (p
-           ;; although it is not in the grammer for quasi patterns
-           ;; it seems important to not allow unquote splicing to be
-           ;; a symbol in this case `,@(a b c). In this unquote-splicing
-           ;; is treated as a symbol and quoted to be matched.
-           ;; this is probably not what the programmer intends so
-           ;; it may be better to throw a syntax error
-           (identifier? (syntax p)) 
-           (syntax/loc stx 'p))
-          ;; ((var p)  ;; we shouldn't worry about this in quasi-quote
-          ;;  (identifier? (syntax p))
-          ;;  (syntax/loc phrase 'p))
-          (,p (syntax p))
-          (,@pat
-             (q-error (syntax ,@pat) "unquote-splicing not nested in list"))
-          ((x . y) 
-           (let* ([list-type 'list]
-                  [result
-                   (let loop 
-                     ((l (syntax-e (syntax (x . y)))))
-                     ;(write l)(newline)
-                     (cond [(null? l) '()]
-                           [(and (stx-pair? (car l))
-                                 (equal? (car (syntax-object->datum (car l))) 
-                                         'unquote-splicing))
-                            (let ([first-car  
-                                   (syntax-case (car l) 
-                                     (unquote-splicing quasiquote)
-                                     [,@(q p)  ;; have to parse forward here
-                                      (or (module-identifier=? #'quasiquote #'q)
-                                          (module-identifier=? #'quote #'q))
-                                      (let ((pq (parse-q (syntax p))))
-                                        (if (stx-list? pq)
-                                            (cdr (syntax->list pq))
-                                            (begin 
-                                              (q-error (syntax ,@`p)
-                                                       "unquote-splicing not followed by list"))))]
-                                     [,@p
-                                        (if (and (stx-list? (syntax p))
-                                                 (memq (syntax-e (car (syntax->list #'p))) '(list list-rest)))
-                                            (cdr (syntax->list (syntax p)))
-                                            (begin ; (write (syntax-e (syntax p))) 
-                                              (q-error (syntax ,@p)
-                                                       "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  
-                                  (let ((res (parse-q (syntax ,p))))
-                                    (set! list-type 'list-rest)
-                                    `(,@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))])
-                                   (set! list-type 'list-rest)
-                                   `(,@first-car ,res))]))]
-                           [else 
-                            (syntax-case (cdr l) (unquote unquote-splicing)
-                              (,@p (q-error (syntax p) 
-                                            "unquote-splicing can not follow dot notation"))
-                              (,p  (begin 
-                                     (set! list-type 'list-rest)
-                                     (list (parse-q (car l))  
-                                           (parse-q (syntax ,p)))))
-                              (p (or (stx-pair? (syntax p))
-                                     (stx-null? (syntax p)))
-                                 (cons (parse-q (car l))
-                                       (loop (syntax-e (syntax p)))))
-                              (p ;; must be an atom
-                               (begin 
-                                 (set! list-type 'list-rest)
-                                 (list (parse-q (car l)) 
-                                       (parse-q (syntax p))))))]))])             
-             (quasisyntax/loc stx (#,list-type #,@result))))
-          (p
-           (vector? (syntax-object->datum (syntax p)))
-           (quasisyntax/loc 
-               stx
-             (vector #,@(cdr 
-                         (syntax-e 
-                          (parse-q
-                           (quasisyntax/loc 
-                               stx 
-                             #,(vector->list (syntax-e (syntax p))))))))))
-          (p
-           (box? (syntax-object->datum (syntax p)))
-           (quasisyntax/loc 
-               stx
-             (box #,(parse-q (unbox (syntax-e (syntax p)))))))
-          (p (q-error (syntax p))))))
-    (parse-q stx))
-  
-  )
-
diff --git a/collects/mzlib/private/match/render-helpers.ss b/collects/mzlib/private/match/render-helpers.ss
deleted file mode 100644
index d1beb9abfc..0000000000
--- a/collects/mzlib/private/match/render-helpers.ss
+++ /dev/null
@@ -1,171 +0,0 @@
-(module render-helpers mzscheme
-  
-  (provide (all-defined))  
-  
-  (require "match-helper.ss"
-           "match-error.ss"
-	   "emit-assm.scm"
-	   "getter-setter.scm"
-	   "parse-quasi.scm"
-           "test-structure.scm"
-           mzlib/etc
-           mzlib/trace)
-
-  (require-for-template mzscheme
-			mzlib/list
-			"match-error.ss")
-  
-  (provide (all-from "emit-assm.scm")
-           (all-from "getter-setter.scm")
-           (all-from "parse-quasi.scm"))
-  
-  (define-syntax define/opt
-    (syntax-rules ()
-      [(_ (nm args ...) body ...)
-       (define nm (opt-lambda (args ...) body ...))]))
-  
-      
-  
-  (define (append-if-necc sym stx)
-    (syntax-case stx ()
-      [() #'(list)]
-      [(a ...) #`(#,sym a ...)]
-      [p #'p]))
-
-  (define (get-bind-val b-var bv-list)
-    (cond [(assq b-var bv-list) => cdr]
-          [(assq
-            (syntax-object->datum b-var)
-            (map (lambda (x)
-                   (cons 
-                    (syntax-object->datum (car x)) (cdr x))) 
-                 bv-list))
-           => cdr]
-          [else (error 'var-not-found)]))
-  
-  
-    ;;!(function proper-hash-table-pattern?
-    ;;          (form (proper-hash-table-pattern? pat-list) -> bool)
-    ;;          (contract list-of-syntax -> bool))
-    ;; This function returns true if there is no ddk in the list of
-    ;; patterns or there is only a ddk at the end of the list.
-    (define (proper-hash-table-pattern? pat-list)
-      (cond ((null? pat-list) #t)
-            (else
-             (let ((ddk-list (ddk-in-list? pat-list)))
-               (or (not ddk-list)
-                   (and ddk-list
-                        (ddk-only-at-end-of-list? pat-list)))))))
-    
-    ;;!(function ddk-in-list?
-    ;;          (form (ddk l) -> bool)
-    ;;          (contract list-of-syntax -> bool))
-    ;; This is a predicate that returns true if there is a ddk in the
-    ;; list.
-    (define (ddk-in-list? l)
-      (not (andmap (lambda (x) (not (stx-dot-dot-k? x))) l)))
-    
-    ;;!(function ddk-only-at-end-of-list?
-    ;;          (form (ddk-only-at-end-of-list? l) -> bool)
-    ;;          (contract list-of-syntax -> bool))
-    ;; This is a predicate that returns true if there is a ddk at the
-    ;; end of the list and the list has at least one item before the ddk.
-    (define ddk-only-at-end-of-list?
-      (lambda (l)
-        '(match
-             l
-           (((not (? stx-dot-dot-k?)) ..1 a) (stx-dot-dot-k? a)))
-        (let ((x l))
-          (if (list? x)
-              (let ddnnl26305 ((exp26306 x) (count26307 0))
-                (if (and (not (null? exp26306))
-                         ((lambda (exp-sym) (if (stx-dot-dot-k? exp-sym) #f #t))
-                          (car exp26306)))
-                    (ddnnl26305 (cdr exp26306) (add1 count26307))
-                    (if (>= count26307 1)
-                        (if (and (pair? exp26306) (null? (cdr exp26306)))
-                            ((lambda (a) (stx-dot-dot-k? a)) (car exp26306))
-                            #f)
-                        #f)))
-              #f))))
-    
-    ;;!(function ddk-only-at-end-of-vector?
-    ;;          (form (ddk-only-at-end-of-vector? vec) -> bool)
-    ;;          (contract vector -> bool))
-    ;; This is a predicate that returns true if there is a ddk at the
-    ;; end of the vector and the list has at least one item before the ddk.
-    (define ddk-only-at-end-of-vector?
-      (lambda (vec)
-        '(match
-             vec
-           (#((not (? stx-dot-dot-k?)) ..1 a) #t))
-        ;; the following is expanded from the above match expression
-        (let ((x vec))
-          (let ((match-failure
-                 (lambda () #f)))
-            (if (vector? x)
-                (let ((lv32956 (vector-length x)))
-                  (if (>= lv32956 2)
-                      (let ((curr-ind32957 0))
-                        (let vloop32958 ((count32959 curr-ind32957))
-                          (let ((fail32961
-                                 (lambda (count-offset32962 index32963)
-                                   (if (>= count-offset32962 1)
-                                       (if (= index32963 lv32956)
-                                           (match-failure)
-                                           (let ((cindnm32965 (add1 index32963)))
-                                             (if (>= cindnm32965 lv32956)
-                                                 ((lambda (a) #t) 
-                                                  (vector-ref x index32963))
-                                                 (match-failure))))
-                                       (match-failure)))))
-                            (if (= lv32956 count32959)
-                                (fail32961 (- count32959 curr-ind32957) count32959)
-                                (if (stx-dot-dot-k? (vector-ref x count32959))
-                                    (fail32961 (- count32959 curr-ind32957) 
-                                               count32959)
-                                    (let ((arglist (list)))
-                                      (apply vloop32958 (add1 count32959) 
-                                             arglist)))))))
-                      (match-failure)))
-                (match-failure))))))
-    
-    ;;!(function ddk-in-vec?
-    ;;          (form (ddk-in-vec? vec stx) -> (integer or #f))
-    ;;          (contract (vector syntax) -> (integer or bool)))
-    ;; this function returns the total of the k's in a vector of syntax
-    ;; it also insure that the ..k's are not consecutive
-    (define ddk-in-vec?
-      (lambda (vec stx)
-        ;; make sure first element is not ddk
-        (if (stx-dot-dot-k? (vector-ref vec 0))
-            (match:syntax-err
-             stx
-             "vector pattern cannot start with ..k syntax")
-            (let ((vlength (vector-length vec))
-                  (flag #f))
-              (letrec ((check-vec
-                        (lambda (last-stx index)
-                          (if (= index vlength)
-                              0
-                              (let ((k-prev (stx-dot-dot-k? last-stx))
-                                    (k-curr (stx-dot-dot-k? (vector-ref vec 
-                                                                        index))))
-                                (cond
-                                  ((and k-prev k-curr)
-                                   (match:syntax-err
-                                    stx
-                                    "consecutive ..k markers are not allowed"))
-                                  (k-curr
-                                   (begin
-                                     (set! flag #t)
-                                     (+ (- k-curr 2) (check-vec (vector-ref vec 
-                                                                            index) 
-                                                                (add1 index)))))
-                                  (else
-                                   (check-vec (vector-ref vec index) 
-                                              (add1 index)))))))))
-                (let ((res (check-vec (vector-ref vec 0) 1)))
-                  (if flag res #f)))))))
-  
-  )
diff --git a/collects/mzlib/private/match/render-sigs.ss b/collects/mzlib/private/match/render-sigs.ss
deleted file mode 100644
index 9b4208556e..0000000000
--- a/collects/mzlib/private/match/render-sigs.ss
+++ /dev/null
@@ -1,12 +0,0 @@
-(module render-sigs mzscheme
-  (require mzlib/unit)
-  
-  (provide (all-defined))
-  
-  (define-signature render-test-list^ (render-test-list))
-  
-  (define-signature ddk-handlers^ (handle-end-ddk-list handle-inner-ddk-list handle-ddk-vector handle-ddk-vector-inner))
-  
-  (define-signature getbindings^ (getbindings create-test-func next-outer next-outer*))
-    
-  )
diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss
deleted file mode 100644
index 7f763c316e..0000000000
--- a/collects/mzlib/private/match/render-test-list-impl.ss
+++ /dev/null
@@ -1,616 +0,0 @@
-(module render-test-list-impl mzscheme
-  
-  (require syntax/stx)
-  
-  (require "match-error.ss"
-           "match-helper.ss"
-           "test-structure.scm"
-           "coupling-and-binding.scm"
-           "update-counts.scm"
-           "update-binding-counts.scm"
-           "reorder-tests.scm"
-           "match-expander-struct.ss"
-           "render-helpers.ss")
-  
-  (require "render-sigs.ss"
-           mzlib/unit)
-  
-  (require-for-syntax "match-helper.ss"
-                      "match-expander-struct.ss"
-                      "test-no-order.ss")
-  
-  (require-for-template mzscheme
-			"match-error.ss"
-			"test-no-order.ss"
-                        "match-helper.ss")
-  
-  (provide render-test-list@)
-  
-  
-  
-  
-  (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!))]))]))
-    
-    
-    ;;!(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) (apply 
-                       append
-                       (map (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)
-                                                   (let ([v (create-test-func
-                                                    p
-                                                    sf
-                                                    let-bound
-                                                    bind-map
-                                                    #f
-                                                    cert)])
-                                                     (printf "~s ~s ~s\n" 
-                                                             (syntax-object->datum p)
-                                                             (syntax-object->datum v)
-                                                             (continuation-mark-set->context
-                                                              (current-continuation-marks)))
-                                                     v))
-                                                 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)
-             ae (lambda (exp) #`(hash-table? #,exp)))
-            
-            (let ([mod-pat
-                   (lambda (pat)
-                     (syntax-case* pat (var) stx-equal?
-                       [(var id) pat]
-                       [(keypat valpat) (syntax/loc pat (list keypat valpat))]
-                       [_ pat]))])
-              (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 #,@(syntax-map mod-pat #'(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
-				       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)))
-            (apply
-             append
-             (map
-              (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)))
-         (begin
-           (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)))))))
-        
-        ;; 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
-             `(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@
-    )
-  
-  )
diff --git a/collects/mzlib/private/match/render-test-list.scm b/collects/mzlib/private/match/render-test-list.scm
deleted file mode 100644
index 1950b33dbd..0000000000
--- a/collects/mzlib/private/match/render-test-list.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-;; This library is used by match.ss
-(module render-test-list mzscheme
-  
-  (provide render-test-list)
-  
-  (require "render-sigs.ss"
-           "render-test-list-impl.ss"
-           "getbindings.ss"
-           "ddk-handlers.ss"
-           mzlib/unit)
-  
-  (define-compound-unit/infer rtl@
-    (import)
-    (export render-test-list^)
-    (link render-test-list@ getbindings@ ddk-handlers@))
-  
-  (define-values/invoke-unit/infer rtl@)
-
-  )
diff --git a/collects/mzlib/private/match/reorder-tests.scm b/collects/mzlib/private/match/reorder-tests.scm
deleted file mode 100644
index cae052673e..0000000000
--- a/collects/mzlib/private/match/reorder-tests.scm
+++ /dev/null
@@ -1,102 +0,0 @@
-;; This library is used by match.ss
-;; This requires the test data structure.
-(module reorder-tests mzscheme
-  
-  (provide reorder-all-lists)
-  
-  (require "test-structure.scm")
-  
-  (require-for-template mzscheme)
-  
-  ;; There really ought to be a stable sort in the std library.
-  
-  ;;!(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.
-  (define 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.
-  (define 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.
-  (define 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.
-  (define 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.
-  (define 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)))))))
-  )
diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss
deleted file mode 100644
index 82bd11a71f..0000000000
--- a/collects/mzlib/private/match/simplify-patterns.ss
+++ /dev/null
@@ -1,190 +0,0 @@
-(module simplify-patterns mzscheme
-  
-  (require syntax/stx)
-  
-  (require scheme/list)
-  
-  (require "match-error.ss"
-           "match-helper.ss"
-           "test-structure.scm"
-           "coupling-and-binding.scm"
-           "update-counts.scm"
-           "update-binding-counts.scm"
-           "reorder-tests.scm"
-           "match-expander-struct.ss"
-           "render-helpers.ss"
-           "observe-step.ss")
-  
-  (require "render-sigs.ss")
-  
-  (require-for-syntax "match-helper.ss"
-                      "match-expander-struct.ss"
-                      "test-no-order.ss")
-  
-  (require-for-template mzscheme
-			"match-error.ss"
-			"test-no-order.ss"
-                        "match-helper.ss")
-  
-
-
-  (provide simplify match-...-nesting)
-  
-  (define match-...-nesting (make-parameter 0))
-  
-  
-  ;; simplifies patterns by removing syntactic sugar and expanding match-expanders
-  ;; simplify : syntax certifier-> syntax
-  (define (simplify stx cert)    
-
-    
-    ;; convert and check sub patterns for hash-table patterns
-    (define (convert-hash-table-pat pat)
-      (syntax-case pat ()
-        [(p1 p2) #`(#,(simplify/i #'p1) #,(simplify/i #'p2))]
-        [i (and (identifier? #'i) (not (stx-dot-dot-k? #'i))) #'(var i)]
-        [_ (match:syntax-err pat "hash table subpattern must contain either two patterns or an identifier")]))
-
-    ;; simple one-arg version, just passes the cert along
-    (define (simplify/i stx) (simplify stx cert))
-    
-    (syntax-case*
-        stx
-      (_ 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?
-
-      ;; expand match-expanders
-      ;; this doesn't work because we need to keep the certifier around
-      [(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)])
-         (unless transformer
-           (match:syntax-err #'expander
-                             "This expander only works with the match.ss library."))
-         (let* ([introducer (make-syntax-introducer)]
-                [certifier (match-expander-certifier expander)]
-                [mstx (introducer (syntax-local-introduce stx))]
-                [mresult (transformer mstx)]
-                [result (syntax-local-introduce (introducer mresult))]
-                [cert* (lambda (id) (certifier (cert id) #f introducer))])
-           (observe-step stx mstx mresult result)
-           (simplify result cert*)))]
-      
-      ;; label variable patterns
-      [id
-       (and (pattern-var? #'id) (not (stx-dot-dot-k? #'id)))
-       #'(var id)]
-      
-      ;; match the empty list
-      ['() (syntax/loc stx (list))]
-      
-      ;; other quoted data is untransformed
-      [(quote data) stx]
-      
-      ;; transform quasi-patterns into regular patterns
-      [`quasi-pat (simplify/i (parse-quasi #'quasi-pat))]
-      
-      ;; predicate patterns with binders are redundant with and patterns
-      [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))]
-      [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
-      [(? . anything)
-           (match:syntax-err
-            stx
-            (if (null? (syntax-e #'anything))
-                "a predicate pattern must have a predicate following the ?"
-                "syntax error in predicate pattern"))]
-      
-      ;; regexp patterns - FIXME: abstract here
-      [(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))]
-      [(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))]
-      [(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))]
-      [(pregexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))]
-      [(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")]
-      [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")]
-     
-      
-      ;; cons is just list-rest with 2 arguments
-      [(cons p1 p2) (simplify/i (syntax/loc stx (list-rest p1 p2)))]
-      [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")]
-      
-      ;; aggregates
-      
-      [(kw pats ... last ddk)
-       (and (stx-dot-dot-k? #'ddk)
-            (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)))
-       (with-syntax ([(pats* ...) (append (syntax-map simplify/i #'(pats ...))
-                                          (parameterize ([match-...-nesting (add1 (match-...-nesting))])
-                                            (list (simplify/i #'last))))])
-         #;(printf "kw: ~a~n" (syntax-object->datum stx))
-         (quasisyntax/loc stx (kw pats* ... ddk)))
-       #;
-       (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
-                     [last* (parameterize ([match-...-nesting (add1 (match-...-nesting))])
-                              (simplify/i #'last))])
-         (syntax/loc stx (kw pats* ... last* ddk)))]
-      [(kw pats ...)       
-       (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))
-       (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))])
-         (syntax/loc stx (kw pats* ...)))]
-      [(kw pats ... . rest)
-       (not (null? (syntax-e #'rest)))
-       (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))]
-      
-      ;; hash table patterns have their own syntax
-      [(hash-table pats ... ooo)
-       (stx-dot-dot-k? #'ooo)
-       (with-syntax 
-           ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
-         (syntax/loc stx (hash-table pats* ... ooo)))]
-      [(hash-table pats ...)
-       (with-syntax 
-           ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))])
-         (syntax/loc stx (hash-table pats* ...)))]
-      [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")]
-      
-      ;; struct patterns
-      [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]
-                                            [st* (cert #'st)])
-                                (syntax/loc stx (struct st* (pats* ...))))]
-      [(struct . rest)
-       (match:syntax-err
-	stx
-	(if (null? (syntax-e #'rest))
-	    (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"))]
-      
-      [(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))]
-      [(box . rest) (match:syntax-err stx "syntax error in box pattern")]
-      
-      [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))]
-      [(app . rest) (match:syntax-err stx "syntax error in app pattern")]
-      
-      [(set! id)
-       (identifier? #'id)
-       stx]
-      [(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")]
-
-      [(get! id)
-       (identifier? #'id)
-       stx]
-      [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")]
-      
-      [(var id) 
-       (identifier? #'id)
-       stx]
-      [(var . rest)
-       (match:syntax-err stx "var pattern must have one identifier")]
-      
-      [__ stx])
-    
-    
-    )
-  
-  
-  )
diff --git a/collects/mzlib/private/match/struct-helper.scm b/collects/mzlib/private/match/struct-helper.scm
deleted file mode 100644
index 6455147743..0000000000
--- a/collects/mzlib/private/match/struct-helper.scm
+++ /dev/null
@@ -1,235 +0,0 @@
-(module struct-helper mzscheme
-  (require mzlib/list)
-  (require-for-template mzscheme)
-  (provide (all-defined))
-  
-  (define-struct field-decl (field ref mut posn immutable? auto?) (make-inspector))
-  
-  (define (sym+ . items)
-    (define (->string x)
-      (cond [(string? x) x]
-            [(symbol? x) (symbol->string x)]
-            [(identifier? x) (symbol->string (syntax-e x))]))
-    (string->symbol (apply string-append (map ->string items))))
-  
-  (define (identifier/tf? stx)
-    (or (identifier? stx) 
-        (not stx) 
-        (eq? (syntax-e stx) #t)
-        (eq? (syntax-e stx) #f)))
-  
-  (define (id/tf stx stx2)
-    (cond [(identifier? stx)
-           stx]
-          [(eq? (syntax-e stx) #t)
-           stx2]
-          [else #f]))
-  
-  (define (mk-parse-field-decl name-id)
-    (define (parse-field-decl stx)
-      (syntax-case stx ()
-        [(field (flag ...) ref mut)
-         (and (identifier? #'field)
-              (identifier/tf? #'ref)
-              (identifier/tf? #'mut)
-              (andmap identifier? (syntax->list #'(flag ...))))
-         (let ((flags (syntax-object->datum #'(flag ...))))
-           (make-field-decl
-            (id/tf #'field #f)
-            (id/tf #'ref (datum->syntax-object name-id (sym+ name-id '- #'field)))
-            (id/tf #'mut (datum->syntax-object name-id (sym+ 'set- name-id '- #'field '!)))
-            #f
-            (memq 'immutable flags)
-            (memq 'auto flags)))]
-        [(field (flag ...) ref)
-         (parse-field-decl #'(field (flag ...) ref #t))]
-        [(field (flag ...))
-         (parse-field-decl
-          #`(field 
-             (flag ...)
-             #t
-             #t))]
-        [field
-         (identifier? #'field)
-         (parse-field-decl
-          #`(field () #t #t))]))
-    (lambda (stx)
-      (let ((r (parse-field-decl stx)))
-        #;(printf "parse-field-decl returned ~s~n" r)
-        r)))
-  
-  (define-struct decl:super (super struct:super))
-  (define-struct decl:auto (value))
-  (define-struct decl:property (key value))
-  (define-struct decl:inspector (value))
-  (define-struct decl:procedure-field (field))
-  (define-struct decl:procedure (value))
-  (define-struct decl:guard (value))
-  (define-struct decl:option (value))
-  
-  (define (fetch-struct:super type)
-    (let ((struct-info (syntax-local-value type)))
-      (car struct-info)))
-  
-  (define (parse-decl stx)
-    (syntax-case stx (super struct:super
-                            auto-value property inspector transparent
-                            procedure procedure-field guard
-                            omit-define-values
-                            omit-static-info
-                            clone
-                            replace
-                            )
-      [(super type)
-       (identifier? #'type)
-       (make-decl:super #'type (fetch-struct:super #'type))]
-      [(struct:super value)
-       (make-decl:super #f #'value)]
-      [(auto-value value)
-       (make-decl:auto #'value)]
-      [(property key value)
-       (make-decl:property #'key #'value)]
-      [(inspector value)
-       (make-decl:inspector #'value)]
-      [transparent
-       (make-decl:inspector #'(make-inspector))]
-      [(procedure proc)
-       (make-decl:procedure #'proc)]
-      [(procedure-field field)
-       (identifier? #'field)
-       (make-decl:procedure-field #'field)]
-      [(guard proc)
-       (make-decl:guard #'proc)]
-      [omit-define-values
-       (make-decl:option 'omit-define-values)]
-      [omit-static-info
-       (make-decl:option 'omit-static-info)]
-      [clone
-       (make-decl:option 'include-clone)]
-      [replace
-       (make-decl:option 'include-replace)]))
-  
-  (define-struct info (type super auto-k auto-v 
-                            props insp proc-spec imm-k-list guard
-                            ref-fields ref-posns ref-names
-                            mut-fields mut-posns mut-names
-                            options fdecls))
-  (define (make-null-info type)
-    (make-info type #f 0 #f
-               '() #f #f '() #f
-               '() '() '()
-               '() '() '()
-               '() '()))
-  (define (create-info type decls field-decls)
-    (let ((info (make-null-info type)))
-      (let loop ((fdecls field-decls) (posn 0) (first-auto #f))
-        (if (pair? fdecls)
-            (let ((fdecl (car fdecls)))
-              (set-field-decl-posn! fdecl posn)
-              (when (and first-auto (not (field-decl-auto? fdecl)))
-                (raise-syntax-error 'define-struct* 
-                                    "non-auto field came after auto field"
-                                    (field-decl-field fdecl)))
-              (when (field-decl-ref fdecl)
-                (set-info-ref-fields! info 
-                                      (cons (field-decl-field fdecl) (info-ref-fields info)))
-                (set-info-ref-posns! info 
-                                     (cons posn (info-ref-posns info)))
-                (set-info-ref-names! info 
-                                     (cons (field-decl-ref fdecl) (info-ref-names info))))
-              (when (field-decl-mut fdecl)
-                (set-info-mut-fields! info 
-                                      (cons (field-decl-field fdecl) (info-mut-fields info)))
-                (set-info-mut-posns! info 
-                                     (cons posn (info-mut-posns info)))
-                (set-info-mut-names! info 
-                                     (cons (field-decl-mut fdecl) (info-mut-names info))))
-              (loop (cdr fdecls)
-                    (add1 posn)
-                    (or first-auto (if (field-decl-auto? fdecl) posn #f))))
-            (begin (set-info-auto-k! info 
-                                     (if first-auto (- posn first-auto) 0)))))
-      (set-info-ref-fields! info (reverse (info-ref-fields info)))
-      (set-info-ref-posns! info (reverse (info-ref-posns info)))
-      (set-info-ref-names! info (reverse (info-ref-names info)))
-      (set-info-mut-fields! info (reverse (info-mut-fields info)))
-      (set-info-mut-posns! info (reverse (info-mut-posns info)))
-      (set-info-mut-names! info (reverse (info-mut-names info)))
-      (set-info-fdecls! info field-decls)
-      (for-each 
-       (lambda (decl)
-         (cond [(decl:super? decl) (set-info-super! info decl)]
-               [(decl:auto? decl) (set-info-auto-v! info (decl:auto-value decl))]
-               [(decl:property? decl)
-                (set-info-props! info (cons (cons (decl:property-key decl)
-                                                  (decl:property-value decl))
-                                            (info-props info)))]
-               [(decl:inspector? decl)
-                (set-info-insp! info (decl:inspector-value decl))]
-               [(decl:procedure? decl)
-                (set-info-proc-spec! info (decl:procedure-value decl))]
-               [(decl:procedure-field? decl)
-                (set-info-proc-spec! 
-                 info
-                 (let loop ((fields (map field-decl-field field-decls)) (i 0))
-                   (cond
-                     [(null? fields)
-                      (raise-syntax-error 'define-struct*
-                                          "procedure-field not in field set"
-                                          (decl:procedure-field-field decl))]
-                     [(module-identifier=? (decl:procedure-field-field decl)
-                                           (car fields))
-                      i]
-                     [else (loop (cdr fields) (add1 i))])))]
-               [(decl:guard? decl)
-                (set-info-guard! info (decl:guard-value decl))]
-               [(decl:option? decl)
-                (set-info-options! info (cons (decl:option-value decl)
-                                              (info-options info)))]
-               ))
-       decls)
-      (when (and (info-include-replacers? info) (pair? (info-auto-fields info)))
-        (error 'define-struct* "cannot define replacers with auto-fields"))
-      info))
-  
-  (define (info-init-fields info)
-    (filter (lambda (fdecl) (not (field-decl-auto? fdecl)))
-            (info-fdecls info)))
-  (define (info-auto-fields info)
-    (filter (lambda (fdecl) (field-decl-auto? fdecl))
-            (info-fdecls info)))
-  
-  (define (info-include-define-values? info)
-    (not (memq 'omit-define-values (info-options info))))
-  
-  (define (info-include-static-info? info)
-    (not (memq 'omit-static-info (info-options info))))
-  (define (info-include-replacers? info)
-    (memq 'include-replace (info-options info)))
-  (define (info-include-clone? info)
-    (memq 'include-clone (info-options info)))
-  
-  (define (info-include-x-ref? info)
-    #f)
-  (define (info-include-x-set!? info)
-    #f)
-  
-  
-  (define (info-name:struct-record info)
-    (let ((type (info-type info)))
-      (datum->syntax-object type (sym+ 'struct: type))))
-  (define (info-name:constructor info)
-    (let ((type (info-type info)))
-      (datum->syntax-object type (sym+ 'make- type))))
-  (define (info-name:predicate info)
-    (let ((type (info-type info)))
-      (datum->syntax-object type (sym+ type '?))))
-  (define (info-defined-names info)
-    (let ((type (info-type info)))
-      (append (list (info-name:struct-record info)
-                    (info-name:constructor info)
-                    (info-name:predicate info))
-              (info-ref-names info)
-              (info-mut-names info))))
-  
-  )
diff --git a/collects/mzlib/private/match/syntax-utils.ss b/collects/mzlib/private/match/syntax-utils.ss
deleted file mode 100644
index 651146cf61..0000000000
--- a/collects/mzlib/private/match/syntax-utils.ss
+++ /dev/null
@@ -1,45 +0,0 @@
-(module syntax-utils mzscheme
-  ;; Useful utilities on syntax objects
-  
-  (provide (all-defined))
-  
-   ;;! (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 stx) (length (syntax->list stx)))
-  
-  ;;! (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-? 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? a b)
-    (equal? (syntax-object->datum a)
-            (syntax-object->datum b)))
-  
-  ;;!(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) #`#,(gensym 'exp))
-  
-  
-  ;; syntax-map : (stx -> b)  stx-list -> listof[b]
-  ;; maps a function over a syntax object that represents a list
-  (define (syntax-map f stx-l)
-    (map f (syntax->list stx-l)))
-  
-  )
diff --git a/collects/mzlib/private/match/tag-negate-tests.scm b/collects/mzlib/private/match/tag-negate-tests.scm
deleted file mode 100644
index 910ab01f64..0000000000
--- a/collects/mzlib/private/match/tag-negate-tests.scm
+++ /dev/null
@@ -1,103 +0,0 @@
-(module tag-negate-tests mzscheme
-  (provide tag-negate-tests)
-  (require "test-structure.scm")
-  
-  (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)))))))
-  
-  
-  
-  )
diff --git a/collects/mzlib/private/match/test-no-order.ss b/collects/mzlib/private/match/test-no-order.ss
deleted file mode 100644
index 2929d9e89b..0000000000
--- a/collects/mzlib/private/match/test-no-order.ss
+++ /dev/null
@@ -1,39 +0,0 @@
-(module test-no-order mzscheme
-  (require mzlib/list)
-
-  (provide match:test-no-order)
-  
-  ;;!(function match:test-no-order 
-  ;;          (form (match:test-no-order tests l last-test ddk-num)
-  ;;                -> 
-  ;;                bool)
-  ;;          (contract (list list test integer) -> bool))
-  ;; This is a recursive depth first search for a sequence of
-  ;; items in list l which will satisfy all of the tests in list
-  ;; tests.  This is used for list-no-order and hash-table patterns.
-  ;; This function also handles ddk patterns by passing it the last
-  ;; test before the ddk and the value of k.
-  (define (match:test-no-order tests l last-test ddk-num)
-    (define (handle-last-test test l)
-      (and (>= (length l) ddk-num) 
-           (andmap test l)))
-    (define (dep-first-test head rest tests)
-      (cond [(null? tests) 
-             (if last-test 
-                 (handle-last-test last-test (cons head rest)) 
-                 #f)]
-            [(null? rest)
-             (if last-test
-                 (and (= 0 ddk-num)
-                      (= 1 (length tests))
-                      ((car tests) head))
-                 (and (= 1 (length tests))
-                      ((car tests) head)))]
-            [else (and (pair? tests)
-                       ((car tests) head)
-                       (match:test-no-order (cdr tests) 
-                                            rest 
-                                            last-test 
-                                            ddk-num))]))
-    (printf "~s\n" (list tests l last-test ddk-num))
-    (ormap (lambda (elem) (dep-first-test elem (remove elem l) tests)) l)))
diff --git a/collects/mzlib/private/match/test-structure.scm b/collects/mzlib/private/match/test-structure.scm
deleted file mode 100644
index 49c18b536a..0000000000
--- a/collects/mzlib/private/match/test-structure.scm
+++ /dev/null
@@ -1,120 +0,0 @@
-;; This library is used by match.ss
-
-(module test-structure mzscheme
-  (provide (all-defined))
-  
- 
-  
-  ;; 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
-  ;; used-set-neg - ???
-  ;; closest-shape-tst - ???
-  ;; equal-set - ???
-  (define-struct test (tst
-                       comp
-                       shape
-                       times-used
-                       used-set
-                       bind-exp-stx
-                       bind-exp
-                       bind-count
-                       used-set-neg
-                       closest-shape-tst
-                       equal-set)
-    #f)
-  
-  ;;!(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 '() #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 '() #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  '() #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/match/update-binding-counts.scm b/collects/mzlib/private/match/update-binding-counts.scm
deleted file mode 100644
index e59525759d..0000000000
--- a/collects/mzlib/private/match/update-binding-counts.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-;; This library is used by match.ss
-(module update-binding-counts mzscheme
-  (provide update-binding-counts update-binding-count)
-  
-  (require "test-structure.scm")
-  (require mzlib/etc)
-  
-  
-  ;;!(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
-  (define 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.
-  (define 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.
-  (define 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.
-  (define update-binding-counts 
-    (lambda (render-lists)
-      (map (compose update-binding-count car) render-lists)))
-  )
diff --git a/collects/mzlib/private/match/update-counts.scm b/collects/mzlib/private/match/update-counts.scm
deleted file mode 100644
index 0c7a862920..0000000000
--- a/collects/mzlib/private/match/update-counts.scm
+++ /dev/null
@@ -1,148 +0,0 @@
-;; This library is used by match.ss
-;; This requires the test data structure.
-
-(module update-counts mzscheme
-  (provide update-counts)
-  
-  (require "test-structure.scm"
-	   "match-helper.ss"
-           mzlib/etc
-           mzlib/list)
-  
-  ;;!(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.
-  
-  (define (test-filter tlist)
-    (filter (lambda (t) (not (= -1 (test-times-used t)))) 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.
-  (define (inverse-in test test-list)
-    (or (pos-inverse-in test test-list)
-        (neg-inverse-in test test-list)))
-  
-  (define (pos-inverse-in test test-list)
-    (let ([test-with-implied (cons test (implied test))])
-      (ormap (lambda (t) (in t test-with-implied))
-             test-list)))
-        
-  
-  (define (neg-inverse-in test test-list)
-    (let ([test-with-implied (cons test (implied test))])
-      (ormap (lambda (t) (in `(not ,t) test-with-implied))
-             test-list)))
-      
-  
-  (define (logical-member item lst)
-    (ormap (lambda (cur)
-             (logical-equal? item cur))
-           lst))
-  
-  (define (logical-equal? a b)
-    (or (equal? a b)
-        (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)))))
-  
-  ;; truncate-list : int listof[int] -> listof[int] 
-  ;; truncate-list-neg : int listof[int] -> listof[int] 
-  ;; truncate-list removes all elements of a list after the element at least as large as p
-  ;; truncate-list-neg removes the found element as well
-  (define-values (truncate-list truncate-list-neg)
-    (let ([mk (lambda (pos-f) 
-                (define (f p l)
-                   (cond [(null? l)
-                         '()]
-                        [(>= p (car l))
-                         (pos-f p)]
-                        [else
-                         (cons (car l)
-                               (f p (cdr l)))]))
-                f)])
-      (values (mk list) (mk (lambda (x) '())))))
-  
-  
-  
-  ;; update-count : test listof[test] int -> 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.
-  (define (update-count test tests-rest pos mem-table)
-      (let loop ([l tests-rest]
-                 [p (add1 pos)])
-        (if (null? l)
-            (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 (logical-member (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-list 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-list-neg pos (cadr entry-pair)))))))))
-              
-  
-  ;; update-counts : listof[(cons test any)] -> void
-  ;; This function essentially calls update-count on every test in
-  ;; all of the test lists.
-  (define (update-counts render-list)
-      (let* ([mem-table (make-hash-table 'equal)]
-             [test-master-list (map (compose test-filter car) render-list)]
-             [test-so-far-lists ;; horrible name
-              (map
-               (lambda (tl) (map test-tst (test-filter tl)))
-               test-master-list)])
-        (let loop ([tml test-master-list]
-                   [tsf test-so-far-lists]
-                   [pos 1])
-          (if (null? tml)
-              (void)
-              (begin
-                (for-each 
-                 (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)))))))
-  )
-
-
-
diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss
index d07523f194..14579c0edc 100644
--- a/collects/scheme/match/compiler.ss
+++ b/collects/scheme/match/compiler.ss
@@ -41,34 +41,29 @@
                          rows)
                     esc)])
       #`[(#,predicate-stx #,x) rhs]))
+  (define (compile-con-pat accs pred pat-acc)
+    (with-syntax ([(tmps ...) (generate-temporaries accs)])
+      (with-syntax ([(accs ...) accs]
+                    [pred pred]
+                    [body (compile*
+                           (append (syntax->list #'(tmps ...)) xs)
+                           (map (lambda (row)
+                                  (define-values (p1 ps) (Row-split-pats row))
+                                  (make-Row (append (pat-acc p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
+                                rows)
+                           esc)])
+        #`[(pred #,x)
+           (let ([tmps (accs #,x)] ...)
+             body)])))
   (cond
     [(eq? 'box k) 
-     (with-syntax ([(v) (generate-temporaries #'(v))])
-       (with-syntax
-           ([body (compile* 
-                   (cons #'v xs)
-                   (map (lambda (r)
-                          (define-values (p1 ps) (Row-split-pats r))
-                          (make-Row (cons (Box-p p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
-                        rows)
-                   esc)])
-         #`[(box? #,x)
-            (let ([v (unbox #,x)])
-              body)]))]
+     (compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
     [(eq? 'pair k)
-     (with-syntax ([(v1 v2) (generate-temporaries #'(v1 v2))])
-       (with-syntax
-           ([body (compile*
-                   (list* #'v1 #'v2 xs)
-                   (map (lambda (r)
-                          (define-values (p1 ps) (Row-split-pats r))
-                          (make-Row (list* (Pair-a p1) (Pair-d p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
-                        rows)
-                   esc)])
-         #`[(pair? #,x)
-            (let ([v1 (car #,x)]
-                  [v2 (cdr #,x)])
-              body)]))]
+     (compile-con-pat (list #'car #'cdr) #'pair? 
+                      (lambda (p) (list (Pair-a p) (Pair-d p))))]
+    [(eq? 'mpair k)
+     (compile-con-pat (list #'mcar #'mcdr) #'mpair? 
+                      (lambda (p) (list (MPair-a p) (MPair-d p))))]
     [(eq? 'string k)  (constant-pat #'string?)]
     [(eq? 'number k)  (constant-pat #'number?)]
     [(eq? 'symbol k)  (constant-pat #'symbol?)]
@@ -78,6 +73,8 @@
     [(eq? 'regexp k)  (constant-pat #'regexp?)]
     [(eq? 'boolean k) (constant-pat #'boolean?)]
     [(eq? 'null k)    (constant-pat #'null?)]
+    ;; vectors are handled specially
+    ;; because each arity is like a different constructor
     [(eq? 'vector k)
      (let ()
        (define ht (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
@@ -110,21 +107,10 @@
      (let* ([s (Row-first-pat (car rows))]
             [accs (Struct-accessors s)]
             [pred (Struct-pred s)])
-       (with-syntax ([(tmps ...) (generate-temporaries accs)])
-         (with-syntax ([(accs ...) accs]
-                       [pred pred]
-                       [body (compile*
-                              (append (syntax->list #'(tmps ...)) xs)
-                              (map (lambda (row)
-                                     (define-values (p1 ps) (Row-split-pats row))
-                                     (make-Row (append (Struct-ps p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
-                                   rows)
-                              esc)])
-           #`[(pred #,x)
-              (let ([tmps (accs #,x)] ...)
-                body)])))]
+       (compile-con-pat accs pred Struct-ps))]
     [else (error 'compile "bad key: ~a" k)]))
 
+
 ;; produces the syntax for a let clause
 (define (compile-one vars block esc)
   (define-values (first rest-pats) (Row-split-pats (car block)))
diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss
index c23bd62836..b7ecd75e9e 100644
--- a/collects/scheme/match/parse-helper.ss
+++ b/collects/scheme/match/parse-helper.ss
@@ -8,7 +8,95 @@
          "compiler.ss"
          (only-in srfi/1 delete-duplicates))
 
-(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable?)
+(provide ddk? parse-literal all-vars pattern-var? match:syntax-err 
+         match-expander-transform matchable? trans-match parse-struct
+         dd-parse parse-quote parse-id)
+
+;; parse x as a match variable
+;; x : identifier
+(define (parse-id x)  
+  (cond [(eq? '_ (syntax-e x))
+         (make-Dummy x)]
+        [(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" #'x)]
+        [else (make-Var x)]))
+
+;; stx : syntax of pattern, starting with quote
+;; parse : the parse function
+(define (parse-quote stx parse)
+  (syntax-case stx (quote)
+    [(quote ())
+     (make-Null (make-Dummy stx))]
+    [(quote (a . b))
+     (make-Pair (parse (syntax/loc stx (quote a)))
+                (parse (syntax/loc stx (quote b))))]
+    [(quote vec)
+     (vector? (syntax-e #'vec))
+     (make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
+                            (parse (quasisyntax/loc stx (quote #,e)))))]
+    [(quote bx)
+     (vector? (syntax-e #'bx))
+     (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
+    [(quote v)
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [_
+     (raise-syntax-error 'match "syntax error in quote pattern" stx)]))
+
+;; parse : the parse fn
+;; p : the repeated pattern
+;; dd : the ... stx
+;; rest : the syntax for the rest
+(define (dd-parse parse p dd rest)
+  (let* ([count (ddk? dd)]
+         [min (if (number? count) count #f)])
+    (make-GSeq 
+     (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+       (list (list (parse p))))
+     (list min)
+     ;; no upper bound
+     (list #f)
+     ;; patterns in p get bound to lists
+     (list #f)
+     (parse rest))))
+
+;; stx : the syntax object for the whole pattern
+;; cert : the certifier
+;; parse : the pattern parser
+;; struct-name : identifier
+;; pats : syntax representing the member patterns
+;; returns a pattern
+(define (parse-struct stx cert parse struct-name pats)
+  (let* ([fail (lambda () 
+                 (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum struct-name)) stx struct-name))]
+         [v (syntax-local-value (cert struct-name) fail)])
+    (unless (struct-info? v)
+      (fail))
+    (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
+      ;; 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 
+                      (extract-struct-info (syntax-local-value struct-name))
+                      5)])
+          (cond [(equal? super #t) '()] ;; no super type exists
+                [(equal? super #f) '()] ;; super type is unknown
+                [else (cons super (get-lineage super))])))
+      (let* (;; the accessors come in reverse order
+             [acc (reverse acc)]
+             ;; remove the first element, if it's #f
+             [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
+        (make-Struct id pred (get-lineage (cert struct-name)) acc 
+                     (if (eq? '_ (syntax-e pats))
+                         (map make-Dummy acc)
+                         (let* ([ps (syntax->list pats)])
+                           (unless (= (length ps) (length acc))
+                             (raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
+                                                                (syntax->datum struct-name) (length acc) (length ps))
+                                                 stx pats))
+                           (map parse ps))))))))
+
+(define (trans-match pred transformer pat)
+  (make-And (list (make-Pred pred) (make-App transformer pat))))
 
 ;; transform a match-expander application
 ;; parse/cert : stx certifier -> pattern
@@ -30,6 +118,7 @@
            [cert* (lambda (id) (certifier (cert id) #f introducer))])
       (parse/cert result cert*))))
 
+;; can we pass this value to regexp-match?
 (define (matchable? e)
   (or (string? e) (bytes? e)))
 
diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss
index bfff1639cb..a845db4e92 100644
--- a/collects/scheme/match/parse-legacy.ss
+++ b/collects/scheme/match/parse-legacy.ss
@@ -19,8 +19,6 @@
     
     [(expander args ...)
      (and (identifier? #'expander)
-          ;; for debugging
-          (syntax-transforming?)
           (match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
      (match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform 
                                "This expander only works with the standard match syntax")]
@@ -44,34 +42,7 @@
      (make-Vector (map parse (syntax->list #'(es ...))))]    
       
     [($ s . pats)
-     (let* ([fail (lambda () 
-                    (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
-            [v (syntax-local-value (cert #'s) fail)])
-       (unless (struct-info? v)
-         (fail))
-       (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
-         ;; 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 
-                         (extract-struct-info (syntax-local-value struct-name))
-                         5)])
-             (cond [(equal? super #t) '()] ;; no super type exists
-                   [(equal? super #f) '()] ;; super type is unknown
-                   [else (cons super (get-lineage super))])))
-         (let* (;; the accessors come in reverse order
-                [acc (reverse acc)]
-                ;; remove the first element, if it's #f
-                [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
-           (make-Struct id pred (get-lineage (cert #'s)) acc 
-                        (if (eq? '_ (syntax-e #'pats))
-                            (map make-Dummy acc)
-                            (let* ([ps (syntax->list #'pats)])
-                              (unless (= (length ps) (length acc))
-                                (raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
-                                                                   (syntax->datum #'s) (length acc) (length ps))
-                                                    stx #'pats))
-                              (map parse ps)))))))]
+     (parse-struct stx cert parse #'s #'pats)]
     [(? p q1 qs ...)
      (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
     [(? p)
@@ -80,47 +51,20 @@
      (make-App #'f (parse (cert #'p)))]
     [(quasiquote p)
      (parse-quasi #'p cert parse/legacy/cert)]
-    [(quote ())
-     (make-Null (make-Dummy stx))]
-    [(quote (a . b))
-     (make-Pair (parse (syntax/loc stx (quote a)))
-                (parse (syntax/loc stx (quote b))))]
-    [(quote vec)
-     (vector? (syntax-e #'vec))
-     (make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
-                            (parse (quasisyntax/loc stx (quote #,e)))))]
-    [(quote bx)
-     (vector? (syntax-e #'bx))
-     (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
-    [(quote v)
-     (or (parse-literal (syntax-e #'v))
-         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [(quote . rest)
+     (parse-quote stx parse)]
     [() (make-Null (make-Dummy #f))]
     [(..)
      (ddk? #'..)
      (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
     [(p .. . rest)
      (ddk? #'..)
-     (let* ([count (ddk? #'..)]
-            [min (if (number? count) count #f)]
-            [max (if (number? count) count #f)])
-       (make-GSeq 
-        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
-          (list (list (parse #'p))))
-        (list min)
-        ;; no upper bound
-        (list #f)
-        ;; patterns in p get bound to lists
-        (list #f)
-        (parse (syntax/loc stx rest))))]
+     (dd-parse parse #'p #'.. #'rest)]
     [(e . es)
      (make-Pair (parse #'e) (parse (syntax/loc stx es)))]  
     [x
      (identifier? #'x)
-     (cond [(eq? '_ (syntax-e #'x))
-            (make-Dummy #'x)]
-           [(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
-           [else (make-Var #'x)])]
+     (parse-id #'x)]
     [v
      (or (parse-literal (syntax-e #'v))
          (raise-syntax-error 'match "syntax error in pattern" stx))]))
diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss
index fddf182cd0..5234bf8430 100644
--- a/collects/scheme/match/parse.ss
+++ b/collects/scheme/match/parse.ss
@@ -13,12 +13,19 @@
 
 (provide parse/cert)
 
+(define (ht-pat-transform p) 
+  (syntax-case p ()
+    [(a b) #'(list a b)]
+    [x
+     (identifier? #'x)
+     #'x]))
+
 ;; parse : syntax -> Pat
 ;; compile stx into a pattern, using the new syntax
 (define (parse/cert stx cert)
   (define (parse stx) (parse/cert stx cert))
   (syntax-case* stx (not var struct box cons list vector ? and or quote app regexp pregexp
-                         list-rest list-no-order hash-table quasiquote)
+                         list-rest list-no-order hash-table quasiquote mcons list*)
     (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     
     [(expander args ...)
@@ -40,62 +47,36 @@
      (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
        (make-And ps))]
     [(regexp r)
-     (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
+     (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (make-Pred #'values))]
     [(regexp r p)
-     (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
+     (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
     [(pregexp r)
-     (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r 
-                                                       (lambda (e) (regexp-match (if (pregexp? r)
-                                                                                     r
-                                                                                     (pregexp r))
-                                                                                 e)))
-                                                     (make-Pred #'values))))]
+     (trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (make-Pred #'values))]
     [(pregexp r p)
-     (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r 
-                                                       (lambda (e) (regexp-match (if (pregexp? r)
-                                                                                     r
-                                                                                     (pregexp r))
-                                                                                 e)))
-                                                     (parse #'p))))]
+     (trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (parse #'p))]
     [(box e) (make-Box (parse #'e))]    
     [(vector es ...)
      (ormap ddk? (syntax->list #'(es ...)))
-     (make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (list es ...))))))]
+     (trans-match #'vector? #'vector->list (parse (syntax/loc stx (list es ...))))]
     [(vector es ...)
      (make-Vector (map parse (syntax->list #'(es ...))))]
     [(hash-table p ... dd)
      (ddk? #'dd)
-     (make-And 
-      (list 
-       (make-Pred #'hash-table?) 
-       (make-App 
-        #'(lambda (e) (hash-table-map e list))
-        (with-syntax ([(elems ...) (map (lambda (p)
-                                          (syntax-case p ()
-                                            [(a b) #'(list a b)]
-                                            [x
-                                             (identifier? #'x)
-                                             #'x]))
-                                        (syntax->list #'(p ...)))])
-          (parse (syntax/loc stx (list-no-order elems ... dd)))))))]
+     (trans-match
+      #'hash-table?
+      #'(lambda (e) (hash-table-map e list))
+      (with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
+        (parse (syntax/loc stx (list-no-order elems ... dd)))))]
     [(hash-table p ...)
     (ormap ddk? (syntax->list #'(p ...)))
     (raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx 
                         (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
     [(hash-table p ...)
-    (make-And 
-      (list 
-       (make-Pred #'hash-table?) 
-       (make-App 
-        #'(lambda (e) (hash-table-map e list))
-        (with-syntax ([(elems ...) (map (lambda (p)
-                                          (syntax-case p ()
-                                            [(a b) #'(list a b)]
-                                            [x
-                                             (identifier? #'x)
-                                             #'x]))
-                                        (syntax->list #'(p ...)))])
-          (parse (syntax/loc stx (list-no-order elems ...)))))))]
+     (trans-match
+      #'hash-table?
+      #'(lambda (e) (hash-table-map e list))
+      (with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
+        (parse (syntax/loc stx (list-no-order elems ...)))))]
     [(hash-table . _)
      (raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
     [(list-no-order p ... lp dd)
@@ -133,67 +114,22 @@
      (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
     [(list p .. . rest)
      (ddk? #'..)
-     (let* ([count (ddk? #'..)]
-            [min (if (number? count) count #f)]
-            [max (if (number? count) count #f)])
-       (make-GSeq 
-        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
-          (list (list (parse #'p))))
-        (list min)
-        ;; no upper bound
-        (list #f)
-        ;; patterns in p get bound to lists
-        (list #f)
-        (parse (syntax/loc stx (list . rest)))))]
+     (dd-parse parse #'p #'.. (syntax/loc stx (list . rest)))]
     [(list e es ...)
      (make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
+    [(list* . rest)
+     (parse (syntax/loc stx (list-rest . rest)))]
     [(list-rest e)
      (parse #'e)]
     [(list-rest p dd . rest)
      (ddk? #'dd)
-     (let* ([count (ddk? #'dd)]
-            [min (if (number? count) count #f)])
-       (make-GSeq 
-        (parameterize ([match-...-nesting (add1 (match-...-nesting))])
-          (list (list (parse #'p))))
-        (list min)
-        ;; no upper bound
-        (list #f)
-        ;; patterns in p get bound to lists
-        (list #f)
-        (parse (syntax/loc stx (list-rest . rest)))))]
+     (dd-parse parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
     [(list-rest e . es)
      (make-Pair (parse #'e) (parse (syntax/loc #'es (list-rest . es))))]
     [(cons e1 e2) (make-Pair (parse #'e1) (parse #'e2))]
+    [(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
     [(struct s pats)
-     (let* ([fail (lambda () 
-                    (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
-            [v (syntax-local-value (cert #'s) fail)])
-       (unless (struct-info? v)
-         (fail))
-       (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
-         ;; 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 
-                         (extract-struct-info (syntax-local-value struct-name))
-                         5)])
-             (cond [(equal? super #t) '()] ;; no super type exists
-                   [(equal? super #f) '()] ;; super type is unknown
-                   [else (cons super (get-lineage super))])))
-         (let* (;; the accessors come in reverse order
-                [acc (reverse acc)]
-                ;; remove the first element, if it's #f
-                [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
-           (make-Struct id pred (get-lineage (cert #'s)) acc 
-                        (if (eq? '_ (syntax-e #'pats))
-                            (map make-Dummy acc)
-                            (let* ([ps (syntax->list #'pats)])
-                              (unless (= (length ps) (length acc))
-                                (raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
-                                                                   (syntax->datum #'s) (length acc) (length ps))
-                                                    stx #'pats))
-                              (map parse ps)))))))]
+     (parse-struct stx cert parse #'s #'pats)]
     [(? p q1 qs ...)
      (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
     [(? p)
@@ -202,27 +138,13 @@
      (make-App #'f (parse (cert #'p)))]
     [(quasiquote p)
      (parse-quasi #'p cert parse/cert)]
-    [(quote ())
-     (make-Null (make-Dummy stx))]
-    [(quote (a . b))
-     (make-Pair (parse (syntax/loc stx (quote a)))
-                (parse (syntax/loc stx (quote b))))]
-    [(quote vec)
-     (vector? (syntax-e #'vec))
-     (make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
-                            (parse (quasisyntax/loc stx (quote #,e)))))]
-    [(quote bx)
-     (vector? (syntax-e #'bx))
-     (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
-    [(quote v)
-     (or (parse-literal (syntax-e #'v))
-         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [(quasiquote . _)
+     (raise-syntax-error 'match "illegal use of quasiquote")]
+    [(quote . _)
+     (parse-quote stx parse)]
     [x
      (identifier? #'x)
-     (cond [(eq? '_ (syntax-e #'x))
-            (make-Dummy #'x)]
-           [(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
-           [else (make-Var #'x)])]
+     (parse-id #'x)]
     [v
      (or (parse-literal (syntax-e #'v))
          (raise-syntax-error 'match "syntax error in pattern" stx))]))
diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss
index 904d5f5bff..90adc11cc9 100644
--- a/collects/scheme/match/patterns.ss
+++ b/collects/scheme/match/patterns.ss
@@ -43,6 +43,7 @@
 (define-struct (VectorSeq Pat) (p count start) #:transparent)
 
 (define-struct (Pair CPat) (a d) #:transparent)
+(define-struct (MPair CPat) (a d) #:transparent)
 
 (define-struct (Box CPat) (p) #:transparent)
 
@@ -121,6 +122,7 @@
     [(Box? p) 'box]
     [(Vector? p) 'vector]
     [(Pair? p) 'pair]
+    [(MPair? p) 'mpair]
     [(String? p) 'string]
     [(Symbol? p) 'symbol]
     [(Number? p) 'number]
@@ -171,6 +173,8 @@
     [(Atom? p) null]
     [(Pair? p)
      (merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
+    [(MPair? p)
+     (merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))]
     [(GSeq? p)
      (merge (cons
              (bound-vars (GSeq-tail p))
diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 5891dd3eab..8c73784b78 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -7,7 +7,7 @@
                        string-constants/string-constant
                        #;'#%more-scheme
                        #;'#%qq-and-or
-                       (lib "match-error.ss" "mzlib" "private" "match"))
+                       (only-in scheme/match/patterns match:error))
          )
 
 
@@ -20,7 +20,7 @@
  (only-in "type-effect-convenience.ss" [make-arr* make-arr])
  "union.ss"
  string-constants/string-constant
- (lib "match-error.ss" "mzlib" "private" "match")
+ (only-in scheme/match/patterns match:error)
  "tc-structs.ss")
 
 (require (for-syntax
@@ -32,7 +32,7 @@
           (only-in "type-effect-convenience.ss" [make-arr* make-arr])
           "union.ss"
           string-constants/string-constant
-          (lib "match-error.ss" "mzlib" "private" "match")
+          (only-in scheme/match/patterns match:error)
           "tc-structs.ss"))
 
 (define-for-syntax (initialize-others)