From ba944cf708365b5ab47eebe0bacbdd120db403f8 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 12 Jul 2006 18:59:07 +0000
Subject: [PATCH] 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

original commit: b42a11d12dbff0a32779566f00f3f612ad47a356
---
 collects/mzlib/match.ss | 89 ++++++++++++++++++++++-------------------
 1 file changed, 47 insertions(+), 42 deletions(-)

diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss
index 59c7316..f044af3 100644
--- a/collects/mzlib/match.ss
+++ b/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)
-    (syntax-case stx ()
-      [(k clause ...)
-       (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) 
-          #'(plt:match-lambda new-clauses ...))]))
   
-  (define-syntax (match-lambda* stx)
-    (syntax-case stx ()
-      [(k clause ...)
-       (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
-         #'(plt:match-lambda* new-clauses ...))]))
+  (define-syntax match-definer
+    (syntax-rules ()
+      [(match-definer name clauses ...)
+       (define-syntax (name stx)
+         (md-help syntax stx
+                  (syntax-case stx ()
+                    clauses ...)))]))
   
-  (define-syntax (match-let stx)
-    (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 ...))]))          
+  (match-definer match-lambda
+    [(k clause ...)
+     (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) 
+       #'(plt:match-lambda new-clauses ...))])
   
-  (define-syntax (match-let* stx)
-    (syntax-case stx ()
-      [(k (clauses ...) body ...)
-       (with-syntax
-           ([(new-clauses ...) (handle-clauses #'(clauses ...))])
-         #'(plt:match-let* (new-clauses ...) body ...))]))
+  (match-definer match-lambda*
+    [(k clause ...)
+     (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
+       #'(plt:match-lambda* new-clauses ...))])
   
-  (define-syntax (match stx)
-    (syntax-case stx ()
-      [(_ exp clause ...)
-       (with-syntax 
-           ([(new-clauses ...) (handle-clauses #'(clause ...))])
-         #'(plt:match exp new-clauses ...))]))
+  (match-definer match-let
+    [(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 ...))])
   
-  (define-syntax (match-letrec stx)
-    (syntax-case stx ()
-      [(k (clauses ...) body ...)
-       (with-syntax 
-           ([(new-clauses ...) (handle-clauses #'(clauses ...))])
-         #'(plt:match-letrec (new-clauses ...) body ...))]))
+  (match-definer match-let*
+    [(k (clauses ...) body ...)
+     (with-syntax
+         ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+       #'(plt:match-let* (new-clauses ...) body ...))])
+
+  (match-definer match
+    [(_ exp clause ...)
+     (with-syntax 
+         ([(new-clauses ...) (handle-clauses #'(clause ...))])
+       #'(plt:match exp new-clauses ...))])
+  
+  
+  (match-definer match-letrec
+    [(k (clauses ...) body ...)
+     (with-syntax 
+         ([(new-clauses ...) (handle-clauses #'(clauses ...))])
+       #'(plt:match-letrec (new-clauses ...) body ...))])
 
   
-  (define-syntax (match-define stx)
-    (syntax-case stx ()
-      [(k pat exp)
-       (with-syntax ([new-pat (convert-pat #'pat)])
-         #'(plt:match-define new-pat exp))]))
+  (match-definer match-define
+    [(k pat exp)
+     (with-syntax ([new-pat (convert-pat #'pat)])
+       #'(plt:match-define new-pat exp))])