syntax/parse: changed #:declare back to "magical" scoping

collects/syntax/parse/private/rep-data.rkt

@@ -109,15 +109,26 @@ DeclEnv =
 DeclEntry =
   (den:lit id id ct-phase ct-phase)
   (den:class id id Arguments)
+  (den:magic-class id id Arguments)
   (den:parser id (listof SAttr) bool bool bool)
   (den:delayed id id)
 
 Arguments is defined in rep-patterns.rkt
+
+== Scoping ==
+
+A #:declare directive results in a den:magic-class entry, which
+indicates that the pattern variable's syntax class arguments (if any)
+have "magical scoping": they are evaluated in the scope where the
+pattern variable occurs. If the variable occurs multiple times, the
+expressions are duplicated, and may be evaluated in different scopes.
 |#
+
 (define-struct declenv (table conventions))
 
 (define-struct den:lit (internal external input-phase lit-phase))
 (define-struct den:class (name class argu))
+(define-struct den:magic-class (name class argu))
 (define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
 (define-struct den:delayed (parser class))
 
@@ -143,6 +154,13 @@ Arguments is defined in rep-patterns.rkt
     (match val
       [(struct den:lit (_i _e _ip _lp))
        (wrong-syntax id "identifier previously declared as literal")]
+      [(struct den:magic-class (name _c _a))
+       (if (and blame-declare? stxclass-name)
+           (wrong-syntax name
+                         "identifier previously declared with syntax class ~a"
+                         stxclass-name)
+           (wrong-syntax (if blame-declare? name id)
+                         "identifier previously declared"))]
       [(struct den:class (name _c _a))
        (if (and blame-declare? stxclass-name)
            (wrong-syntax name
@@ -158,7 +176,7 @@ Arguments is defined in rep-patterns.rkt
   (declenv-check-unbound env id)
   (make-declenv
    (bound-id-table-set (declenv-table env) id
-                       (make den:class id stxclass-name argu))
+                       (make den:magic-class id stxclass-name argu))
    (declenv-conventions env)))
 
 ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
@@ -182,7 +200,7 @@ Arguments is defined in rep-patterns.rkt
   (define idbm (make-bound-id-table))
   (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t))
   (for/list ([(k v) (in-dict (declenv-table env))]
-             #:when (or (den:class? v) (den:parser? v))
+             #:when (or (den:class? v) (den:magic-class? v) (den:parser? v))
              #:when (not (bound-id-table-ref idbm k #f)))
     k))
 
@@ -198,7 +216,7 @@ Arguments is defined in rep-patterns.rkt
 (define DeclEnv/c declenv?)
 
 (define DeclEntry/c 
-  (or/c den:lit? den:class? den:parser? den:delayed?))
+  (or/c den:lit? den:class? den:magic-class? den:parser? den:delayed?))
 
 (define SideClause/c
   (or/c clause:fail? clause:with? clause:attr? clause:do?))
@@ -209,6 +227,7 @@ Arguments is defined in rep-patterns.rkt
 
 (provide (struct-out den:lit)
          (struct-out den:class)
+         (struct-out den:magic-class)
          (struct-out den:parser)
          (struct-out den:delayed))
 

collects/syntax/parse/private/rep.rkt

@@ -51,21 +51,9 @@
   (-> syntax?
       #:context syntax?
       arity?)]
- #|
- [check-literals-list
-  ;; NEEDS txlift context
-  (-> syntax? syntax?
-      (listof (list/c identifier? identifier? ct-phase/c ct-phase/c)))]
- |#
  [check-literals-list/litset
   (-> syntax? syntax?
       (listof (list/c identifier? identifier?)))]
- #|
- [check-literal-sets-list
-  ;; NEEDS txlift context
-  (-> syntax? syntax?
-      (listof (listof (list/c identifier? identifier? ct-phase/c))))]
- |#
  [check-conventions-rules
   (-> syntax? syntax?
       (listof (list/c regexp? any/c)))]
@@ -73,6 +61,8 @@
   (-> syntax? syntax?
       (listof sattr?))])
 
+;; ----
+
 (define (atomic-datum? stx)
   (let ([datum (syntax-e stx)])
     (or (null? datum)
@@ -320,6 +310,8 @@ A syntax class is integrable if
   (match entry
     [(struct den:lit (_i _e _ip _lp))
      (values entry null)]
+    [(struct den:magic-class (name class argu))
+     (values entry null)]
     [(struct den:class (name class argu))
      ;; FIXME: integrable syntax classes?
      (cond [(identifier? name)
@@ -667,6 +659,22 @@ A syntax class is integrable if
   (match entry
     [(struct den:lit (internal literal input-phase lit-phase))
      (create-pat:literal literal input-phase lit-phase)]
+    [(struct den:magic-class (name class argu))
+     (let* ([pos-count (length (arguments-pargs argu))]
+            [kws (arguments-kws argu)]
+            [sc (get-stxclass/check-arity class class pos-count kws)]
+            [splicing? (stxclass-splicing? sc)]
+            [attrs (stxclass-attrs sc)]
+            [parser (stxclass-parser sc)]
+            [commit? (stxclass-commit? sc)]
+            [delimit-cut? (stxclass-delimit-cut? sc)])
+       (check-no-delimit-cut-in-not id delimit-cut?)
+       (if splicing?
+           (begin
+             (unless allow-head?
+               (wrong-syntax id "splicing syntax class not allowed here"))
+             (parse-pat:id/h id parser argu attrs commit?))
+           (parse-pat:id/s id parser argu attrs commit?)))]
     [(struct den:class (_n _c _a))
      (error 'parse-pat:id
             "(internal error) decls had leftover stxclass entry: ~s"

collects/tests/stxparse/test.rkt

@@ -369,3 +369,21 @@
       (m zero)))
    0)
   (void))
+
+
+;; -- test #:declare scoping
+
+(test-case "#:declare magical scoping"
+  (syntax-parse #'(1 2)
+    [(a b)
+     #:declare a nat
+     #:declare b (nat> (syntax-e #'a))
+     (void)]))
+
+(tcerr "#:declare magical scoping 2"
+  (syntax-parse #'(1 1)
+    [(a b)
+     #:declare a nat
+     #:declare b (nat> (syntax-e #'a))
+     (void)]))
+