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