suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Conservative extension to match so that app patterns may produce and consume multiple values.

Browse Source
This commit is contained in:
J. Ian Johnson 2013-09-28 22:17:20 -04:00 committed by Sam Tobin-Hochstadt
parent 1260d7e8cd
commit b32697bd88
9 changed files with 26 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-pkgs/racket-doc/scribblings/reference/match-grammar.rkt
View File

@ -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

6
pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl
View File

@ -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

6
pkgs/racket-pkgs/racket-test/tests/match/examples.rkt
View File

@ -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]

11
racket/collects/racket/match/compiler.rkt
View File

@ -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)))

2
racket/collects/racket/match/parse-helper.rkt
View File

@ -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

4
racket/collects/racket/match/parse-legacy.rkt
View File

@ -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)

4
racket/collects/racket/match/parse-quasi.rkt
View File

@ -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

4
racket/collects/racket/match/parse.rkt
View File

@ -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 . _)

4
racket/collects/racket/match/patterns.rkt
View File

@ -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)))]