From e1e2e7e5da54c1518c5831dc33698cc9862f55de Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 1 Oct 2014 00:04:42 -0400
Subject: [PATCH] syntax/parse: conventions have lowest priority

---
 .../syntax/parse/private/rep-data.rkt         | 15 ++++++----
 racket/collects/syntax/parse/private/rep.rkt  | 30 ++++++++++++-------
 2 files changed, 28 insertions(+), 17 deletions(-)

diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt
index c79a3d60c4..6fabc47a0d 100644
--- a/racket/collects/syntax/parse/private/rep-data.rkt
+++ b/racket/collects/syntax/parse/private/rep-data.rkt
@@ -120,16 +120,17 @@ expressions are duplicated, and may be evaluated in different scopes.
                     (bound-id-table-set table id literal)))])
     (make-declenv table conventions)))
 
-(define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
-  (or (bound-id-table-ref (declenv-table env) id #f)
-      (and use-conventions?
-           (conventions-lookup (declenv-conventions env) id))))
+(define (declenv-lookup env id)
+  (bound-id-table-ref (declenv-table env) id #f))
+
+(define (declenv-apply-conventions env id)
+  (conventions-lookup (declenv-conventions env) id))
 
 (define (declenv-check-unbound env id [stxclass-name #f]
                                #:blame-declare? [blame-declare? #f])
   ;; Order goes: literals, pattern, declares
   ;; So blame-declare? only applies to stxclass declares
-  (let ([val (declenv-lookup env id #:use-conventions? #f)])
+  (let ([val (declenv-lookup env id)])
     (match val
       [(den:lit _i _e _ip _lp)
        (wrong-syntax id "identifier previously declared as literal")]
@@ -229,7 +230,9 @@ expressions are duplicated, and may be evaluated in different scopes.
        [#:conventions list?]
        DeclEnv/c)]
  [declenv-lookup
-  (->* [DeclEnv/c identifier?] [#:use-conventions? any/c] any)]
+  (-> DeclEnv/c identifier? any)]
+ [declenv-apply-conventions
+  (-> DeclEnv/c identifier? any)]
  [declenv-put-stxclass
   (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f)
       DeclEnv/c)]
diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt
index 252fe3b3cf..b10c93a998 100644
--- a/racket/collects/syntax/parse/private/rep.rkt
+++ b/racket/collects/syntax/parse/private/rep.rkt
@@ -439,11 +439,11 @@
   ;; Conventions to not shadow pattern-form bindings, under the
   ;; theory that conventions only apply to things already determined
   ;; to be pattern variables.
-  (not (declenv-lookup decls id #:use-conventions? #f)))
+  (not (declenv-lookup decls id)))
 ;; suitable as id=? argument to syntax-case*
 (define ((make-not-shadowed-id=? decls) lit-id pat-id)
   (and (free-identifier=? lit-id pat-id)
-       (not (declenv-lookup decls pat-id #:use-conventions? #f))))
+       (not (declenv-lookup decls pat-id))))
 
 ;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern
 (define (parse-*-pattern stx decls allow-head? allow-action?)
@@ -681,7 +681,21 @@
                                  "not allowed within ~~not pattern"))))
 
 (define (parse-pat:id id decls allow-head?)
-  (define entry (declenv-lookup decls id))
+  (cond [(declenv-lookup decls id)
+         => (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))]
+        [(not (safe-name? id))
+         (wrong-syntax id "expected identifier not starting with ~~ character")]
+        [else
+         (let-values ([(name sc) (split-id/get-stxclass id decls)])
+           (cond [sc
+                  (parse-pat:var* id allow-head? name sc no-arguments "." #f #f)]
+                 [(declenv-apply-conventions decls id)
+                  => (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))]
+                 [else (create-pat:var name #f no-arguments null #f #t #f)]))]))
+
+;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern
+;; Handle when meaning of identifier pattern is given by declenv entry.
+(define (parse-pat:id/entry id decls allow-head? entry)
   (match entry
     [(den:lit internal literal input-phase lit-phase)
      (create-pat:literal literal input-phase lit-phase)]
@@ -706,14 +720,8 @@
             (parse-pat:id/s id parser no-arguments attrs commit? "." #f)])]
     [(den:delayed parser class)
      (let ([sc (get-stxclass class)])
-       (parse-pat:var* id allow-head? id sc no-arguments "." #f parser))]
-    ['#f
-     (unless (safe-name? id)
-       (wrong-syntax id "expected identifier not starting with ~~ character"))
-     (let-values ([(name sc) (split-id/get-stxclass id decls)])
-       (if sc
-           (parse-pat:var* id allow-head? name sc no-arguments "." #f #f)
-           (create-pat:var name #f no-arguments null #f #t #f)))]))
+       (parse-pat:var* id allow-head? id sc no-arguments "." #f parser))]))
+
 
 (define (parse-pat:var stx decls allow-head?)
   (define name0