Add mlist patterns, and handle ...

svn: r9774

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

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))])
+    (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))))
+     (parse rest)
+     mutable?)))
 
 ;; stx : the syntax object for the whole pattern
 ;; cert : the certifier
@@ -93,9 +95,11 @@
                         [(not (car acc)) (cdr acc)]
                         [else acc])])
         (make-Struct id pred (get-lineage (cert struct-name)) acc
-                     (if (eq? '_ (syntax-e pats))
+                     (cond [(eq? '_ (syntax-e pats))                            
-                       (map make-Dummy acc)
+                            (map make-Dummy acc)]
-                       (let* ([ps (syntax->list pats)])
+                           [(syntax->list pats)
+                            =>
+                            (lambda (ps)
                               (unless (= (length ps) (length acc))
                                 (raise-syntax-error
                                  'match
@@ -104,7 +108,11 @@
                                          (syntax->datum struct-name) (length acc)
                                          (length ps))
                                  stx pats))
-                         (map parse ps))))))))
+                              (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))))

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

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)

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

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)))
    
@@ -528,6 +540,16 @@
                 (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)]) 
                 (expand (quote-syntax (match '(1 x 2 y 3 z)