From 2bf93a2fa0e35b4e5d7deecb3f314e7f5ab162b1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 9 May 2008 19:47:28 +0000 Subject: [PATCH] Add mlist patterns, and handle ... svn: r9774 --- collects/scheme/match/compiler.ss | 2 ++ collects/scheme/match/parse-helper.ss | 50 ++++++++++++++++----------- collects/scheme/match/parse-quasi.ss | 6 ++-- collects/scheme/match/parse.ss | 17 +++++++-- collects/scheme/match/patterns.ss | 3 +- collects/tests/match/examples.ss | 24 ++++++++++++- 6 files changed, 74 insertions(+), 28 deletions(-) diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index aca476793a..e2176c2c50 100644 --- a/collects/scheme/match/compiler.ss +++ b/collects/scheme/match/compiler.ss @@ -307,6 +307,8 @@ [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 diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss index 4c43210164..2c8304f8cd 100644 --- a/collects/scheme/match/parse-helper.ss +++ b/collects/scheme/match/parse-helper.ss @@ -48,17 +48,19 @@ ;; p : the repeated pattern ;; dd : the ... stx ;; rest : the syntax for the rest -(define (dd-parse parse p dd rest) +(define (dd-parse parse p dd rest #:mutable [mutable? #f]) (let* ([count (ddk? dd)] [min (and (number? count) count)]) - (make-GSeq (parameterize ([match-...-nesting (add1 (match-...-nesting))]) - (list (list (parse p)))) - (list min) - ;; no upper bound - (list #f) - ;; patterns in p get bound to lists - (list #f) - (parse rest)))) + (make-GSeq + (parameterize ([match-...-nesting (add1 (match-...-nesting))]) + (list (list (parse p)))) + (list min) + ;; no upper bound + (list #f) + ;; patterns in p get bound to lists + (list #f) + (parse rest) + mutable?))) ;; stx : the syntax object for the whole pattern ;; cert : the certifier @@ -93,18 +95,24 @@ [(not (car acc)) (cdr acc)] [else acc])]) (make-Struct id pred (get-lineage (cert struct-name)) acc - (if (eq? '_ (syntax-e pats)) - (map make-Dummy acc) - (let* ([ps (syntax->list pats)]) - (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)))))))) + (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 pat)))) diff --git a/collects/scheme/match/parse-quasi.ss b/collects/scheme/match/parse-quasi.ss index de7836e431..d602d94791 100644 --- a/collects/scheme/match/parse-quasi.ss +++ b/collects/scheme/match/parse-quasi.ss @@ -25,7 +25,8 @@ (GSeq-mins p1) (GSeq-maxs p1) (GSeq-onces? p1) - (append-pats (GSeq-tail p1) p2))] + (append-pats (GSeq-tail p1) p2) + (GSeq-mutable? p1))] [(Null? p1) p2] [else (error 'match "illegal input to append-pats")])) @@ -55,7 +56,8 @@ (list #f) ;; patterns in p get bound to lists (list #f) - (make-Null (make-Dummy #f))))] + (make-Null (make-Dummy #f)) + #f))] [(a . b) (make-Pair (pq #'a) (pq #'b))] ;; the hard cases [#(p ...) diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss index c2ed077f26..c2a18d6eb0 100644 --- a/collects/scheme/match/parse.ss +++ b/collects/scheme/match/parse.ss @@ -24,7 +24,7 @@ (define (parse stx) (parse/cert stx cert)) (syntax-case* stx (not var struct box cons list vector ? and or quote app regexp pregexp list-rest list-no-order hash-table - quasiquote mcons list*) + quasiquote mcons list* mlist) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(expander args ...) (and (identifier? #'expander) @@ -104,7 +104,8 @@ (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 #f))))] + (make-Null (make-Dummy #f)) + #f))] [(list-no-order p ...) (ormap ddk? (syntax->list #'(p ...))) (raise-syntax-error @@ -118,16 +119,26 @@ (map (lambda _ 1) ps) ;; all of these patterns get bound to only one thing (map (lambda _ #t) ps) - (make-Null (make-Dummy #f))))] + (make-Null (make-Dummy #f)) + #f))] [(list) (make-Null (make-Dummy stx))] + [(mlist) (make-Null (make-Dummy 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 parse #'p #'.. (syntax/loc stx (list . rest)))] + [(mlist p .. . rest) + (ddk? #'..) + (dd-parse parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)] [(list e es ...) (make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))] + [(mlist e es ...) + (make-MPair (parse #'e) (parse (syntax/loc stx (mlist es ...))))] [(list* . rest) (parse (syntax/loc stx (list-rest . rest)))] [(list-rest e) diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss index 30543f7bcb..e0ae6be6a1 100644 --- a/collects/scheme/match/patterns.ss +++ b/collects/scheme/match/patterns.ss @@ -84,7 +84,8 @@ ;; onces? : listof boolean -- is this pattern being bound only once (take the ;; car of the variables) ;; tail : pattern -(define-struct (GSeq Pat) (headss mins maxs onces? tail) #:transparent) +;; mutable? : is this for mutable lists? +(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent) ;; match with equal? ;; v is a quotable scheme value diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss index 23af910c9d..cebe591dfe 100644 --- a/collects/tests/match/examples.ss +++ b/collects/tests/match/examples.ss @@ -1,8 +1,10 @@ #lang scheme/base (require scheme/match + scheme/mpair (for-syntax scheme/base) - (prefix-in m: mzlib/match)) + (prefix-in m: mzlib/match) + (only-in srfi/13 string-contains)) (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) @@ -516,6 +518,16 @@ [(mcons a b) (+ a b)] [_ 'no])) + (comp 3 + (match (mlist 1 2) + [(mlist a b) (+ a b)] + [_ 'no])) + + (comp 3 + (match (mlist 1 2) + [(mlist a ...) (apply + a)] + [_ 'no])) + (comp 1 (match (box 'x) ('#&x 1) (else #f))) @@ -527,6 +539,16 @@ [values (lambda _ 'no)]) (match 1) 'no)) + + (comp 'yes + (with-handlers ([exn:fail:syntax? (lambda _ 'yes)] + [values (lambda _ 'no)]) + (expand #'(let () + (define-struct foo (bar)) + (define the-bar (match (make-foo 42) + [(struct foo bar) ;; note the bad syntax + bar])) + 0)))) ;; raises error (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])