From b7127dc9c77f55bb6f787fbb58d4ebaa940f525f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 Mar 2008 23:54:58 +0000 Subject: [PATCH] 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