From 7cc1476170e9bcdea023aa893cf32efdb29cf8c0 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 21 Sep 2011 16:40:57 -0600
Subject: [PATCH] syntax/parse: fix bug: integrated stxclass might not bind
 pvar to syntax

---
 collects/redex/private/reduction-semantics.rkt |  6 ++++--
 collects/syntax/parse/private/lib.rkt          |  4 ++--
 collects/syntax/parse/private/parse.rkt        | 12 ++++++------
 collects/tests/stxparse/test.rkt               |  8 ++++++++
 4 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index fcfca2f1d8..15377870c0 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1603,7 +1603,8 @@
     (syntax-parse body #:context full-stx
       [((~or (~seq #:mode ~! mode:mode-spec)
              (~seq #:contract ~! contract:contract-spec))
-        ... . rules:expr)
+        ...
+        rule:expr ...)
        (let-values ([(name/mode mode)
                      (syntax-parse #'(mode ...)
                        [((name . mode)) (values #'name (syntax->list #'mode))]
@@ -1618,7 +1619,8 @@
                         (raise-syntax-error 
                          syn-err-name "expected at most one contract specification"
                          #f #f (syntax->list #'dups))])])
-         (values name/mode mode name/ctc ctc (parse-rules #'rules)))]))
+         (values name/mode mode name/ctc ctc
+                 (parse-rules (syntax->list #'(rule ...)))))]))
   (check-clauses full-stx syn-err-name rules #t)
   (check-arity-consistency mode contract full-stx)
   (define-values (form-name dup-names)
diff --git a/collects/syntax/parse/private/lib.rkt b/collects/syntax/parse/private/lib.rkt
index a786959e81..79a5a33cd1 100644
--- a/collects/syntax/parse/private/lib.rkt
+++ b/collects/syntax/parse/private/lib.rkt
@@ -29,11 +29,11 @@
 
 (define-syntax-class keyword
   #:description (quote "keyword")
-  (pattern (~fail #:unless (and (syntax? this-syntax) (keyword? (syntax-e this-syntax))))))
+  (pattern (~fail #:unless (keyword? (syntax-e this-syntax)))))
 
 (define-syntax-class expr
   #:description (quote "expression")
-  (pattern (~fail #:when (and (syntax? this-syntax) (keyword? (syntax-e this-syntax))))))
+  (pattern (~fail #:when (keyword? (syntax-e this-syntax)))))
 
 ;; == Normal syntax classes ==
 
diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt
index e0fee40832..da9918d523 100644
--- a/collects/syntax/parse/private/parse.rkt
+++ b/collects/syntax/parse/private/parse.rkt
@@ -415,13 +415,13 @@ Conventions:
        [#s(pat:integrated _attrs name argu predicate description)
         (with-syntax ([(name-attr ...)
                        (if (identifier? #'name)
-                           #'([#s(attr name 0 #t) x])
+                           #'([#s(attr name 0 #t) x*])
                            #'())])
-          ;; NOTE: predicate must not assume x (ie, this-syntax) is stx
-          #'(if (app-argu predicate x argu)
-                (let-attributes (name-attr ...) k)
-                (let ([es (cons (expect:thing 'description #t) es)])
-                  (fail (failure pr es)))))])]))
+          #'(let ([x* (datum->syntax cx x cx)])
+              (if (app-argu predicate x* argu)
+                  (let-attributes (name-attr ...) k)
+                  (let ([es (cons (expect:thing 'description #t) es)])
+                    (fail (failure pr es))))))])]))
 
 ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans]
 (define-syntax (disjunct stx)
diff --git a/collects/tests/stxparse/test.rkt b/collects/tests/stxparse/test.rkt
index 3e0f325e45..40c832d012 100644
--- a/collects/tests/stxparse/test.rkt
+++ b/collects/tests/stxparse/test.rkt
@@ -387,3 +387,11 @@
      #:declare b (nat> (syntax-e #'a))
      (void)]))
 
+;; ---- Regression tests
+
+(test-case "pvar is syntax"
+  ;; from clklein 9/21/2011
+  (check-true (syntax-parse #'(m 1 1 2 1 2 3)
+                [(_ 1 ... . after-ones:expr)
+                 (syntax? #'after-ones)]))
+  (void))