diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match-grammar.rkt b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match-grammar.rkt index 1735d66c8f..568267f7a6 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match-grammar.rkt +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match-grammar.rkt @@ -28,7 +28,7 @@ pat ::= id @match anything, bind identifier | (AND pat ...) @match when all pats match | (OR pat ...) @match when any pat match | (NOT pat ...) @match when no pat matches - | (APP expr pat) @match (expr value) to pat + | (APP expr pats ...) @match (expr value) output values to pats | (? expr pat ...) @match if (expr value) and pats | (QUASIQUOTE qp) @match a quasipattern | derived-pattern @match using extension diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl index 8aa68973c4..dfc8aace34 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl @@ -313,14 +313,16 @@ In more detail, patterns match as follows: [_ 'no]) ]} - @item{@racket[(#,(racketidfont "app") _expr _pat)] --- applies + @item{@racket[(#,(racketidfont "app") _expr _pats ...)] --- applies @racket[_expr] to the value to be matched; the result of the - application is matched against @racket[_pat]. + application is matched against @racket[_pats]. @examples[ #:eval match-eval (match '(1 2) [(app length 2) 'yes]) + (match '(1 2) + [(app (lambda (v) (split-at v 1)) '(1) '(2)) 'yes]) ]} @item{@racket[(#,(racketidfont "?") _expr _pat ...)] --- applies diff --git a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt index f79c81f6f1..42646e5bcc 100644 --- a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt @@ -3,6 +3,7 @@ (require scheme/match scheme/mpair scheme/control scheme/foreign + (only-in racket/list split-at) (for-syntax scheme/base) (prefix-in m: mzlib/match) (only-in srfi/13 string-contains) @@ -278,6 +279,11 @@ [(or (list a 1) (list a 2)) a] [_ 'bad])) + (comp 'yes + (match '(1 2) + [(app (lambda (v) (split-at v 1)) '(1) '(2)) 'yes] + [_ 'bad])) + (comp '(2 3) (match '(1 (2 3) 4) [(list _ (and a (list _ ...)) _) a] diff --git a/racket/collects/racket/match/compiler.rkt b/racket/collects/racket/match/compiler.rkt index 0044029b71..1a08c5ef75 100644 --- a/racket/collects/racket/match/compiler.rkt +++ b/racket/collects/racket/match/compiler.rkt @@ -234,11 +234,12 @@ (unless (null? (cdr block)) (error 'compile-one "App block with multiple rows: ~a" block)) (let* ([row (car block)] - [pats (Row-pats row)]) - (with-syntax ([(t) (generate-temporaries #'(t))]) - #`(let ([t (#,(App-expr first) #,x)]) - #,(compile* (cons #'t xs) - (list (make-Row (cons (App-p first) (cdr pats)) + [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))) diff --git a/racket/collects/racket/match/parse-helper.rkt b/racket/collects/racket/match/parse-helper.rkt index 98596e5db5..d63b07612d 100644 --- a/racket/collects/racket/match/parse-helper.rkt +++ b/racket/collects/racket/match/parse-helper.rkt @@ -125,7 +125,7 @@ stx pats)]))))))) (define (trans-match pred transformer pat) - (make-And (list (make-Pred pred) (make-App transformer pat)))) + (make-And (list (make-Pred pred) (make-App transformer (list pat))))) ;; transform a match-expander application ;; parse : stx -> pattern diff --git a/racket/collects/racket/match/parse-legacy.rkt b/racket/collects/racket/match/parse-legacy.rkt index d717f988bc..58a40f7b73 100644 --- a/racket/collects/racket/match/parse-legacy.rkt +++ b/racket/collects/racket/match/parse-legacy.rkt @@ -42,7 +42,7 @@ (ormap ddk? (syntax->list #'(es ...))) (make-And (list (make-Pred #'vector?) (make-App #'vector->list - (parse (syntax/loc stx (es ...))))))] + (list (parse (syntax/loc stx (es ...)))))))] [#(es ...) (make-Vector (map parse (syntax->list #'(es ...))))] [($ s . pats) @@ -53,7 +53,7 @@ [(? p) (make-Pred (rearm #'p))] [(= f p) - (make-App #'f (parse #'p))] + (make-App #'f (list (parse #'p)))] [(quasiquote p) (parse-quasi #'p parse)] [(quote . rest) diff --git a/racket/collects/racket/match/parse-quasi.rkt b/racket/collects/racket/match/parse-quasi.rkt index 8248a94e64..5ba6cef4fe 100644 --- a/racket/collects/racket/match/parse-quasi.rkt +++ b/racket/collects/racket/match/parse-quasi.rkt @@ -60,7 +60,7 @@ [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 - (make-Vector (cons (make-Dummy #f) (map pq pats)))))) + (list (make-Vector (cons (make-Dummy #f) (map pq pats))))))) #; (make-PrefabStruct key (map pq pats)))] ;; the hard cases @@ -73,7 +73,7 @@ (syntax->list #'(p ...))) (make-And (list (make-Pred #'vector?) (make-App #'vector->list - (pq (quasisyntax/loc stx (p ...))))))] + (list (pq (quasisyntax/loc stx (p ...)))))))] [#(p ...) (make-Vector (map pq (syntax->list #'(p ...))))] [bx diff --git a/racket/collects/racket/match/parse.rkt b/racket/collects/racket/match/parse.rkt index f53573b4a9..57b2cbf132 100644 --- a/racket/collects/racket/match/parse.rkt +++ b/racket/collects/racket/match/parse.rkt @@ -166,8 +166,8 @@ (And (map rearm+parse (syntax->list #'(q1 qs ...))))))] [(? p) (Pred (rearm #'p))] - [(app f p) - (App #'f (rearm+parse #'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 . _) diff --git a/racket/collects/racket/match/patterns.rkt b/racket/collects/racket/match/patterns.rkt index 650e5022a3..6eb669ee2a 100644 --- a/racket/collects/racket/match/patterns.rkt +++ b/racket/collects/racket/match/patterns.rkt @@ -51,7 +51,7 @@ ;; expr is an expression ;; p is a pattern -(define-struct (App Pat) (expr p) #:transparent) +(define-struct (App Pat) (expr ps) #:transparent) ;; pred is an expression (define-struct (Pred Pat) (pred) #:transparent) @@ -173,7 +173,7 @@ [(Struct? p) (merge (map bound-vars (Struct-ps p)))] [(App? p) - (bound-vars (App-p p))] + (merge (map bound-vars (App-ps p)))] [(Not? p) null] [(And? p) (merge (map bound-vars (And-ps p)))]