match.ss: abstract some boilerplate, and use syntax/loc when doing conversion to plt-match

match-helper.ss: add helper macro

render-test-list-impl.ss: fix hygiene bug in checking for non-linear patters
			  (thanks to Ryan Culpepper)

gen-match.ss: Fix error reporting location in match errors.
	      (thanks to Ryan Culpepper)

svn: r3689

collects/mzlib/match.ss

@@ -125,61 +125,66 @@
   (require-for-syntax "private/convert-pat.ss"
                       "private/match-helper.ss")
   
+  (require-for-template mzscheme)
+  
   (require  (prefix plt: "private/match-internal-func.ss")
 	    "private/match-expander.ss"
 	    "private/match-helper.ss"
 	    "private/match-error.ss"
 	    "private/test-no-order.ss")
   
-  (define-syntax (match-lambda stx)
+  
+  (define-syntax match-definer
+    (syntax-rules ()
+      [(match-definer name clauses ...)
+       (define-syntax (name stx)
+         (md-help syntax stx
                   (syntax-case stx ()
+                    clauses ...)))]))
+  
+  (match-definer match-lambda
     [(k clause ...)
      (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) 
-          #'(plt:match-lambda new-clauses ...))]))
+       #'(plt:match-lambda new-clauses ...))])
   
-  (define-syntax (match-lambda* stx)
+  (match-definer match-lambda*
-    (syntax-case stx ()
     [(k clause ...)
      (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
-         #'(plt:match-lambda* new-clauses ...))]))
+       #'(plt:match-lambda* new-clauses ...))])
   
-  (define-syntax (match-let stx)
+  (match-definer match-let
-    (syntax-case stx ()
     [(k name (clauses ...) body ...)
      (identifier? (syntax name))
      (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
        #'(plt:match-let name (new-clauses ...) body ...))]          
     [(k (clauses ...) body ...)
      (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
-          #'(plt:match-let (new-clauses ...) body ...))]))          
+       #'(plt:match-let (new-clauses ...) body ...))])
   
-  (define-syntax (match-let* stx)
+  (match-definer match-let*
-    (syntax-case stx ()
     [(k (clauses ...) body ...)
      (with-syntax
          ([(new-clauses ...) (handle-clauses #'(clauses ...))])
-         #'(plt:match-let* (new-clauses ...) body ...))]))
+       #'(plt:match-let* (new-clauses ...) body ...))])
 
-  (define-syntax (match stx)
+  (match-definer match
-    (syntax-case stx ()
     [(_ exp clause ...)
      (with-syntax 
          ([(new-clauses ...) (handle-clauses #'(clause ...))])
-         #'(plt:match exp new-clauses ...))]))
+       #'(plt:match exp new-clauses ...))])
   
-  (define-syntax (match-letrec stx)
+  
-    (syntax-case stx ()
+  (match-definer match-letrec
     [(k (clauses ...) body ...)
      (with-syntax 
          ([(new-clauses ...) (handle-clauses #'(clauses ...))])
-         #'(plt:match-letrec (new-clauses ...) body ...))]))
+       #'(plt:match-letrec (new-clauses ...) body ...))])
 
   
-  (define-syntax (match-define stx)
+  (match-definer match-define
-    (syntax-case stx ()
     [(k pat exp)
      (with-syntax ([new-pat (convert-pat #'pat)])
-         #'(plt:match-define new-pat exp))]))
+       #'(plt:match-define new-pat exp))])
   
   
   

collects/mzlib/private/convert-pat.ss

@@ -13,7 +13,7 @@
     
   (define (handle-clause stx)
     (syntax-case stx ()
-      [(pat . rest) #`(#,(convert-pat (syntax pat)) . rest)]))
+      [(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))]))
   
   (define (handle-clauses stx) (syntax-map handle-clause stx))
   

collects/mzlib/private/gen-match.ss

@@ -169,7 +169,7 @@
           (match:syntax-err stx "null clause list"))
         (let* ([marked-clauses (mark-patlist patlist)]
                [compiled-match
-                #`(let ([match-failure (lambda () (match:error #,exp '#,stx))])
+                #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
                     #,(gen exp tsf marked-clauses
                            stx
                            #'(match-failure)

collects/mzlib/private/match-helper.ss

@@ -18,6 +18,14 @@
       [(_ nm func)
        (define-syntax (nm stx) (func stx stx))]))
   
+  ;; bind an identifier to be syntax/loc with a particular location, in an expression
+  (define-syntax md-help
+    (syntax-rules ()
+      [(md-help id stx e)
+       (let-syntax ([id (syntax-rules () [(id arg) (syntax/loc stx arg)])])
+         e)]))
+  
+  
   
   ;;!(function symbol-append
   ;;          (form (symbol-append . args) -> symbol)

collects/mzlib/private/render-test-list-impl.ss

@@ -180,8 +180,10 @@
                            (lambda (ks kf let-bound)
                              (lambda (sf bv)                           
                                (cond [(ormap (lambda (x)
-                                               (if (stx-equal? #'pt (car x))
+                                               (if (bound-identifier=? #'pt (car x))
-                                                   (cdr x) #f)) bv)
+                                                   (cdr x) 
+                                                   #f)) 
+                                             bv)
                                       => (lambda (bound-exp)
                                            (emit (lambda (exp)
                                                    #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound)))