From 02f88787fff3a2489420c5112ee7cce1d47e9f85 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Fri, 12 Feb 2010 16:34:38 +0000
Subject: [PATCH] Fixed pattern parsing so that the components of
 variable-except, variable-prefix, and cross patterns are treated as
 identifiers, not arbitrary patterns.

svn: r18064
---
 .../redex/private/rewrite-side-conditions.ss  | 15 ++++++++--
 collects/redex/tests/tl-test.ss               | 29 ++++++++++++++-----
 2 files changed, 34 insertions(+), 10 deletions(-)

diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss
index 7620363269..5904356edb 100644
--- a/collects/redex/private/rewrite-side-conditions.ss
+++ b/collects/redex/private/rewrite-side-conditions.ss
@@ -32,6 +32,9 @@
                           stx))
     (define (expected-arguments name stx)
       (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx))
+    (define ((expect-identifier src) stx)
+      (unless (identifier? stx)
+        (raise-syntax-error what "expected an identifier" src stx)))
     (let loop ([term orig-stx])
       (syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole side-condition cross)
         [(side-condition pre-pat (and))
@@ -56,9 +59,13 @@
                   src-loc)))))]
         [(side-condition a ...) (expected-exact 'side-condition 2 term)]
         [side-condition (expected-arguments 'side-condition term)]
-        [(variable-except a ...) #`(variable-except #,@(map loop (syntax->list (syntax (a ...)))))]
+        [(variable-except a ...)
+         (for-each (expect-identifier term) (syntax->list #'(a ...)))
+         term]
         [variable-except (expected-arguments 'variable-except term)]
-        [(variable-prefix a) #`(variable-prefix #,(loop (syntax a)))]
+        [(variable-prefix a)
+         ((expect-identifier term) #'a)
+         term]
         [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)]
         [variable-prefix (expected-arguments 'variable-prefix term)]
         [hole term]
@@ -71,7 +78,9 @@
         [(hide-hole a) #`(hide-hole #,(loop #'a))]
         [(hide-hole a ...) (expected-exact 'hide-hole 1 term)]
         [hide-hole (expected-arguments 'hide-hole term)]
-        [(cross a) #`(cross #,(loop #'a))]
+        [(cross a)
+         ((expect-identifier term) #'a)
+         term]
         [(cross a ...) (expected-exact 'cross 1 term)]
         [cross (expected-arguments 'cross term)]
         [_
diff --git a/collects/redex/tests/tl-test.ss b/collects/redex/tests/tl-test.ss
index 625a7b346e..1a9d11d01f 100644
--- a/collects/redex/tests/tl-test.ss
+++ b/collects/redex/tests/tl-test.ss
@@ -225,6 +225,14 @@
             (void)))
         "extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language")
   
+  ;; underscores in literals
+  (let ()
+    (define-language L
+      (x (variable-except a_b))
+      (y (variable-prefix a_b)))
+    (test (pair? (redex-match L x (term a_c))) #t)
+    (test (pair? (redex-match L y (term a_bc))) #t))
+  
   ;; test caching
   (let ()
     (define match? #t)
@@ -266,13 +274,20 @@
   (define-namespace-anchor here)
   (define ns (namespace-anchor->namespace here))
   
-  (let ([src 'bad-underscore])
-    (test 
-     (parameterize ([current-namespace ns])
-       (syntax-error-sources
-        '(define-language L (n m_1))
-        src))
-     (list src)))
+  (define-syntax (test-syntax-error stx)
+    (syntax-case stx ()
+      [(_ x)
+       (with-syntax ([expected (syntax/loc stx (list src))])
+         #`(let ([src (gensym)])
+             (test 
+              (parameterize ([current-namespace ns])
+                (syntax-error-sources 'x src))
+              expected)))]))
+  
+  (test-syntax-error (define-language L (n m_1)))
+  (test-syntax-error (define-language L (n (variable-except a 2 c))))
+  (test-syntax-error (define-language L (n (variable-prefix 7))))
+  (test-syntax-error (define-language L (n (cross 7))))
   
 ;                                                                                             
 ;