commit dade971dd60b994d801a0cc49cbe93455c0d79f4
parent 55e5934598b2399956d3ac9b00f0d6eb6a3243a5
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 25 Jan 2017 22:56:07 +0100
added current-pvars+unique
Diffstat:
2 files changed, 104 insertions(+), 20 deletions(-)
diff --git a/current-pvars.rkt b/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)
@@ -111,6 +117,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)))))
;; (with-pvars [pvar ...] . body)
@@ -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)]
diff --git a/scribblings/stxparse-info.scrbl b/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
