From 362a6d75a52b3f60e8ce635c426d1c3b6814394b Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Fri, 15 Apr 2011 13:52:57 -0500
Subject: [PATCH] Changes redex-match to suppress ..._x bindings

---
 .../redex/private/reduction-semantics.rkt     | 26 ++++++++++---------
 collects/redex/tests/tl-test.rkt              |  4 +++
 2 files changed, 18 insertions(+), 12 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 12cc2a4af6..bf2d4fcd5e 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1053,19 +1053,19 @@
 
 (define-syntax (test-match stx)
   (syntax-case stx ()
-    [(_ lang-exp pattern)
+    [(form-name lang-exp pattern)
      (identifier? #'lang-exp)
-     (with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs 
-                                              (language-id-nts #'lang-exp 'redex-match) 
-                                              'redex-match 
-                                              #t
-                                              (syntax pattern))])
-       (syntax 
-        (do-test-match lang-exp `side-condition-rewritten)))]
-    [(_ lang-exp pattern expression)
+     (let*-values ([(what) (syntax-e #'form-name)]
+                   [(nts) (language-id-nts #'lang-exp what)]
+                   [(ids/depths _) (extract-names nts what #t #'pattern)])
+       (with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs nts what #t #'pattern)]
+                     [binders (map syntax-e ids/depths)])
+         (syntax 
+          (do-test-match lang-exp `side-condition-rewritten 'binders))))]
+    [(form-name lang-exp pattern expression)
      (identifier? #'lang-exp)
      (syntax 
-      ((test-match lang-exp pattern) expression))]
+      ((form-name lang-exp pattern) expression))]
     [(_ a b c)
      (raise-syntax-error 'redex-match "expected an identifier (bound to a language) as first argument" stx #'a)]
     [(_ a b)
@@ -1073,14 +1073,16 @@
 
 (define-struct match (bindings) #:inspector #f)
 
-(define (do-test-match lang pat)
+(define (do-test-match lang pat binders)
   (unless (compiled-lang? lang)
     (error 'redex-match "expected first argument to be a language, got ~e" lang))
   (let ([cpat (compile-pattern lang pat #t)])
     (λ (exp)
       (let ([ans (match-pattern cpat exp)])
         (and ans
-             (map (λ (m) (make-match (sort-bindings (bindings-table (mtch-bindings m)))))
+             (map (λ (m) (make-match (sort-bindings 
+                                      (filter (λ (x) (memq (bind-name x) binders))
+                                              (bindings-table (mtch-bindings m))))))
                   ans))))))
 
 (define (sort-bindings bnds)
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index 2a5a2d671a..767a4fb996 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -288,6 +288,10 @@
     ;; not a syntax error since first e is not a binder
     (test (pair? (redex-match L ((cross e) e ...) (term ((hole 2) 1)))) #t))
   
+  ;; match structures do not report ..._x bindings
+  (test (map match-bindings (redex-match grammar (a ..._1) (term (a a a))))
+        '(()))
+  
   (define-syntax (test-match stx)
     (syntax-case stx ()
       [(_ actual (((var val) ...) ...))