added current-pvars+unique

current-pvars.rkt

@@ -1,5 +1,6 @@
 (module current-pvars '#%kernel
-  (#%provide (for-syntax current-pvars)
+  (#%provide (for-syntax current-pvars
+                         current-pvars+unique)
              with-pvars
              define-pvars)
   
@@ -40,6 +41,11 @@
   (define-syntaxes (current-pvars-param0) '())
 
   (begin-for-syntax
+    ;; (-> any/c (or/c (listof syntax?) #f))
+    (define-values (syntax*->list)
+      (λ (stxlist)
+        (syntax->list (datum->syntax #f stxlist))))
+    
     ;; (-> identifier? (or/c #f (listof identifier?)))
     (define-values (try-current-pvars)
       (λ (id)
@@ -110,6 +116,10 @@
 
     ;; (-> (listof identifier?))
     (define-values (current-pvars)
+      (λ ()
+        (map car (try-nth-current-pvars (find-last-current-pvars)))))
+
+    (define-values (current-pvars+unique)
       (λ ()
         (try-nth-current-pvars (find-last-current-pvars)))))
 
@@ -119,13 +129,18 @@
       (if (not (and (stx-pair? stx)
                     (identifier? (stx-car stx))
                     (stx-pair? (stx-cdr stx))
-                    (syntax->list (stx-car (stx-cdr stx)))
+                    (syntax*->list (stx-car (stx-cdr stx)))
                     (andmap identifier?
-                            (syntax->list (stx-car (stx-cdr stx))))))
+                            (syntax*->list (stx-car (stx-cdr stx))))))
           (raise-syntax-error 'with-pvars "bad syntax" stx)
           (void))
-      (let* ([pvars (syntax->list (stx-car (stx-cdr stx)))]
-             [quoted-pvars (reverse (map (λ (v) `(quote-syntax ,v)) pvars))]
+      (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
+             [unique-at-runtime (map gensym (map syntax-e pvars))]
+             [stxquoted-pvars (map (λ (v unique)
+                                     `(cons (quote-syntax ,v)
+                                            (quote-syntax ,unique)))
+                                   pvars
+                                   unique-at-runtime)]
              [body (stx-cdr (stx-cdr stx))]
              [old-pvars-index (find-last-current-pvars)]
              [old-pvars (try-nth-current-pvars old-pvars-index)]
@@ -134,26 +149,31 @@
              [lower-bound-binding
               (syntax-local-identifier-as-binding
                (syntax-local-introduce
-                (quote-syntax current-pvars-index-lower-bound)))])
+                (quote-syntax current-pvars-index-lower-bound)))]
+             [do-unique-at-runtime (map (λ (id pvar)
+                                          `[(,id) (gensym (quote ,pvar))])
+                                        unique-at-runtime
+                                        pvars)])
         (datum->syntax
          (quote-syntax here)
-         `(letrec-syntaxes+values
-              ([(,binding) (list* ,@quoted-pvars
-                                  (try-nth-current-pvars ,old-pvars-index))]
-               [(,lower-bound-binding) ,(+ old-pvars-index 1)])
-              ()
-            . ,body)))))
+         `(let-values (,@do-unique-at-runtime)
+            (letrec-syntaxes+values
+                ([(,binding) (list* ,@stxquoted-pvars
+                                    (try-nth-current-pvars ,old-pvars-index))]
+                 [(,lower-bound-binding) ,(+ old-pvars-index 1)])
+                ()
+              . ,body))))))
 
   (define-syntaxes (define-pvars)
     (lambda (stx)
       (if (not (and (stx-pair? stx)
                     (identifier? (stx-car stx))
-                    (syntax->list (stx-cdr stx))
+                    (syntax*->list (stx-cdr stx))
                     (andmap identifier?
-                            (syntax->list (stx-cdr stx)))))
+                            (syntax*->list (stx-cdr stx)))))
           (raise-syntax-error 'with-pvars "bad syntax" stx)
           (void))
-      (let* ([pvars (syntax->list (stx-cdr stx))]
+      (let* ([pvars (syntax*->list (stx-cdr stx))]
              [quoted-pvars (reverse (map (λ (v) `(quote-syntax ,v)) pvars))]
              [old-pvars-index (find-last-current-pvars)]
              [old-pvars (try-nth-current-pvars old-pvars-index)]

scribblings/stxparse-info.scrbl

@@ -26,11 +26,11 @@ and the @racket[syntax-case] family. These patched versions track which syntax
 pattern variables are bound. This allows some libraries to change the way
 syntax pattern variables work.
 
-For example, @racketmodname[phc-graph/subtemplate] automatically derives
-temporary identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ]
-is a pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …]
-identifiers must be derived, @racketmodname[phc-graph/subtemplate] needs to
-know which syntax pattern variables are within scope.
+For example, @racketmodname[subtemplate] automatically derives temporary
+identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a
+pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …]
+identifiers must be derived, @racketmodname[subtemplate] needs to know which
+syntax pattern variables are within scope.
 
 @section{Tracking currently-bound pattern variables with @racket[syntax-parse]}
 
@@ -64,6 +64,70 @@ track which syntax or datum pattern variables are bound.
  @racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows
  libraries to also track variables bound by match-like forms, for example.}
 
