Add OrderedAnd patterns, and use them in ? patterns.

This guarantees that patterns like (? pred pat) will
always check `pred` before matching any of `pat`.
However, `and` patterns are not required to match left-
to-right.

collects/racket/match/compiler.rkt

@@ -249,20 +249,22 @@
                          esc))))]
     ;; the And rule
     [(And? first)
-     ;; we only handle 1-row Ands atm - this is all the mixture rule should
+     ;; we only handle 1-row Ands 
-     ;; give us
+     ;; 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)]
+     (define row (car block))
-            [pats (Row-pats row)]
+     (define pats (Row-pats row))
      ;; all the patterns
-            [qs (And-ps (car pats))])
+     (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))]
+               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
@@ -407,7 +409,7 @@
                         #'failkv)))]
     [else (error 'compile "unsupported pattern: ~a\n" first)]))
 
-(define (compile* vars rows esc)
+(define (compile* vars rows esc [reorder? #t])
   (define (let/wrap clauses body)
     (if (stx-null? clauses)
       body
@@ -447,7 +449,9 @@
     ;; and compile each block with a reference to its continuation
    [else
     (let*-values
-        ([(rows vars) (reorder-columns rows vars)]
+        ([(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)

collects/racket/match/parse.rkt

@@ -36,23 +36,23 @@
       "This expander only works with the legacy match syntax")]
     [(var v)
      (identifier? #'v)
-     (make-Var (rearm #'v))]
+     (Var (rearm #'v))]
     [(and p ...)
-     (make-And (map rearm+parse (syntax->list #'(p ...))))]
+     (And (map rearm+parse (syntax->list #'(p ...))))]
     [(or)
-     (make-Not (make-Dummy stx))]
+     (Not (Dummy stx))]
     [(or p ps ...)
      (let ([ps (map rearm+parse (syntax->list #'(p ps ...)))])
        (all-vars ps stx)
-       (make-Or ps))]
+       (Or ps))]
     [(not p ...)
      ;; nots are conjunctions of negations
-     (let ([ps (map (compose make-Not rearm+parse) (syntax->list #'(p ...)))])
+     (let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
-       (make-And ps))]
+       (And ps))]
     [(regexp r)
      (trans-match #'matchable?
                   (rearm #'(lambda (e) (regexp-match r e)))
-                  (make-Pred #'values))]
+                  (Pred #'values))]
     [(regexp r p)
      (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
     [(pregexp r)
@@ -60,21 +60,21 @@
                   (rearm
                    #'(lambda (e)
                        (regexp-match (if (pregexp? r) r (pregexp r)) e)))
-                  (make-Pred #'values))]
+                  (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) (make-Box (parse #'e))]
+    [(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 ...)
-     (make-Vector (map rearm+parse (syntax->list #'(es ...))))]
+     (Vector (map rearm+parse (syntax->list #'(es ...))))]
     [(hash-table p ... dd)
      (ddk? #'dd)
      (trans-match
@@ -103,13 +103,13 @@
             [min (if (number? count) count #f)]
             [max (if (number? count) count #f)]
             [ps (syntax->list #'(p ...))])
-       (make-GSeq (cons (list (rearm+parse #'lp))
+       (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))
-                  (make-Null (make-Dummy (syntax/loc stx _)))
+                  (Null (Dummy (syntax/loc stx _)))
                   #f))]
     [(list-no-order p ...)
      (ormap ddk? (syntax->list #'(p ...)))
@@ -119,15 +119,15 @@
       (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 (rearm+parse 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)
-                  (make-Null (make-Dummy (syntax/loc stx _)))
+                  (Null (Dummy (syntax/loc stx _)))
                   #f))]
-    [(list) (make-Null (make-Dummy (syntax/loc stx _)))]
+    [(list) (Null (Dummy (syntax/loc stx _)))]
-    [(mlist) (make-Null (make-Dummy (syntax/loc stx _)))]
+    [(mlist) (Null (Dummy (syntax/loc stx _)))]
     [(list ..)
      (ddk? #'..)
      (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
@@ -141,9 +141,9 @@
      (ddk? #'..)
      (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
     [(list e es ...)
-     (make-Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
+     (Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
     [(mlist e es ...)
-     (make-MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist 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)
@@ -152,21 +152,22 @@
      (ddk? #'dd)
      (dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
     [(list-rest e . es)
-     (make-Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
+     (Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
-    [(cons e1 e2) (make-Pair (rearm+parse #'e1) (rearm+parse #'e2))]
+    [(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]
-    [(mcons e1 e2) (make-MPair (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 ...)
-     (make-And (cons (make-Pred (rearm #'p))
+     (OrderedAnd 
-                     (map rearm+parse (syntax->list #'(q1 qs ...)))))]
+      (list (Pred (rearm #'p))
+            (And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
     [(? p)
-     (make-Pred (rearm #'p))]
+     (Pred (rearm #'p))]
     [(app f p)
-     (make-App #'f (rearm+parse #'p))]
+     (App #'f (rearm+parse #'p))]
     [(quasiquote p)
      (parse-quasi #'p rearm+parse)]
     [(quasiquote . _)

collects/racket/match/patterns.rkt

@@ -69,6 +69,7 @@
 ;; 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)
 

collects/racket/match/reorder.rkt

@@ -51,8 +51,7 @@
   (ormap (lambda (p) (andmap p l)) ps))
 
 (define (count-while pred l)
-  (let loop ([l l] [r 0])
+  (for/sum ([e (in-list l)] #:break (not (pred e))) 1))
-    (if (or (null? l) (not (pred (car l)))) r (loop (cdr l) (add1 r)))))
 
 (define (score col)
   (define n (length col))

collects/scribblings/reference/match.scrbl

@@ -326,8 +326,10 @@ In more detail, patterns match as follows:
  @item{@racket[(#,(racketidfont "?") _expr _pat ...)] --- applies
        @racket[_expr] to the value to be matched, and checks whether
        the result is a true value; the additional @racket[_pat]s must
-       also match (i.e., @racketidfont{?} combines a predicate
+       also match; i.e., @racketidfont{?} combines a predicate
-       application and an @racketidfont{and} pattern).
+       application and an @racketidfont{and} pattern.  However,
+       @racketidfont{?}, unlike @racketidfont{and}, guarantees that
+       @racket[_expr] is matched before any of the @racket[_pat]s.
 
        @examples[
        #:eval match-eval