diff --git a/collects/racket/match/compiler.rkt b/collects/racket/match/compiler.rkt index 767d67134e..718fd74ffd 100644 --- a/collects/racket/match/compiler.rkt +++ b/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 - ;; give us + ;; 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)) - (let* ([row (car block)] - [pats (Row-pats row)] - ;; all the patterns - [qs (And-ps (car pats))]) - (compile* (append (map (lambda _ x) qs) xs) - (list (make-Row (append qs (cdr pats)) - (Row-rhs row) - (Row-unmatch row) - (Row-vars-seen row))) - esc))] + (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 @@ -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) diff --git a/collects/racket/match/parse.rkt b/collects/racket/match/parse.rkt index 04737ba8b2..f53573b4a9 100644 --- a/collects/racket/match/parse.rkt +++ b/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 ...)))]) - (make-And ps))] + (let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))]) + (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 _)))] - [(mlist) (make-Null (make-Dummy (syntax/loc stx _)))] + [(list) (Null (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))))] - [(cons e1 e2) (make-Pair (rearm+parse #'e1) (rearm+parse #'e2))] - [(mcons e1 e2) (make-MPair (rearm+parse #'e1) (rearm+parse #'e2))] + (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 ...) - (make-And (cons (make-Pred (rearm #'p)) - (map rearm+parse (syntax->list #'(q1 qs ...)))))] + (OrderedAnd + (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 . _) diff --git a/collects/racket/match/patterns.rkt b/collects/racket/match/patterns.rkt index 3763f6812e..650e5022a3 100644 --- a/collects/racket/match/patterns.rkt +++ b/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) diff --git a/collects/racket/match/reorder.rkt b/collects/racket/match/reorder.rkt index d1da55d703..44cc47fa56 100644 --- a/collects/racket/match/reorder.rkt +++ b/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]) - (if (or (null? l) (not (pred (car l)))) r (loop (cdr l) (add1 r))))) + (for/sum ([e (in-list l)] #:break (not (pred e))) 1)) (define (score col) (define n (length col)) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index 8c7accbd13..8aa68973c4 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/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 - application and an @racketidfont{and} pattern). + also match; i.e., @racketidfont{?} combines a predicate + 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