+@defproc[#:kind "procedure at phase 1"
+         (current-pvars+unique) (listof (pairof identifier? identifier?))]{
+ This for-syntax procedure works like @racket[current-pvars], but associates
+ each syntax pattern variable with an identifier containing a unique symbol
+ which is generated at each execution of the code recording the pattern
+ variable via @racket[with-pvars] or @racket[define-pvars].
+
+ The @racket[car] of each pair in the returned list is the syntax pattern
+ variable (as produced by @racket[current-pvars]). It is the responsibility of
+ the reader to check that the identifiers present in the @racket[car] of each
+ element of the returned list are bound, and that they are bound to syntax
+ pattern variables, for example using @racket[identifier-binding] and
+ @racket[syntax-pattern-variable?]. This allows libraries to also track
+ variables bound by match-like forms, for example.
+
+ The @racket[cdr] of each pair is the identifier of a temporary variable.
+ Reading that temporary variable produces a @racket[gensym]-ed symbol, which
+ was generated at run-time at the point where @racket[with-pvars] or
+ @racket[define-pvars] was used to record the corresponding pattern variable.
+
+ This can be used to associate run-time data with each syntax pattern
+ variable, via a weak hash table created with @racket[make-weak-hasheq]. For
+ example, the @racketmodname[subtemplate] library implicitly derives
+ identifiers (similarly to @racket[generate-temporaries]) for uses of
+ @racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same
+ subscript. The generated identifiers are associated with @racket[xᵢ] via this
+ weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the
+ scope of the same @racket[xᵢ] binding derive the same identifiers.
+
+ The code @racket[(with-pvars (v) body)] roughly expands to:
+
+ @racketblock[
+ (let-values ([(tmp) (gensym 'v)])
+   (letrec-syntaxes+values ([(shadow-current-pvars)
+                             (list* (cons (quote-syntax v)
+                                          (quote-syntax tmp))
+                                    old-current-pvars)])
+     body))]
+
+ @bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is
+ generated when @racket[with-pvars] or @racket[define-pvars] is called, not
+ when the syntax pattern variable is actually bound. For example:
+
+ @RACKETBLOCK[
+ (define-syntax (get-current-pvars+unique stx)
+   #`'#,(current-pvars+unique))
+              
+ (require racket/private/sc)
+ (let ([my-valvar (quote-syntax x)])
+   (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
+     (with-pvars (x)
+       (get-current-pvars+unique)) (code:comment '([x . g123]))
+     (with-pvars (x)
+                 (get-current-pvars+unique)))) (code:comment '([x . g124]))]
+
+ Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
+ be called immediately after binding the syntax pattern variable, but the code
+ above shows that it is technically possible to do otherwise.
+
+ This caveat is not meant to dissuade the use of
+ @racket[current-pvars+unique], it rather serves as an explanation of the
+ behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are
+ incorrectly used more than once to record the same pattern variable.}
+
 @defform[(with-pvars (pvar ...) . body)
          #:contracts ([pvar identifier?])]{
  Prepends the given @racket[pvar ...] to the list of pattern variables which