From dade971dd60b994d801a0cc49cbe93455c0d79f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 25 Jan 2017 22:56:07 +0100 Subject: [PATCH] added current-pvars+unique --- current-pvars.rkt | 50 +++++++++++++++------- scribblings/stxparse-info.scrbl | 74 ++++++++++++++++++++++++++++++--- 2 files changed, 104 insertions(+), 20 deletions(-) diff --git a/current-pvars.rkt b/current-pvars.rkt index 0c9ad6a..4417b62 100644 --- 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) @@ -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)] diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl index b11bf46..5b6032a 100644 --- 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