diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 6142238779..47d4b74377 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -1,25 +1,14 @@ ;; (documentation (name match)) ;; 
Pattern Matching Syntactic Extensions for Scheme
 ;;
-;; All bugs or questions concerning this software should be directed to
-;; Bruce Hauman .  The latest version of this software
-;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
-;;
 ;; Special thanks go out to:
 ;; Robert Bruce Findler for support and bug detection.
 ;; 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.
 ;;
-;; This software is in the public domain.  Feel free to copy,
-;; distribute, and modify this software as desired.  No warranties
-;; nor guarantees of any kind apply.  Please return any improvements
-;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
-;; in future releases.
-;;
 ;; This macro package extends Scheme with several new expression forms.
 ;; Following is a brief summary of the new forms.  See the associated
 ;; LaTeX documentation for a full description of their functionality.
@@ -128,7 +117,8 @@
    match-equality-test
    exn:misc:match?
    exn:misc:match-value
-   define-match-expander)
+   define-match-expander
+   match:test-no-order)
   
   ;; FIXME: match-helper and match-error should each be split
   ;; into a compile-time part and a run-time part.
@@ -139,7 +129,8 @@
   (require  (prefix plt: "private/match-internal-func.ss")
 	    "private/match-expander.ss"
 	    "private/match-helper.ss"
-	    "private/match-error.ss")
+	    "private/match-error.ss"
+	    "private/test-no-order.ss")
   
   (define-syntax (match-lambda stx)
     (syntax-case stx ()
diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss
index c733ac1a44..1c7ba685c4 100644
--- a/collects/mzlib/plt-match.ss
+++ b/collects/mzlib/plt-match.ss
@@ -142,12 +142,14 @@
    exn:misc:match?
    exn:misc:match-value
    match-equality-test
-   define-match-expander) 
+   define-match-expander
+   match:test-no-order) 
   
   (require "private/match-internal-func.ss"
            "private/match-expander.ss"
            "private/match-helper.ss"
-           "private/match-error.ss")
+           "private/match-error.ss"
+	   "private/test-no-order.ss")
   
   )
 
diff --git a/collects/mzlib/private/match-helper.ss b/collects/mzlib/private/match-helper.ss
index 6e7c721851..f68293d2d1 100644
--- a/collects/mzlib/private/match-helper.ss
+++ b/collects/mzlib/private/match-helper.ss
@@ -8,6 +8,8 @@
            "match-error.ss"
            (lib "list.ss"))
   
+  (require (only (lib "1.ss" "srfi") zip unzip2))
+  
   (require-for-template mzscheme)
   
   ;; define a syntax-transformer in terms of a two-argument function  
@@ -33,10 +35,10 @@
     (string->symbol (apply string-append (map data->string l))))
   
   ;;!(function struct-pred-accessors-mutators
-  ;;          (form (struct-pred-accessors-mutators struct-name failure-thunk)
+  ;;          (form (struct-pred-accessors-mutators struct-name)
   ;;                ->
   ;;                (values pred accessors mutators parental-chain))
-  ;;          (contract (syntax-object (any -> void))
+  ;;          (contract (syntax-object)
   ;;                     ->
   ;;                     (values (any -> bool) list list)))
   ;; This function takes a syntax-object that is the name of a structure
@@ -44,8 +46,8 @@
   ;; a predicate for the structure.  The second is a list of accessors
   ;; in the same order as the fields of the structure declaration.  The
   ;; third is a list of mutators for the structure also in the same
-  ;; order.  The last is a list of supertypes of this struct. The
-  ;; failure thunk is invoked if the struct-name is not bound to a
+  ;; order.  The last is a list of supertypes of this struct. An
+  ;; error is raised if the struct-name is not bound to a
   ;; structure.
   (define (struct-pred-accessors-mutators struct-name)
     (define accessors-index 3)
@@ -56,23 +58,31 @@
       (match:syntax-err struct-name 
                         "not a defined structure"))
     (define (local-val sn) (syntax-local-value sn failure-thunk))
-    (define (handle-acc-list l)
-      (reverse (filter (lambda (x) x) l)))
+    ;; accessor/mutator lists are stored in reverse order, and can contain #f
+    ;; we only filter out a mutator if the accessor is also false.
+    ;; this function returns 2 lists of the same length if the inputs were the same length
+    (define (handle-acc/mut-lists accs muts)
+      (let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (zip accs muts))]
+                    [(accs muts) (unzip2 filtered-lists)])
+        (values (reverse accs)
+                (reverse muts))))
+    
     (define (get-lineage struct-name)
       (let ([super (list-ref 
                     (local-val struct-name)
                     super-type-index)])
-        (cond [(equal? super #t) '()]
-              [(equal? super #f) '()] ;; not sure what to do in case where super-type is unknown
+        (cond [(equal? super #t) '()] ;; no super type exists
+              [(equal? super #f) '()] ;; super type is unknown
               [else (cons super (get-lineage super))])))
     (define info-on-struct (local-val struct-name))
     
     (define (get-info info-on-struct)
-      (values (handle-acc-list
-               (list-ref info-on-struct accessors-index))
-              (handle-acc-list
-               (list-ref info-on-struct mutators-index))
-              (list-ref info-on-struct pred-index)))
+      (let-values ([(accs muts)
+                    (handle-acc/mut-lists 
+                     (list-ref info-on-struct accessors-index)
+                     (list-ref info-on-struct mutators-index))])
+        (values accs muts
+                (list-ref info-on-struct pred-index))))
     
     (unless (struct-declaration-info? info-on-struct) (failure-thunk))
     
diff --git a/collects/mzlib/private/render-test-list.scm b/collects/mzlib/private/render-test-list.scm
index 62240df115..a39425f2bd 100644
--- a/collects/mzlib/private/render-test-list.scm
+++ b/collects/mzlib/private/render-test-list.scm
@@ -16,14 +16,17 @@
            "match-expander-struct.ss"
 
            ;; the following are only used by render-test-list
-           "render-helpers.ss")
+           "render-helpers.ss"
+           "test-no-order.ss")
 
   (require-for-syntax "match-helper.ss"
-                      "match-expander-struct.ss")
+                      "match-expander-struct.ss"
+                      "test-no-order.ss")
   
   (require-for-template mzscheme
 			"match-error.ss"
-			"test-no-order.ss")
+			"test-no-order.ss"
+                        "match-helper.ss")
   
    ;; BEGIN SPECIAL-GENERATORS.SCM
 
@@ -1195,7 +1198,7 @@
         "improperly formed hash table pattern"))
       
       ((struct struct-name (fields ...))
-       (identifier? (syntax struct-name))       
+       (identifier? (syntax struct-name))
        (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
                      [(num-of-fields) (length field-pats)]
                      [(pred accessors mutators parental-chain)
@@ -1217,7 +1220,8 @@
           (map-append 
              (lambda (cur-pat cur-mutator cur-accessor) 
                (syntax-case cur-pat (set! get!)
-                 [(set! . rest) 
+                 [(set! . rest)
+                  (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
                   (set/get-matcher 'set! ae stx (syntax rest)
                                    #`(lambda (y)
                                        (#,cur-mutator #,ae y)))]