From 1c654c35d2e75605871b19163aa94ffe18618923 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Thu, 4 Sep 2008 19:30:45 +0000
Subject: [PATCH] Fixed bug in may-be-non-list-pattern?/internal and stored
 compatible context language in compiled-lang, for use in term generator.

svn: r11537
---
 collects/redex/private/matcher-test.ss | 13 ++++++++++++
 collects/redex/private/matcher.ss      | 28 ++++++++++++++------------
 2 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss
index a2a559e448..9e3b8fcab5 100644
--- a/collects/redex/private/matcher-test.ss
+++ b/collects/redex/private/matcher-test.ss
@@ -42,6 +42,8 @@
     (test-empty '(variable-except x) 1 #f)
     (test-empty '(variable-except x) 'x #f)
     (test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none)))
+    (test-lang 'x 'y (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none))
+               (list (make-nt 'x (list (make-rhs '(variable-except x) '())))))
     (test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none)))
     (test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none)))
     (test-empty '(variable-prefix x:) ': #f)
@@ -616,6 +618,17 @@
       exp)
      ans))
   
+  ;; 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)])
+      (run-match-test
+       `(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used ',nts ',nt-map) ',pat #t) ',exp)
+       (match-pattern 
+        (compile-pattern (compile-language 'pict-stuff-not-used nts nt-map) pat #t)
+        exp)
+       ans)))
+  
   (define xab-lang #f)
   ;; test-xab : sexp[pattern] sexp[term] answer -> void
   ;; returns #t if pat matching exp with a simple language produces ans.
diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss
index 1baa605a5f..a94cda1004 100644
--- a/collects/redex/private/matcher.ss
+++ b/collects/redex/private/matcher.ss
@@ -90,9 +90,9 @@ before the pattern compiler is invoked.
   ;;               #f means we're not in a `in-hole' context
   ;;               none means we're looking for a hole
   
-  (define-struct compiled-lang (lang ht list-ht across-ht across-list-ht has-hole-ht
-                                     cache bind-names-cache pict-builder literals
-                                     nt-map))
+  (define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht
+                                     has-hole-ht cache bind-names-cache pict-builder
+                                     literals nt-map))
   
   ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
   (define (lookup-binding bindings
@@ -118,7 +118,7 @@ before the pattern compiler is invoked.
            [cache (make-hash)]
            [bind-names-cache (make-hash)]
            [literals (extract-literals lang)]
-           [clang (make-compiled-lang lang clang-ht clang-list-ht 
+           [clang (make-compiled-lang lang #f clang-ht clang-list-ht 
                                       across-ht across-list-ht
                                       has-hole-ht 
                                       cache bind-names-cache
@@ -140,13 +140,15 @@ before the pattern compiler is invoked.
                                (hash-set!
                                 ht
                                 (nt-name nt)
-                                (cons compiled-pattern (hash-ref ht (nt-name nt)))))])
-                        (when (may-be-non-list-pattern? (rhs-pattern rhs)
-                                                        non-list-nt-table)
-                          (add-to-ht ht))
-                        (when (may-be-list-pattern? (rhs-pattern rhs) 
-                                                    list-nt-table)
-                          (add-to-ht list-ht)))))
+                                (cons compiled-pattern (hash-ref ht (nt-name nt)))))]
+                            [may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table)]
+                            [may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table)])
+                        (when may-be-non-list? (add-to-ht ht))
+                        (when may-be-list? (add-to-ht list-ht))
+                        (unless (or may-be-non-list? may-be-list?)
+                          (error 'compile-language 
+                                 "unable to determine whether pattern matches lists, non-lists, or both: ~s"
+                                 (rhs-pattern rhs))))))
                   (nt-rhs nt)))
                lang))]
            [init-ht
@@ -171,7 +173,7 @@ before the pattern compiler is invoked.
                   compatible-context-language)
         (do-compilation clang-ht clang-list-ht lang #t)
         (do-compilation across-ht across-list-ht compatible-context-language #f)
-        clang)))
+        (struct-copy compiled-lang clang [cclang compatible-context-language]))))
   
   ;; extract-literals : (listof nt) -> (listof symbol)
   (define (extract-literals nts)
@@ -495,7 +497,7 @@ before the pattern compiler is invoked.
       [`number #t]
       [`string #t]
       [`variable #t] 
-      [`(variable-except vars ...) #t]
+      [`(variable-except ,vars ...) #t]
       [`variable-not-otherwise-mentioned #t]
       [`(variable-prefix ,prefix) #t]
       [`hole #t]