From daa8507e51f9e5e7453dac09f183849f6544a1e3 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Mon, 21 Jun 2010 10:24:37 -0500
Subject: [PATCH] Fixes matcher bug

---
 collects/redex/private/matcher.rkt    |  5 +++--
 collects/redex/tests/matcher-test.rkt | 24 +++++++++++++++---------
 2 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt
index 1b60992a02..6d88b7df7f 100644
--- a/collects/redex/private/matcher.rkt
+++ b/collects/redex/private/matcher.rkt
@@ -1318,7 +1318,8 @@ before the pattern compiler is invoked.
                                       [`(,(struct mismatch-bind (name sing-exp)) ,(struct mismatch-bind (name mult-exp)))
                                        (make-mismatch-bind name (cons sing-exp mult-exp))]
                                       [else 
-                                       (error 'collapse-single-multiples "expected matches' bindings in same order; got ~e ~e"
+                                       (error 'collapse-single-multiples
+                                              "internal error: expected matches' bindings in same order; got ~e ~e"
                                               single-bindings
                                               multiple-bindings)])
                                     (bindings-table single-bindings)
@@ -1462,7 +1463,7 @@ before the pattern compiler is invoked.
                  (make-mismatch-bind name '())
                  (make-bind name '()))
              (loop pat ribs))]
-      [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))]
+      [`(in-hole ,context ,contractum) (loop contractum (loop context ribs))]
       [`(hide-hole ,p) (loop p ribs)]
       [`(side-condition ,pat ,test ,expr) (loop pat ribs)]
       [(? list?)
diff --git a/collects/redex/tests/matcher-test.rkt b/collects/redex/tests/matcher-test.rkt
index 640f6b20d8..b03703c25d 100644
--- a/collects/redex/tests/matcher-test.rkt
+++ b/collects/redex/tests/matcher-test.rkt
@@ -136,7 +136,7 @@
                    `(,(make-repeat '(name x (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
     (test-ellipses '((in-hole (name x a) (name y b)) ...)
                    `(,(make-repeat '(in-hole (name x a) (name y b)) 
-                                   (list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
+                                   (list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
     
     (test-ellipses '(a ..._1)
                    `(,(make-repeat 'a (list) '..._1 #f)))
@@ -625,10 +625,11 @@
                   "compile-pattern"
                   equal?)
     
-    (test-ellipsis-binding '((number_1 number_2) ...) '((1 2)))
-    (test-ellipsis-binding '((name x number_1) ...) '(1 2))
-    (test-ellipsis-binding '(((number_1 ...) (number_2 ...)) ...) '(((1) (2))))
-    (test-ellipsis-binding '(number ... variable) '(1 x))
+    (test-ellipsis-binding '((number_1 number_2) ...) '() '((1 2)))
+    (test-ellipsis-binding '((name x number_1) ...) '() '(1 2))
+    (test-ellipsis-binding '(((number_1 ...) (number_2 ...)) ...) '() '(((1) (2))))
+    (test-ellipsis-binding '(number ... variable) '() '(1 x))
+    (test-ellipsis-binding '((in-hole H_1 number_1) ...) '((H hole)) '(1 2))
     
     (cond
       [(= failures 0)
@@ -660,10 +661,14 @@
       exp)
      ans))
   
+  ;; make-nt-map : (listof nt) -> (listof (listof symbol))
+  (define (make-nt-map nts)
+    (map (λ (x) (list (nt-name x))) nts))
+  
   ;; test-lang : sexp[pattern] sexp[term] answer (list/c nt) -> void
   ;; returns #t if pat matching exp with the language defined by the given nts
   (define (test-lang pat exp ans nts)
-    (let ([nt-map (map (λ (x) (list (nt-name x))) nts)])
+    (let ([nt-map (make-nt-map nts)])
       (run-match-test
        `(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used ',nts ',nt-map) ',pat #t) ',exp)
        (match-pattern 
@@ -751,10 +756,10 @@
   (define (test-suite:non-underscore-binder? x)
     (memq x '(number any variable string)))
   
-  ;; test-ellipsis-binding: sexp sexp -> boolean
+  ;; test-ellipsis-binding: sexp sexp sexp -> boolean
   ;; Checks that `extract-empty-bindings' produces bindings in the same order
   ;; as the matcher, as required by `collapse-single-multiples'
-  (define (test-ellipsis-binding pat exp)
+  (define (test-ellipsis-binding pat nts/sexp exp)
     (define (binding-names bindings)
       (map (λ (b)
              (cond [(bind? b) (bind-name b)]
@@ -767,7 +772,8 @@
        (mtch-bindings
         (car 
          ((compiled-pattern-cp
-           (compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t))
+           (let ([nts (map (λ (nt-def) (nt (car nt-def) (map rhs (cdr nt-def)))) nts/sexp)])
+             (compile-pattern (compile-language 'pict-stuff-not-used nts (make-nt-map nts)) pat #t)))
           exp
           #t)))))
      (binding-names (extract-empty-bindings test-suite:non-underscore-binder? pat))))