.

original commit: 7189a486ea256050be0d0c36be4385e5656fb0e5

collects/mzlib/match.ss

@@ -125,6 +125,7 @@
    match-let*
    match-letrec
    match-define
+   match-test
    )
 
   (require-for-syntax (lib "stx.ss" "syntax")
@@ -159,6 +160,8 @@
                       match-let*
                       match-letrec
                       match-define
+                      match-test
+                      m:match-test
                       m:match
                       m:match-letrec
                       m:match-define
@@ -312,6 +315,35 @@
                      #,@(map handle-clause 
                              (syntax-e (syntax (clause ...))))))))))
 
+(define m:match-test/proc 
+      (lambda (stx)
+        (syntax-case stx (=>)
+          ((_ clause ...)
+           (begin
+             (set! node-count 0)
+              (let-values (((stx t rt gc) (time-apply gen-match 
+                                   (list (syntax x)
+                                         '()
+                                         (syntax (clause ...))
+                                         stx))))
+                #`(list ; (let ((dat-struct (seconds->date (current-seconds))))
+                        ;         (list (date-month dat-struct)
+                        ;              (date-day dat-struct)
+                        ;           (date-year dat-struct)));
+                        ;           (list #,@(get-date)) 
+                        #,node-count
+                        #,rt)))))))
+
+ (define match-test/proc
+      (lambda (stx)
+        (syntax-case stx ()
+          ((_ clause ...)
+           (quasisyntax/loc 
+            stx 
+            (m:match-test  
+                     #,@(map handle-clause 
+                             (syntax-e (syntax (clause ...))))))))))
+
     (define match-letrec/proc
       (lambda (stx)
         (syntax-case stx ()
@@ -377,10 +409,9 @@
                     not
                     $
                     set!
-                    var
                     get!
-                    unquote
-                    unquote-splicing
+                    ;unquote
+                    ;unquote-splicing
                     )))
         (let/ec out
           (let loop ((x x))
@@ -415,6 +446,7 @@
            (quasisyntax/loc 
             stx #,(box (convert-quasi (unbox (syntax-e stx))))))
           (pat stx)))
+      ;(write (syntax-object->datum stx))(newline)
       (syntax-case* 
        stx
        (_ ? = and or not $ set! get! quasiquote 

collects/mzlib/plt-match.ss

@@ -7,9 +7,10 @@
 ;;
 ;; Special thanks go out to:
 ;; Robert Bruce Findler for support and bug detection.
+;; Scott Owens for the new constructor grammer.
 ;; Doug Orleans for pointing out that pairs should be reused while
 ;; matching lists.
-;;
+;; 
 ;;
 ;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
 ;; which in turn was adapted from code written by Bruce F. Duba, 1991.
@@ -52,6 +53,7 @@
 ;;       | character                       a character
 ;;       | 'sexp                           an s-expression
 ;;       | 'symbol                         a symbol (special case of s-expr)
+;;       | (var id)                        allows one to use ..k or _ as identifiers
 ;;       | (list lvp_1 ... lvp_n)               list of n elements
 ;;       | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements
 ;;                                         plus a last element which represents
@@ -110,15 +112,12 @@
 ;;                                           of remainder must match qp_n+1
 ;;       | #&qp                            box
 ;;       | ,pat                            a pattern
-;;       | ,@(lvp . . . lvp-n)
-;;       | ,@(lvp-1 . . . lvp-n . pat)
+;;       | ,@(list lvp . . . lvp-n)
+;;       | ,@(list-rest lvp-1 . . . lvp-n pat)
 ;;       | ,@`qp                           qp must evaluate to a list as 
 ;;                                         so that this rule resembles the 
 ;;                                         above two rules
 ;;
-;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
-;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___) 
-;; cannot be used as pattern variables.</pre>
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -132,13 +131,11 @@
    match-let*
    match-letrec
    match-define
-   match-count
    match:test-no-order
    ) 
   
   (require-for-syntax (lib "stx.ss" "syntax")
                       (lib "etc.ss")
-                      ;(lib "pretty.ss")
                       (lib "list.ss")
                       (lib "include.ss"))
   
@@ -169,32 +166,12 @@
                       match-let*
                       match-letrec
                       match-define
-                      match-count
                       )
 
     (include "private/plt-match/match-inc.scm")    
 
     (define node-count 0)
 
-    ;;!(syntax match-count)
-    ;; This macro only returns a number.  This number represents the
-    ;; number of nodes generated in the process of compiling the match 
-    ;; expresseion.  This gives one and idea as to the size of the 
-    ;; compiled expression.  This is mostly used for testing.
-    (define match-count/proc 
-      (lambda (stx)
-        (syntax-case stx (=>)
-          ((_ exp clause ...)
-           (begin
-             (set! node-count 0)
-             (quasisyntax/loc 
-              stx 
-              (let ((x exp)) #,(gen-match (syntax x)
-                                        '()
-                                        (syntax (clause ...))
-                                        stx)))
-             #`#,node-count)))))
-
     (define match/proc 
       (lambda (stx)
         (syntax-case stx (=>)

collects/tests/mzscheme/unit.ss

@@ -183,7 +183,7 @@
    (import struct:a a?)
    (export x? make-x x-z both)
    
-   (define-syntax a (list #'struct:a #f #'a? (list #f) (list #f)))
+   (define-syntax a (list #'struct:a #f #'a? (list #f) (list #f) #f))
 
    (define-struct (x a) (y z))
    (define both (lambda (v)

collects/tests/mzscheme/unitsig.ss

@@ -274,7 +274,7 @@
    m2-2^
    (import m2-1^)
 
-   (define-syntax a (list #'struct:a #f #f (list #f) (list #f)))
+   (define-syntax a (list #'struct:a #f #f (list #f) (list #f) #f))
 
    (define-struct (x a) (y z))
    (define both (lambda (v)