Added for and match

whalesong/lang/match.rkt

@@ -0,0 +1,27 @@
+#lang whalesong
+(require "private/match/match.rkt" "private/match/runtime.rkt"
+         (for-syntax racket/base))
+
+(provide (except-out (all-from-out "private/match/match.rkt")
+                     define-match-expander)
+         failure-cont
+         (rename-out [define-match-expander* define-match-expander]))
+
+
+(define-for-syntax (no-old-match-form stx)
+  (raise-syntax-error
+   #f
+   "works only for constructor-based `match' form"
+   stx))
+
+(define-syntax-rule (failure-cont) (fail))
+
+
+(define-syntax define-match-expander*
+  (syntax-rules ()
+    [(_ id expr) (define-match-expander id expr)]
+    [(_ id expr expr2) (define-match-expander id
+                         expr
+                         no-old-match-form
+                         (#%expression expr2))]))
+

whalesong/lang/private/match/compiler.rkt

@@ -0,0 +1,481 @@
+#lang racket/base
+
+(require (for-template whalesong/lang/whalesong
+                       ; racket/base 
+                       "runtime.rkt"
+                       racket/stxparam
+                       ; racket/unsafe/ops
+                       )
+         syntax/boundmap
+         syntax/stx
+         "patterns.rkt"
+         "split-rows.rkt"
+         "reorder.rkt"
+         racket/stxparam
+         racket/syntax)
+
+(provide compile*)
+
+;; for non-linear patterns
+(define vars-seen (make-parameter null))
+
+(define (hash-on f elems #:equal? [eql #t])
+  (define ht (if eql (make-hash) (make-hasheq)))
+  ;; put all the elements e in the ht, indexed by (f e)
+  (for ([r
+         ;; they need to be in the original order when they come out
+         (reverse elems)])
+    (define k (f r))
+    (hash-set! ht k (cons r (hash-ref ht k (lambda () null)))))
+  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]))
+  (define (compile-con-pat accs pred pat-acc)
+    (with-syntax* ([(tmps ...) (generate-temporaries accs)]
+                   [(accs ...) accs]
+                   [pred pred]
+                   [body (compile*
+                          (append (syntax->list #'(tmps ...)) xs)
+                          (map (lambda (row)
+                                 (define-values (p1 ps) (Row-split-pats row))
+                                 (make-Row (append (pat-acc p1) ps)
+                                           (Row-rhs row)
+                                           (Row-unmatch row)
+                                           (Row-vars-seen row)))
+                               rows)
+                          esc)])
+      #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
+  (cond
+    [(eq? 'box k)
+     (compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
+    [(eq? 'pair k)
+     (compile-con-pat (list #'car #'cdr) #'pair?
+                      (lambda (p) (list (Pair-a p) (Pair-d p))))]
+    [(eq? 'mpair k)
+     ; XXX These should be unsafe-mcar* when mpairs have chaperones
+     (compile-con-pat (list #'mcar #'mcdr) #'mpair?
+                      (lambda (p) (list (MPair-a p) (MPair-d p))))]
+    [(eq? 'string k)  (constant-pat #'string?)]
+    [(eq? 'number k)  (constant-pat #'number?)]
+    [(eq? 'symbol k)  (constant-pat #'symbol?)]
+    [(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?)]
+    ;; vectors are handled specially
+    ;; because each arity is like a different constructor
+    [(eq? 'vector k)
+     (let ([ht (hash-on (lambda (r) 
+                          (length (Vector-ps (Row-first-pat r)))) rows)])
+       (with-syntax ([(clauses ...)
+                      (hash-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) ; [Whalesong] unsafe-
+              clauses ...
+              [else (#,esc)])]))]
+    ;; 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)]
+            [accs (if (Struct-complete? s)
+                      (build-list (length accs) 
+                                  (λ (i) (with-syntax ([a (list-ref accs i)])
+                                           #`(λ (x) (a x))))) ; [Whalesong]
+                      accs)]
+            [pred (Struct-pred s)])
+       (compile-con-pat accs pred Struct-ps))]
+    [else (error 'match-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-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
+                [(for/or ([e seen])
+                   (let ([v* (car e)] [id (cdr e)])
+                     (and (bound-identifier=? v v*) id)))                 
+                 =>
+                 (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 (let ([v* (free-identifier-mapping-get
+                                 (current-renaming) v (lambda () v))])
+                        (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, indexed by their constructor
+         ([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
+       (with-syntax ([(clauses ...)
+                      (hash-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)]
+            [seen (Row-vars-seen 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 
+             (for/list ([bv (bound-vars (car qs))]
+                        #:when (for/and ([seen-var seen])
+                                 (not (free-identifier=? bv (car seen-var)))))
+               bv)])
+       (with-syntax ([(esc* success? var ...) (append (generate-temporaries '(esc* success?)) vars)])
+         ;; do the or matching, and bind the results to the appropriate
+         ;; variables
+         #`(let ([esc* (lambda () (values #f #,@(for/list ([v vars]) #'#f)))])
+             (let-values ([(success? var ...)
+                           #,(compile* (list x)
+                                       (map (lambda (q)
+                                              (make-Row (list q)
+                                                        #'(values #t var ...)
+                                                        #f
+                                                        seen))
+                                            qs)
+                                       #'esc*)])
+               ;; then compile the rest of the row
+               (if success?
+                   #,(compile* xs
+                               (list (make-Row (cdr pats)
+                                               (Row-rhs row)
+                                               (Row-unmatch row)
+                                               (append (map cons vars vars) seen)))
+                               esc)
+                   (#,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)]
+            [app-pats (App-ps first)])
+       (with-syntax ([(t ...) (generate-temporaries app-pats)])
+         #`(let-values ([(t ...) (#,(App-expr first) #,x)])
+             #,(compile* (append (syntax->list #'(t ...)) xs)
+                         (list (make-Row (append app-pats (cdr pats))
+                                         (Row-rhs row)
+                                         (Row-unmatch row)
+                                         (Row-vars-seen row)))
+                         esc))))]
+    ;; the And rule
+    [(And? first)
+     ;; we only handle 1-row Ands 
+     ;; this is all the mixture rule should give us
+     (unless (null? (cdr block))
+       (error 'compile-one "And block with multiple rows: ~a" block))
+     (define row (car block))
+     (define pats (Row-pats row))
+     ;; all the patterns
+     (define 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
+               ;; don't re-order OrderedAnd patterns
+               (not (OrderedAnd? first)))]
+    ;; 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)]
+            [mutable? (GSeq-mutable? first)]
+            [make-Pair (if mutable? make-MPair make-Pair)]
+            [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)]
+            [head-idss* (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* ...) ...) 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))])])
+           (parameterize ([current-renaming
+                           (for/fold ([ht (copy-mapping (current-renaming))])
+                             ([id (apply append head-idss)]
+                              [id* (apply append head-idss*)])
+                             (free-identifier-mapping-put! ht id id*)
+                             (free-identifier-mapping-for-each
+                              ht
+                              (lambda (k v)
+                                (when (free-identifier=? v id)
+                                  (free-identifier-mapping-put! ht k id*))))
+                             ht)])
+             #`(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))
+                                               (Row-vars-seen
+                                                (car block))))
+                                   (map list heads)
+                                   (syntax->list #'(rhs ...)))
+                              (list (make-Row (list tail)
+                                              #`tail-rhs
+                                              (Row-unmatch (car block))
+                                              (Row-vars-seen
+                                               (car block)))))
+                             #'failkv))))))]
+    [else (error 'compile "unsupported pattern: ~a\n" first)]))
+
+(define (compile* vars rows esc [reorder? #t])
+  (define (let/wrap clauses body)
+    (if (stx-null? clauses)
+        body
+        (quasisyntax (let* #,clauses #,body))))
+  (cond 
+    ;; if there are no rows, then just call the esc continuation
+    [(null? rows) #`(#,esc)]
+    ;; if we have no variables, there are no more patterns to match
+    ;; so we just pick the first RHS
+    [(null? vars)
+     (let ([fns
+            (let loop ([blocks (reverse rows)] [esc esc] [acc null])
+              (if (null? blocks)
+                  ;; if we're done, return the blocks
+                  (reverse acc)
+                  (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)))])
+                            (define unmatch (Row-unmatch (car blocks)))
+                            (if unmatch
+                                (quasisyntax/loc unmatch
+                                  (call-with-continuation-prompt
+                                   (lambda () (let ([#,unmatch
+                                                     (lambda ()
+                                                       (abort-current-continuation match-prompt-tag))])
+                                                rhs))
+                                   match-prompt-tag
+                                   (lambda () (#,esc))))
+                                #'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
+    [else
+     (let*-values
+         ([(rows vars) (if reorder?
+                           (reorder-columns rows vars)
+                           (values rows vars))]
+          [(fns)
+           (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
+             (if (null? blocks)
+                 ;; if we're done, return the blocks
+                 (reverse acc)
+                 (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 #,(syntax-property
+                                       #'(lambda () c)
+                                       'typechecker:called-in-tail-position #t)]
+                               acc)))))])
+       (with-syntax ([(fns ... [_ (lambda () body)]) fns])
+         (let/wrap #'(fns ...) #'body)))]))
+
+;; (require mzlib/trace)
+;; (trace compile* compile-one)

whalesong/lang/private/match/define-forms.rkt

@@ -0,0 +1,183 @@
+#lang whalesong
+
+(require (for-syntax racket/base
+                     racket/syntax
+                     (only-in racket/list append* remove-duplicates)
+                     unstable/sequence
+                     syntax/parse
+                     syntax/parse/experimental/template
+                     racket/lazy-require))
+
+(require (for-syntax "patterns.rkt" "gen-match.rkt")) ; [Whalesong]
+#;(begin-for-syntax
+ (lazy-require ["patterns.rkt" (bound-vars)]
+               ["gen-match.rkt" (go parse-id go/one)]))
+
+(provide define-forms)
+
+;; syntax classes for `define/match`
+(begin-for-syntax
+  (define-syntax-class function-header
+    (pattern ((~or header:function-header name:id) . args:args)
+             #:attr params
+             (template ((?@ . (?? header.params ()))
+                        . args.params))))
+
+  (define-syntax-class args
+    (pattern (arg:arg ...)
+             #:attr params #'(arg.name ...))
+    (pattern (arg:arg ... . rest:id)
+             #:attr params #'(arg.name ... rest)))
+
+  (define-splicing-syntax-class arg
+    #:attributes (name)
+    (pattern name:id)
+    (pattern [name:id default])
+    (pattern (~seq kw:keyword name:id))
+    (pattern (~seq kw:keyword [name:id default]))))
+
+(define-syntax-rule (define-forms parse-id
+                      match match* match-lambda match-lambda*
+		      match-lambda** match-let match-let*
+                      match-let-values match-let*-values
+		      match-define match-define-values match-letrec
+		      match/values match/derived match*/derived
+                      define/match)
+  (...
+   (begin
+     (provide match match* match-lambda match-lambda* match-lambda**
+	      match-let match-let* match-let-values match-let*-values
+              match-define match-define-values match-letrec
+	      match/values match/derived match*/derived match-define-values
+              define/match)
+     (define-syntax (match* stx)
+       (syntax-parse stx
+         [(_ es . clauses)
+          (go parse-id stx #'es #'clauses)]))
+
+     (define-syntax (match*/derived stx)
+       (syntax-parse stx
+         [(_ es orig-stx . clauses)
+          (go parse-id #'orig-stx #'es #'clauses)]))
+
+     (define-syntax (match stx)
+       (syntax-parse stx
+         [(_ arg:expr clauses ...)
+          (go/one parse-id stx #'arg #'(clauses ...))]))
+
+     (define-syntax (match/derived stx)
+       (syntax-parse stx
+         [(_ arg:expr orig-stx clauses ...)
+          (go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
+
+     (define-syntax (match/values stx)
+       (syntax-parse stx
+         [(_ arg:expr (~and cl0 [(pats ...) rhs ...]) clauses ...)
+          (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
+            #`(let-values ([(ids ...) arg])
+                (match*/derived (ids ...) #,stx cl0 clauses ...)))]))
+
+     (define-syntax (match-lambda stx)
+       (syntax-parse stx
+         [(_ . clauses)
+          (with-syntax* ([arg (generate-temporary)]
+                         [body #`(match/derived arg #,stx . clauses)])
+            (syntax/loc stx (lambda (arg) body)))]))
+
+     (define-syntax (match-lambda* stx)
+       (syntax-parse stx
+         [(_ . clauses)
+          (with-syntax* ([arg (generate-temporary)]
+                         [body #`(match/derived arg #,stx . clauses)])
+            (syntax/loc stx (lambda arg body)))]))
+
+     (define-syntax (match-lambda** stx)
+       (syntax-parse stx
+         [(_ (~and clauses [(pats ...) . rhs]) ...)
+          (with-syntax* ([vars (generate-temporaries (car (syntax-e #'((pats ...) ...))))]
+                         [body #`(match*/derived vars #,stx clauses ...)])
+            (syntax/loc stx (lambda vars body)))]))
+
+
+     (define-syntax (match-let-values stx)
+       (syntax-parse stx
+         [(_ (~and clauses ([(patss ...) rhss:expr] ...)) body1 body ...)
+          (define-values (idss let-clauses)
+            (for/lists (idss let-clauses)
+                ([pats (syntax->list #'((patss ...) ...))]
+                 [rhs (syntax->list #'(rhss ...))])
+              (define ids (generate-temporaries pats))
+              (values ids #`[#,ids #,rhs])))
+          #`(let-values #,let-clauses
+              (match*/derived #,(append* idss) #,stx
+                [(patss ... ...) (let () body1 body ...)]))]))
+
+     (define-syntax (match-let*-values stx)
+       (syntax-parse stx
+         [(_ () body1 body ...)
+          #'(let () body1 body ...)]
+         [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
+          (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
+            #`(let-values ([(ids ...) rhs])
+                (match*/derived (ids ...) #,stx
+                  [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...)
+                                                  body1 body ...))])))]))
+
+     ;; 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-parse stx
+         [(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
+          (with-syntax*
+           ([vars (generate-temporaries #'(pat ...))]
+            [loop-body #`(match*/derived vars #,stx
+                           [(pat ...) (let () body1 body ...)])])
+           #'(letrec ([nm (lambda vars loop-body)])
+               (nm init-exp ...)))]
+         [(_ ([pat init-exp:expr] ...) body1 body ...)
+          #`(match-let-values ([(pat) init-exp] ...) body1 body ...)]))
+
+     (define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
+       (match-let*-values ([(pat) exp] ...) body1 body ...))
+
+     (define-syntax (match-letrec stx)
+       (syntax-parse stx
+         [(_ ((~and cl [pat exp]) ...) body1 body ...)
+          (quasisyntax/loc stx
+			   (let ()
+                            #,@(for/list ([c (in-syntax #'(cl ...))]
+                                          [p (in-syntax #'(pat ...))]
+                                          [e (in-syntax #'(exp ...))])
+                                 (quasisyntax/loc c (match-define #,p #,e)))
+                            body1 body ...))]))
+
+     (define-syntax (match-define stx)
+       (syntax-parse stx
+         [(_ pat rhs:expr)
+          (let ([p (parse-id #'pat)])
+            (with-syntax ([vars (bound-vars p)])
+              (quasisyntax/loc stx
+                (define-values vars (match*/derived (rhs) #,stx
+				      [(pat) (values . vars)])))))]))
+
+     (define-syntax (match-define-values stx)
+       (syntax-parse stx
+         [(_ (pats ...) rhs:expr)
+          (define bound-vars-list (remove-duplicates
+                                   (foldr (λ (pat vars)
+                                             (append (bound-vars (parse-id pat)) vars))
+                                          '() (syntax->list #'(pats ...)))
+                                   bound-identifier=?))
+          (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
+            (quasisyntax/loc stx
+              (define-values #,bound-vars-list
+                (match/values rhs
+                  [(pats ...) (values . #,bound-vars-list)]))))]))
+
+     (define-syntax (define/match stx)
+       (syntax-parse stx
+         [(_ ?header:function-header ?clause ...)
+          (template
+           (define ?header
+             (match* (?? ?header.params)
+               ?clause ...)))])))))

whalesong/lang/private/match/gen-match.rkt

@@ -0,0 +1,88 @@
+#lang racket/base
+
+(require "patterns.rkt" "compiler.rkt"
+         syntax/stx syntax/parse racket/syntax
+         (for-template racket/base (only-in "runtime.rkt" match:error fail)))
+
+(provide go go/one)
+
+;; this transforms `match'-style clauses into ones acceptable to `go'
+;; go : syntax syntax syntax -> syntax
+(define (go/one parse stx expr clauses)
+  (define-syntax-class cl
+    #:description "a clause with a pattern and a result"
+    (pattern [p . rhs]
+             #:with res (syntax/loc this-syntax [(p) . rhs])))
+  (syntax-parse clauses
+    [(c:cl ...)
+     (go parse stx (quasisyntax/loc expr (#,expr))
+         #'(c.res ...))]))
+
+;; this parses the clauses using parse, then compiles them
+;; go : syntax syntax syntax -> syntax
+(define (go parse stx es clauses)
+  (syntax-parse clauses
+    [([pats . rhs] ...)
+     (parameterize ([orig-stx stx])
+       (unless (syntax->list es)
+         (raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
+     (define/with-syntax form-name
+       (syntax-case stx ()
+         [(fname . _)
+          (identifier? #'fname)
+          (syntax-e #'fname)]
+         [_ 'match]))
+     (define len (length (syntax->list es)))
+     (define srcloc-list (list #`(quote #,(syntax-source stx))
+                               #`(quote #,(syntax-line stx))
+                               #`(quote #,(syntax-column stx))
+                               #`(quote #,(syntax-position stx))
+                               #`(quote #,(syntax-span stx))))
+     (define/with-syntax (xs ...) (generate-temporaries es))
+     (define/with-syntax (exprs ...) es)
+     (define/with-syntax outer-fail (generate-temporary #'fail))
+     (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
+     (define/with-syntax raise-error
+       (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
+     (define parsed-clauses
+       (for/list ([clause (syntax->list clauses)]
+                  [pats (syntax->list #'(pats ...))]
+                  [rhs (syntax->list #'(rhs ...))])
+         (unless (syntax->list pats)
+           (raise-syntax-error 'match* "expected a sequence of patterns" pats))
+         (define lp (length (syntax->list pats)))
+         (unless (= len lp)
+           (raise-syntax-error 
+            'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
+         (define (mk unm rhs)
+           (make-Row (for/list ([p (syntax->list pats)]) (parse p))
+                     (syntax-property
+                      (quasisyntax/loc stx
+                        (let () . #,rhs))
+                      'feature-profile:pattern-matching 'antimark)
+                     unm null))
+         (syntax-parse rhs
+           [()
+            (raise-syntax-error 
+             'match
+             "expected at least one expression on the right-hand side"
+             clause)]
+           [(#:when e)
+            (raise-syntax-error 
+             'match
+             "expected at least one expression on the right-hand side after #:when clause"
+             clause)]
+           [(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
+           [(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
+           [_ (mk #f rhs)])))
+     (define/with-syntax body 
+       (compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
+     (define/with-syntax (exprs* ...)
+       (for/list ([e (in-list (syntax->list #'(exprs ...)))])
+         (syntax-property e 'feature-profile:pattern-matching 'antimark)))
+    (syntax-property
+     (quasisyntax/loc stx
+      (let ([xs exprs*] ...)
+        (define (outer-fail) raise-error)
+        body))
+     'feature-profile:pattern-matching #t)]))

whalesong/lang/private/match/legacy-match.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+
+(require (only-in "runtime.rkt"
+                  match-equality-test
+                  exn:misc:match?)
+         (only-in "match-expander.rkt"
+                  define-match-expander)
+         "define-forms.rkt"
+         (for-syntax "parse-legacy.rkt"
+                     (only-in "patterns.rkt" match-...-nesting)))
+
+(provide (for-syntax match-...-nesting)
+         match-equality-test
+         define-match-expander
+         exn:misc:match?)
+
+(define-forms parse/legacy
+  match match* match-lambda match-lambda* match-lambda** match-let match-let*
+  match-let-values match-let*-values
+  match-define match-define-values match-letrec match/values match/derived match*/derived
+  define/match)

whalesong/lang/private/match/match-expander.rkt

@@ -0,0 +1,84 @@
+#lang whalesong
+
+(require (for-syntax racket/base "stxtime.rkt"))
+
+(provide define-match-expander)
+
+(begin-for-syntax
+  (define make-match-expander
+    (let ()
+      (define-struct match-expander (match-xform legacy-xform macro-xform)
+        #:property prop:set!-transformer 
+        (λ (me stx)
+          (define xf (match-expander-macro-xform me))
+          (if (set!-transformer? xf)
+              ((set!-transformer-procedure xf) stx)
+              (syntax-case stx (set!)
+                [(set! . _)
+                 (raise-syntax-error #f "cannot mutate syntax identifier" stx)]
+                [_ (xf stx)])))
+        #:property prop:match-expander (struct-field-index match-xform)
+        #:property prop:legacy-match-expander (struct-field-index legacy-xform))
+      (values make-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 (identifier? #'nm) #'macro-xform]
+                    [(set! . _)
+                     (raise-syntax-error #f "match expander cannot be target of a set!" stx)])))))
+           (syntax/loc stx
+             (define-syntax id
+               (make-match-expander match-xform legacy-xform macro-xform))))))]
+    ;; 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)]))

whalesong/lang/private/match/match.rkt

@@ -0,0 +1,34 @@
+#lang whalesong
+
+(require (only-in "runtime.rkt"
+                  match-equality-test
+                  exn:misc:match?)
+         (only-in "match-expander.rkt"
+                  define-match-expander)
+         "define-forms.rkt"
+         "struct.rkt"
+         (for-syntax racket/lazy-require
+                     (only-in "stxtime.rkt"
+                              match-...-nesting
+                              match-expander?
+                              legacy-match-expander?
+                              prop:match-expander
+                              prop:legacy-match-expander)))
+
+(require (for-syntax "parse.rkt")) ; [Whalesong]
+#;(begin-for-syntax
+    (lazy-require ["parse.rkt" (parse)]))
+
+(provide (for-syntax match-...-nesting match-expander? legacy-match-expander?
+                     prop:match-expander prop:legacy-match-expander)
+         match-equality-test
+         define-match-expander
+         struct* ==          
+         exn:misc:match?)
+
+(define-forms parse
+  match match* match-lambda match-lambda* match-lambda** match-let match-let*
+  match-let-values match-let*-values
+  match-define match-define-values match-letrec match/values
+  match/derived match*/derived
+  define/match)

whalesong/lang/private/match/parameters.rkt

@@ -0,0 +1,74 @@
+#lang whalesong
+; This module contains a poor man's parameters.
+(provide make-parameter parameterize)
+
+(require (for-syntax syntax/parse
+                     (only-in racket/base ... 
+                              with-syntax
+                              syntax
+                              generate-temporaries
+                              #%app)))
+
+; Assumptions:
+;   i) single thread
+;  ii) no continuation marks available
+; The return value of make-parameter is not the parameter structure,
+; but the getter/setter. When Whalesong gets support for applicable
+; structures, the structure should be returned instead.
+
+(struct param ([value #:mutable] getter guard)
+  ; #:property prop:procedure (struct-field-index getter)
+  ; Nope - whalesong does not support applicable structures
+  )
+
+(define (make-parameter v [guard #f]) ; -> parameter?
+  ; return new parameter procedure
+  ; the value is initialized to v (in all threads)
+  ; setting a new value will pass the value to a guard,
+  ; the value returned by the guard will be used as the new value
+  ; (the guard can raise an exception)
+  ; the guard is not called for the initial value
+  (letrec ([getter (λ xs 
+                     (if (null? xs)
+                         (param-value p)
+                         (set-param-value! p (car xs))))]
+           [p (param v getter (and guard (λ(x) x)))])
+    getter))
+
+(define-syntax (parameterize stx)
+  (syntax-parse stx
+    [(_ ([param-expr:expr val-expr:expr] ...) body0 body ...)
+     (with-syntax ([(param ...)     (generate-temporaries #'(param-expr ...))]
+                   [(old-value ...) (generate-temporaries #'(param-expr ...))])
+       #'(let ([param param-expr] ...)
+           (let ([old-value (param)] ...)
+             (param val-expr) ...
+             (begin0
+               (let () body0 body ...)
+               (param old-value) ...))))]))
+
+;;; Tests
+#;(begin
+    (define foo (make-parameter 11))
+    (list (list (foo) (foo 12) (foo))
+          (list 11 (void) 12))
+    
+    (define bar (make-parameter 21))
+    
+    (list (list (bar) (bar 22) (bar))
+          (list 21    (void)   22))
+    
+    (list (parameterize ([foo 13] [bar 23])
+            (list (foo) (bar)))
+          (list 13 23))
+    
+    (list (list (foo) (bar))
+          (list 12 22))
+    
+    (list (parameterize ([foo 13] [bar 23])
+            (list (parameterize ([foo 14] [bar 24])
+                    (list (foo) (bar)))
+                  (foo) (bar)))
+          (list (list 14 24) 13 23)))
+
+

whalesong/lang/private/match/parse-helper.rkt

@@ -0,0 +1,224 @@
+#lang racket/base
+
+(require (for-template racket/base)
+         syntax/boundmap
+         racket/struct-info
+         ;macro-debugger/emit
+         "patterns.rkt")
+
+(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
+         match-expander-transform trans-match parse-struct
+         dd-parse parse-quote parse-id in-splicing?)
+
+(define in-splicing? (make-parameter #f))
+
+;; parse x as a match variable
+;; x : identifier
+(define (parse-id x)
+  (cond [(eq? '_ (syntax-e x))
+         (make-Dummy x)]
+        [(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern"
+                                      x)]
+        [else (make-Var x)]))
+
+;; stx : syntax of pattern, starting with quote
+;; parse : the parse function
+(define (parse-quote stx parse)
+  (syntax-case stx (quote)
+    [(quote ())
+     (make-Null (make-Dummy stx))]
+    [(quote (a . b))
+     (make-Pair (parse (syntax/loc stx (quote a)))
+                (parse (syntax/loc stx (quote b))))]
+    [(quote vec)
+     (vector? (syntax-e #'vec))
+     (make-Vector (for/list ([e (syntax-e #'vec)])
+                    (parse (quasisyntax/loc stx (quote #,e)))))]
+    [(quote bx)
+     (box? (syntax-e #'bx))
+     (make-Box (parse (quasisyntax/loc 
+                       stx 
+                       (quote #,(unbox (syntax-e #'bx))))))]
+    [(quote v)
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
+    [_ (raise-syntax-error 'match "syntax error in quote pattern" stx)]))
+
+;; parse : the parse fn
+;; p : the repeated pattern
+;; dd : the ... stx
+;; rest : the syntax for the rest
+;; pred? : recognizer for the parsed data structure (such as list?)
+;; to-list: function to convert the value to a list
+(define (dd-parse parse p dd rest pred? #:to-list [to-list #'values] #:mutable [mutable? #f])
+  (define count (ddk? dd))
+  (define min (and (number? count) count))
+  (define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+                (parse p)))
+  (define rest-pat (parse rest))
+  (cond [(and (not (in-splicing?)) ;; when we're inside splicing, rest-pat isn't the rest
+              (not min) ;; if we have a count, better generate general code
+              (Null? rest-pat)
+              (or (Var? pat) (Dummy? pat)))
+         (make-And (list (make-Pred pred?) (make-App to-list (list pat))))]
+        [else (make-GSeq (list (list pat))
+                         (list min)
+                         ;; no upper bound
+                         (list #f)
+                         ;; patterns in p get bound to lists
+                         (list #f)
+                         rest-pat
+                         mutable?)]))
+
+;; stx : the syntax object for the whole pattern
+;; parse : the pattern parser
+;; struct-name : identifier
+;; pats : syntax representing the member patterns
+;; returns a pattern
+(define (parse-struct stx parse struct-name pats)
+  (let* ([fail (lambda ()
+                 (raise-syntax-error
+                  'match (format "~a does not refer to a structure definition"
+                                 (syntax->datum struct-name))
+                  stx struct-name))]
+         [v (syntax-local-value struct-name fail)])
+    (unless (struct-info? v) (fail))
+    (let-values ([(id _1 pred acc _2 super)
+                  (apply values (extract-struct-info v))])
+      ;; this produces a list of all the super-types of this struct
+      ;; ending when it reaches the top of the hierarchy, or a struct that we
+      ;; can't access
+      (define (get-lineage struct-name)
+        (let ([super (list-ref (extract-struct-info (syntax-local-value
+                                                     struct-name))
+                               5)])
+          (cond [(equal? super #t) (values #t '())] ;; no super type exists
+                [(equal? super #f) (values #f '())] ;; super type is unknown
+                [else 
+                 (let-values ([(complete? lineage) (get-lineage super)])
+                   (values complete?
+                           (cons super lineage)))])))
+      (unless pred
+        (raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
+                                           (syntax->datum struct-name))
+                            stx struct-name))
+      (let-values ([(complete? lineage) (get-lineage struct-name)])
+        (let* (;; the accessors come in reverse order
+               [acc (reverse acc)]
+               ;; remove the first element, if it's #f
+               [acc (cond [(null? acc) acc]
+                          [(not (car acc)) (cdr acc)]
+                          [else acc])])
+          (make-Struct pred
+                       (syntax-property 
+                        pred 
+                        'disappeared-use (list struct-name))
+                       lineage (and (checked-struct-info? v) complete?)
+                       acc
+                       (cond [(eq? '_ (syntax-e pats))                            
+                              (map make-Dummy acc)]
+                             [(syntax->list pats)
+                              =>
+                              (lambda (ps)
+                                (unless (= (length ps) (length acc))
+                                  (raise-syntax-error
+                                   'match
+                                   (format "~a structure ~a: expected ~a but got ~a"
+                                           "wrong number for fields for"
+                                           (syntax->datum struct-name) (length acc)
+                                           (length ps))
+                                   stx pats))
+                                (map parse ps))]
+                             [else (raise-syntax-error
+                                    'match
+                                    "improper syntax for struct pattern"
+                                    stx pats)])))))))
+
+(define (trans-match pred transformer pat)
+  (make-And (list (make-Pred pred) (make-App transformer (list pat)))))
+
+;; transform a match-expander application
+;; parse : stx -> pattern
+;; expander : identifier
+;; stx : the syntax of the match-expander application (armed)
+;; accessor : match-expander -> syntax transformer/#f
+;; error-msg : string
+;; produces a parsed pattern
+(define (match-expander-transform parse expander stx accessor
+                                  error-msg)
+  (let* ([expander* (syntax-local-value expander)]
+         [transformer (accessor expander*)]
+         ;; this transformer might have been defined w/ `syntax-id-rules'
+         [transformer (if (set!-transformer? transformer)
+                          (set!-transformer-procedure transformer)
+                          transformer)])
+    (unless transformer (raise-syntax-error #f error-msg expander*))
+    (let* ([introducer (make-syntax-introducer)]
+           [mstx (introducer (syntax-local-introduce stx))]
+           [mresult (if (procedure-arity-includes? transformer 2) 
+                        (transformer expander* mstx)
+                        (transformer mstx))]
+           [result (syntax-local-introduce (introducer mresult))])
+      ;(emit-local-step stx result #:id expander)
+      (parse result))))
+
+;; 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* ([m (regexp-match #rx"^(?:\\.\\.|__)([0-9]+)$"
+                                   (symbol->string s))]
+                  [n (and m (string->number (cadr m)))])
+             (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 : racket-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
+;; ps is never null
+;; check that all the ps bind the same set of variables
+(define (all-vars ps stx)  
+  (let* ([first-vars (bound-vars (car ps))]
+         [l (length ps)]
+         [ht (make-free-identifier-mapping)])
+    (for ([v first-vars]) (free-identifier-mapping-put! ht v 1))
+    (for* ([p (cdr ps)]
+           [v (bound-vars p)])
+      (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)]))
+    (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))))))

whalesong/lang/private/match/parse-legacy.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+(require (for-template racket/base)
+         "patterns.rkt"
+         "parse-helper.rkt"
+         "parse-quasi.rkt")
+
+(provide parse/legacy)
+
+(define orig-insp (variable-reference->module-declaration-inspector
+                   (#%variable-reference)))
+
+(define (parse/legacy stx)
+  (define (rearm new-stx) (syntax-rearm new-stx stx))
+  (define (parse stx) (parse/legacy (rearm stx)))
+  (define disarmed-stx (syntax-disarm stx orig-insp))
+  (syntax-case* disarmed-stx (not $ ? and or = quasiquote quote)
+                (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
+    [(expander args ...)
+     (and (identifier? #'expander)
+          (legacy-match-expander?
+           (syntax-local-value #'expander (λ () #f))))
+     (match-expander-transform
+      parse #'expander disarmed-stx legacy-match-expander-proc
+      "This expander only works with the standard match syntax")]
+    [(and p ...)
+     (make-And (map parse (syntax->list #'(p ...))))]
+    [(or)
+     (make-Not (make-Dummy stx))]
+    [(or p ps ...)
+     (let ([ps (map parse (syntax->list #'(p ps ...)))])
+       (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
+                               (list (parse (syntax/loc stx (es ...)))))))]
+    [#(es ...)
+     (make-Vector (map parse (syntax->list #'(es ...))))]
+    [($ s . pats)
+     (parse-struct disarmed-stx parse #'s #'pats)]
+    [(? p q1 qs ...)
+     (make-And (cons (make-Pred #'p)
+                     (map parse (syntax->list #'(q1 qs ...)))))]
+    [(? p)
+     (make-Pred (rearm #'p))]
+    [(= f p)
+     (make-App #'f (list (parse #'p)))]
+    [(quasiquote p)
+     (parse-quasi #'p parse)]
+    [(quote . rest)
+     (parse-quote disarmed-stx parse)]
+    [() (make-Null (make-Dummy #f))]
+    [(..)
+     (ddk? #'..)
+     (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
+    [(p .. . rest)
+     (ddk? #'..)
+     (dd-parse parse #'p #'.. #'rest #'list?)]
+    [(e . es)
+     (make-Pair (parse #'e) (parse (syntax/loc stx es)))]
+    [x
+     (identifier? #'x)
+     (parse-id #'x)]
+    [v
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "syntax error in pattern" stx))]))

whalesong/lang/private/match/parse-quasi.rkt

@@ -0,0 +1,87 @@
+#lang racket/base
+
+(require (for-template racket/base)
+         "patterns.rkt"
+         "parse-helper.rkt")
+
+(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)
+                               (GSeq-mutable? p1))]
+        [(Null? p1) p2]
+        [else (error 'match "illegal input to append-pats")]))
+
+;; parse stx as a quasi-pattern
+;; parse parses unquote
+(define (parse-quasi stx parse)
+  (define (pq s) (parse-quasi s parse))
+  (syntax-case stx (quasiquote unquote quote unquote-splicing)
+    [(unquote p) (parse #'p)]
+    [((unquote-splicing p) . rest)
+     (let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
+           [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 . rest)
+     (ddk? #'dd)
+     ;; FIXME: parameterize dd-parse so that it can be used here
+     (let* ([count (ddk? #'dd)]
+            [min (and (number? count) count)])
+       (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)
+        (pq #'rest)
+        #f))]
+    [(a . b) (make-Pair (pq #'a) (pq #'b))]
+    ;; prefab structs
+    [struct
+     (prefab-struct-key (syntax-e #'struct))
+     (let ([key (prefab-struct-key (syntax-e #'struct))]
+           [pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
+       (make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
+                       (make-App #'struct->vector
+                                 (list (make-Vector (cons (make-Dummy #f) (map pq pats)))))))
+       #;
+       (make-PrefabStruct key (map pq pats)))]
+    ;; 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
+                               (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))]))

whalesong/lang/private/match/parse.rkt

@@ -0,0 +1,184 @@
+#lang racket/base
+
+(require racket/struct-info
+         "patterns.rkt"
+         "parse-helper.rkt"
+         "parse-quasi.rkt"
+         (for-template (only-in "runtime.rkt" matchable? mlist? mlist->list)
+                       racket/base))
+
+(provide parse)
+
+(define (ht-pat-transform p)
+  (syntax-case p ()
+    [(a b) #'(list a b)]
+    [x (identifier? #'x) #'x]))
+
+(define orig-insp (variable-reference->module-declaration-inspector
+                   (#%variable-reference)))
+
+;; parse : syntax -> Pat
+;; compile stx into a pattern, using the new syntax
+(define (parse stx)
+  (define (rearm new-stx) (syntax-rearm new-stx stx))
+  (define (rearm+parse new-stx) (parse (rearm new-stx)))
+  (define disarmed-stx (syntax-disarm stx orig-insp))
+  (syntax-case* disarmed-stx (not var struct box cons list vector ? and or quote app
+                                  regexp pregexp list-rest list-no-order hash-table
+                                  quasiquote mcons list* mlist)
+                (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
+    [(expander args ...)
+     (and (identifier? #'expander)
+          (match-expander? (syntax-local-value #'expander
+                                               (lambda () #f))))
+     (match-expander-transform
+      rearm+parse #'expander disarmed-stx match-expander-proc
+      "This expander only works with the legacy match syntax")]
+    [(var v)
+     (identifier? #'v)
+     (Var (rearm #'v))]
+    [(and p ...)
+     (And (map rearm+parse (syntax->list #'(p ...))))]
+    [(or)
+     (Not (Dummy stx))]
+    [(or p ps ...)
+     (let ([ps (map rearm+parse (syntax->list #'(p ps ...)))])
+       (all-vars ps stx)
+       (Or ps))]
+    [(not p ...)
+     ;; nots are conjunctions of negations
+     (let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
+       (And ps))]
+    [(regexp r)
+     (trans-match #'matchable?
+                  (rearm #'(lambda (e) (regexp-match r e)))
+                  (Pred #'values))]
+    [(regexp r p)
+     (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
+    [(pregexp r)
+     (trans-match #'matchable?
+                  (rearm
+                   #'(lambda (e)
+                       (regexp-match (if (pregexp? r) r (pregexp r)) e)))
+                  (Pred #'values))]
+    [(pregexp r p)
+     (trans-match #'matchable?
+                  (rearm 
+                   #'(lambda (e)
+                       (regexp-match (if (pregexp? r) r (pregexp r)) e)))
+                  (rearm+parse #'p))]
+    [(box e) (Box (parse #'e))]
+    [(vector es ...)
+     (ormap ddk? (syntax->list #'(es ...)))
+     (trans-match #'vector?
+                  #'vector->list
+                  (rearm+parse (syntax/loc stx (list es ...))))]
+    [(vector es ...)
+     (Vector (map rearm+parse (syntax->list #'(es ...))))]
+    [(hash-table p ... dd)
+     (ddk? #'dd)
+     (trans-match
+      #'hash?
+      #'(lambda (e) (hash-map e list))
+      (with-syntax ([(elems ...)
+                     (map ht-pat-transform (syntax->list #'(p ...)))])
+        (rearm+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 ...)
+     (trans-match #'hash?
+                  #'(lambda (e) (hash-map e list))
+                  (with-syntax ([(elems ...)
+                                 (map ht-pat-transform
+                                      (syntax->list #'(p ...)))])
+                    (rearm+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 ...))])
+       (GSeq (cons (list (rearm+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))
+                  (Null (Dummy (syntax/loc stx _)))
+                  #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 ...))])
+       (GSeq (for/list ([p ps]) (list (rearm+parse p)))
+                  (map (lambda _ 1) ps)
+                  (map (lambda _ 1) ps)
+                  ;; all of these patterns get bound to only one thing
+                  (map (lambda _ #t) ps)
+                  (Null (Dummy (syntax/loc stx _)))
+                  #f))]
+    [(list) (Null (Dummy (syntax/loc stx _)))]
+    [(mlist) (Null (Dummy (syntax/loc stx _)))]
+    [(list ..)
+     (ddk? #'..)
+     (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
+    [(mlist ..)
+     (ddk? #'..)
+     (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
+    [(list p .. . rest)
+     (ddk? #'..)
+     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'list?)]
+    [(mlist p .. . rest)
+     (ddk? #'..)
+     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'mlist? #:to-list #'mlist->list #:mutable #t)]
+    [(list e es ...)
+     (Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
+    [(mlist e es ...)
+     (MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist es ...))))]
+    [(list* . rest)
+     (rearm+parse (syntax/loc stx (list-rest . rest)))]
+    [(list-rest e)
+     (rearm+parse #'e)]
+    [(list-rest p dd . rest)
+     (ddk? #'dd)
+     (dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)) #'list?)]
+    [(list-rest e . es)
+     (Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
+    [(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]
+    [(mcons e1 e2) (MPair (rearm+parse #'e1) (rearm+parse #'e2))]
+    [(struct s pats)
+     (parse-struct disarmed-stx rearm+parse #'s #'pats)]
+    [(s . pats)
+     (and (identifier? #'s) (struct-info? (syntax-local-value #'s (lambda () #f))))
+     (parse-struct disarmed-stx rearm+parse #'s #'pats)]
+    [(? p q1 qs ...)
+     (OrderedAnd 
+      (list (Pred (rearm #'p))
+            (And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
+    [(? p)
+     (Pred (rearm #'p))]
+    [(app f ps ...) ;; only make a list for more than one pattern
+     (App #'f (map rearm+parse (syntax->list #'(ps ...))))]
+    [(quasiquote p)
+     (parse-quasi #'p rearm+parse)]
+    [(quasiquote . _)
+     (raise-syntax-error 'match "illegal use of quasiquote")]
+    [(quote . _)
+     (parse-quote disarmed-stx rearm+parse)]
+    [x
+     (identifier? #'x)
+     (parse-id (rearm #'x))]
+    [v
+     (or (parse-literal (syntax-e #'v))
+         (raise-syntax-error 'match "syntax error in pattern" disarmed-stx))]))
+
+;; (trace parse)

whalesong/lang/private/match/patterns.rkt

@@ -0,0 +1,212 @@
+#lang racket/base
+
+(require syntax/boundmap
+         racket/contract
+         "stxtime.rkt"
+         (for-syntax racket/base))
+
+(provide (except-out (combine-out 
+                      (all-defined-out)
+                      (all-from-out "stxtime.rkt"))
+                     struct-key-ht
+                     get-key
+                     (struct-out Row)))
+
+(define orig-stx (make-parameter #f))
+
+(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 (Pair CPat) (a d) #:transparent)
+(define-struct (MPair 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
+;; ps is a list of patterns
+(define-struct (App Pat) (expr ps) #:transparent)
+
+;; pred is an expression
+(define-struct (Pred Pat) (pred) #:transparent)
+
+;; pred is an identifier
+;; super is an identifier, or #f
+;; complete? is a boolean
+;; 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 complete? 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)
+(define-struct (OrderedAnd And) () #: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
+;; mutable? : is this for mutable lists?
+(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent)
+
+;; match with equal?
+;; v is a quotable racket 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 <expr>)" (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]
+        [(MPair? p) 'mpair]
+        [(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]))
+
+;; (require mzlib/trace)
+;; (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* ([ids l] [id ids])
+                  (module-identifier-mapping-put! m id #t))
+                (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)
+     (let ([v (Var-v p)])
+       (list (free-identifier-mapping-get (current-renaming) v (lambda () v))))]
+    [(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))))]
+    [(MPair? p)
+     (merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-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)
+     (merge (map bound-vars (App-ps p)))]
+    [(Not? p) null]
+    [(And? p)
+     (merge (map bound-vars (And-ps p)))]
+    [(Exact? p) null]
+    [else (error 'match "bad pattern: ~a" p)]))
+
+(define current-renaming (make-parameter (make-free-identifier-mapping)))
+
+(define (copy-mapping ht)
+  (define new-ht (make-free-identifier-mapping))
+  (free-identifier-mapping-for-each
+   ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
+  new-ht)
+
+#|
+;; 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?))])))
+

whalesong/lang/private/match/reorder.rkt

@@ -0,0 +1,87 @@
+#lang racket/base
+
+(require "patterns.rkt"
+         (for-syntax racket/base))
+
+(provide reorder-columns)
+
+#|
+(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))
+
+(define r5 (make-Row (list p-x p-y p-cons) #'1 #f null))
+(define r6 (make-Row (list p-cons p-y p-vec) #'1 #f null))
+|#
+
+(define-sequence-syntax in-par
+    (lambda () (raise-syntax-error 'in-par "bad"))
+    (lambda (stx)
+      (syntax-case stx ()
+        [((id) (_ lst-exprs))
+         #'[(id)
+            (:do-in
+             ;;outer bindings
+             ([(lst) lst-exprs])
+             ;; outer check
+             (void) ; (unless (list? lst) (in-list lst))
+             ;; loop bindings
+             ([lst lst])
+             ;; pos check
+             (not (ormap null? lst))
+             ;; inner bindings
+             ([(id) (map car lst)])
+             ;; pre guard
+             #t
+             ;; post guard
+             #t
+             ;; loop args
+             ((map cdr lst)))]]
+        [_ (error 'no (syntax->datum stx))])))
+
+(define (or-all? ps l)
+  (ormap (lambda (p) (andmap p l)) ps))
+
+(define (count-while pred l)
+  (for/sum ([e (in-list l)] #:break (not (pred e))) 1))
+
+(define (score col)
+  (define n (length col))
+  (define c (car col))
+  (define preds (list Var? Pair? Null?))
+  (cond [(or-all? preds col) (add1 n)]
+        [(andmap CPat? col) n]
+        [(Var? c)    (count-while Var? col)]
+        [(Pair? c)   (count-while Pair? col)]
+        [(Vector? c) (count-while Vector? col)]
+        [(Box? c)    (count-while Box? col)]
+        [else 0]))
+
+(define (reorder-by ps scores*)
+  (for/fold 
+      ([pats null])
+    ([score-ref scores*])
+    (cons (list-ref ps score-ref) pats)))
+
+
+(define (reorder-columns rows vars)
+  (define scores (for/list ([i (in-naturals)]
+                            [column (in-par (map (compose Row-pats) rows))])
+                   (cons i (score column))))
+  (define scores* (reverse (map car (sort scores > #:key cdr))))
+  (values
+   (for/list ([row rows])
+     (let ([ps (Row-pats row)])
+       (make-Row (reorder-by ps scores*)
+                 (Row-rhs row)
+                 (Row-unmatch row)
+                 (Row-vars-seen row))))
+   (reorder-by vars scores*)))

whalesong/lang/private/match/runtime.rkt

@@ -0,0 +1,72 @@
+#lang whalesong
+(require "parameters.rkt") ; whalesong-libs
+
+(require racket/stxparam
+         (for-syntax racket/base))
+
+(provide match-equality-test
+         exn:misc:match?
+         match:error
+         fail
+         matchable?
+         match-prompt-tag
+         mlist? mlist->list)
+
+(define match-prompt-tag (make-continuation-prompt-tag 'match)) 
+
+; (define match-equality-test (make-parameter equal?))
+; This is an parameter that a user of match can set in order
+; to change the the equality operations used to determine
+; if repeated uses of an identifier in a pattern has "equal" values.
+; The default is equal?, so in the Whalesong matcher we just hardcode it.
+(define match-equality-test (λ () equal?))
+
+
+(define-struct (exn:misc:match exn:fail) (value srclocs)
+ #:property prop:exn:srclocs (lambda (ex) (exn:misc:match-srclocs ex)))
+
+
+(define (match:error val srclocs form-name)
+  (raise (make-exn:misc:match (format "~a: no matching clause for ~e" form-name val)
+                              (current-continuation-marks)
+                              val
+                              srclocs)))
+
+(define-syntax-parameter fail
+  (lambda (stx)
+    (raise-syntax-error
+     #f "used out of context: not in match pattern" stx)))
+
+;; can we pass this value to regexp-match?
+(define (matchable? e)
+  (or (string? e) 
+      ; (bytes? e)   ; [Whalesong] no byte strings
+      ))
+
+;; duplicated because we can't depend on `compatibility` here
+(define mpair? pair?)  ; [Whalesong] no mutable pairs
+(define mcdr cdr)      ; [Whalesong]
+(define mcar car)
+(define (mlist? l)
+  (cond
+   [(null? l) #t]
+   [(mpair? l)
+    (let loop ([turtle l][hare (mcdr l)])
+      (cond
+       [(null? hare) #t]
+       [(eq? hare turtle) #f]
+       [(mpair? hare)
+        (let ([hare (mcdr hare)])
+          (cond
+           [(null? hare) #t]
+           [(eq? hare turtle) #f]
+           [(mpair? hare)
+            (loop (mcdr turtle) (mcdr hare))]
+           [else #f]))]
+       [else #f]))]
+   [else #f]))
+
+(define (mlist->list l)
+  (cond
+   [(null? l) null]
+   [else (cons (mcar l) (mlist->list (mcdr l)))]))

whalesong/lang/private/match/split-rows.rkt

@@ -0,0 +1,81 @@
+#lang racket/base
+
+(require "patterns.rkt")
+
+(provide split-rows)
+
+;; split-rows : Listof[Row] -> Listof[Listof[Row]]
+;; takes a matrix, and returns a list of matrices
+;; 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)
+    (if (null? rows)
+      (reverse (cons (reverse matched-rows) prev-mats))
+      (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)
+    (if (null? rows)
+      (reverse (cons (reverse matched-rows) prev-mats))
+      (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)
+    (if (null? rows)
+      (reverse (cons (reverse matched-rows) prev-mats))
+      (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))]))))
+  (if (null? rows)
+    (reverse acc)
+    (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))
+|#

whalesong/lang/private/match/struct.rkt

@@ -0,0 +1,80 @@
+#lang whalesong
+(require "match-expander.rkt"
+         (for-syntax racket/base
+                     racket/struct-info
+                     syntax/id-table
+                     racket/list))
+
+(define-match-expander
+  struct*
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ struct-name (field+pat ...))
+       (let* ([fail (lambda ()
+                      (raise-syntax-error
+                       'struct* "not a structure definition"
+                       stx #'struct-name))]
+              [v (if (identifier? #'struct-name)
+                     (syntax-local-value #'struct-name fail)
+                     (fail))]
+              [field-acc->pattern (make-free-id-table)])
+         (unless (struct-info? v) (fail))
+         ; Check each pattern and capture the field-accessor name
+         (for-each (lambda (an)
+                     (syntax-case an ()
+                       [(field pat)
+                        (unless (identifier? #'field)
+                          (raise-syntax-error 
+                           'struct* "not an identifier for field name" 
+                           stx #'field))
+                        (let ([field-acc
+                               (datum->syntax #'field
+                                              (string->symbol
+                                               (format "~a-~a"
+                                                       (syntax-e #'struct-name)
+                                                       (syntax-e #'field)))
+                                              #'field)])
+                          (when (free-id-table-ref field-acc->pattern field-acc #f)
+                            (raise-syntax-error 'struct* "Field name appears twice" stx #'field)) 
+                          (free-id-table-set! field-acc->pattern field-acc #'pat))]
+                       [_
+                        (raise-syntax-error
+                         'struct* "expected a field pattern of the form (<field-id> <pat>)"
+                         stx an)]))
+                   (syntax->list #'(field+pat ...)))
+         (let* (; Get the structure info
+                [acc (fourth (extract-struct-info v))]
+                ;; the accessors come in reverse order
+                [acc (reverse acc)]
+                ;; remove the first element, if it's #f
+                [acc (cond [(empty? acc) acc]
+                           [(not (first acc)) (rest acc)]
+                           [else acc])]
+                ; Order the patterns in the order of the accessors
+                [pats-in-order
+                 (for/list ([field-acc (in-list acc)])
+                   (begin0
+                     (free-id-table-ref
+                      field-acc->pattern field-acc
+                      (syntax/loc stx _))
+                     ; Use up pattern
+                     (free-id-table-remove! field-acc->pattern field-acc)))])
+           ; Check that all patterns were used
+           (free-id-table-for-each
+            field-acc->pattern
+            (lambda (field-acc pat)
+              (when pat
+                (raise-syntax-error 'struct* "field name not associated with given structure type"
+                                    stx field-acc))))
+           (quasisyntax/loc stx
+             (struct struct-name #,pats-in-order))))])))
+
+(provide struct* ==)
+
+(define-match-expander
+  ==
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ val comp)
+       #'(? (lambda (x) (comp val x)))]
+      [(_ val) #'(? (lambda (x) (equal? val x)))])))

whalesong/lang/private/match/stxtime.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+(provide (all-defined-out))
+
+(define match-...-nesting (make-parameter 0))
+
+(struct acc-prop (n acc))
+
+(define (make-struct-type-property/accessor name [guard #f] [supers null])
+  (define-values (p pred? acc)
+    (make-struct-type-property name
+     (λ (pval sinfo)
+	(cond [(exact-nonnegative-integer? pval)
+	       (acc-prop pval (cadddr sinfo))]
+	      [else (if (procedure? guard) 
+			(guard pval sinfo)
+			pval)]))
+     supers))
+  (values p pred? (lambda (v)
+		    (define v* (acc v))
+		    (if (acc-prop? v*)
+			((acc-prop-acc v*) v (acc-prop-n v*))
+			v*))))
+
+(define-values (prop:match-expander match-expander? match-expander-proc) 
+  (make-struct-type-property/accessor 'prop:match-expander))
+
+(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc)
+  (make-struct-type-property/accessor 'prop:legacy-match-expander ))