From 7b3bb4a3ba10ce689a4e3e437087a3ccdba8a96a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 Dec 2012 07:47:21 -0700 Subject: [PATCH] make `splicing-syntax-parameterize' work with `begin-for-syntax' More generally, a `splicing-syntax-parameterize' wrapping immediate compile-time code effectively parameterizes the compile-time code as well as any macro-triggered compile-time code. This is implemented by using a compile-time parameter that complements each syntax binding. --- collects/racket/private/stxparam.rkt | 8 ++- collects/racket/private/stxparamkey.rkt | 40 ++++++++--- collects/racket/splicing.rkt | 71 ++++++++++++++++--- collects/racket/stxparam.rkt | 2 +- collects/tests/racket/mz-tests.rktl | 1 + collects/tests/racket/stxparam.rktl | 94 +++++++++++++++++++++++++ 6 files changed, 193 insertions(+), 23 deletions(-) create mode 100644 collects/tests/racket/stxparam.rktl diff --git a/collects/racket/private/stxparam.rkt b/collects/racket/private/stxparam.rkt index c7124cf9ed..bc69e27c78 100644 --- a/collects/racket/private/stxparam.rkt +++ b/collects/racket/private/stxparam.rkt @@ -8,7 +8,7 @@ (#%provide (for-syntax do-syntax-parameterize)) - (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok?) + (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok? keep-orig?) (syntax-case stx () [(_ ([id val] ...) body ...) (let ([ids (syntax->list #'(id ...))]) @@ -46,7 +46,11 @@ #f "missing body expression(s)" stx))) - (with-syntax ([let-syntaxes let-syntaxes-id]) + (with-syntax ([let-syntaxes let-syntaxes-id] + [(orig ...) (if keep-orig? + (list ids) + #'())]) (syntax/loc stx (let-syntaxes ([(gen-id) (convert-renamer val)] ...) + orig ... body ...)))))]))) diff --git a/collects/racket/private/stxparamkey.rkt b/collects/racket/private/stxparamkey.rkt index 67f58f2c3b..d2be47f863 100644 --- a/collects/racket/private/stxparamkey.rkt +++ b/collects/racket/private/stxparamkey.rkt @@ -4,6 +4,7 @@ "stxcase.rkt" "stxloc.rkt" "with-stx.rkt") (-define-struct wrapped-renamer (renamer)) + (-define-struct parameter-binding (val param)) (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!) (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0)) @@ -11,21 +12,37 @@ (define (syntax-parameter-target sp) (syntax-parameter-ref sp 1)) + (define (target-value target) + (syntax-local-value (syntax-local-get-shadower target) + (lambda () + (syntax-local-value + target + (lambda () #f))))) + (define (syntax-parameter-target-value target) - (let ([v (syntax-local-value (syntax-local-get-shadower target) - (lambda () - #f - (syntax-local-value - target - (lambda () #f))))]) + (let* ([v (target-value target)] + [v (if (parameter-binding? v) + (or (let ([id ((parameter-binding-param v))]) + (and id + (let ([v (syntax-local-value id)]) + (parameter-binding-val v)))) + (parameter-binding-val v)) + v)]) (if (wrapped-renamer? v) (wrapped-renamer-renamer v) - v))) + v))) + + (define (syntax-parameter-target-parameter target) + (let ([v (target-value target)]) + (parameter-binding-param v))) (define (convert-renamer v) - (if (rename-transformer? v) - (make-wrapped-renamer v) - v)) + (make-parameter-binding + (if (rename-transformer? v) + (make-wrapped-renamer v) + v) + ;; comile-time parameter needed for `splicing-syntax-parameterize': + (make-parameter #f))) (define (apply-transformer v stx set!-stx) (cond @@ -68,4 +85,5 @@ syntax-parameter? make-syntax-parameter syntax-parameter-target - syntax-parameter-target-value)) + syntax-parameter-target-value + syntax-parameter-target-parameter)) diff --git a/collects/racket/splicing.rkt b/collects/racket/splicing.rkt index 797acf05c1..0c54a97bdc 100644 --- a/collects/racket/splicing.rkt +++ b/collects/racket/splicing.rkt @@ -1,7 +1,11 @@ #lang racket/base (require (for-syntax racket/base syntax/kerncase - racket/syntax) + racket/syntax + "private/stxparamkey.rkt") + (for-meta 2 ; for wrap-et-param + racket/base + syntax/kerncase) "private/stxparam.rkt" "private/local.rkt") @@ -159,24 +163,24 @@ (define-syntax (splicing-syntax-parameterize stx) (if (eq? 'expression (syntax-local-context)) ;; Splicing is no help in an expression context: - (do-syntax-parameterize stx #'let-syntaxes #f) + (do-syntax-parameterize stx #'let-syntaxes #f #f) ;; Let `syntax-parameterize' check syntax, then continue - (do-syntax-parameterize stx #'ssp-let-syntaxes #t))) + (do-syntax-parameterize stx #'ssp-let-syntaxes #t #t))) (define-syntax (ssp-let-syntaxes stx) (syntax-case stx () - [(_ ([(id) rhs] ...) body ...) + [(_ ([(id) rhs] ...) (orig-id ...) body ...) (with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))]) #'(begin ;; Evaluate each RHS only once: (define-syntax splicing-temp rhs) ... ;; Partially expand `body' to push down `let-syntax': - (expand-ssp-body (id ...) (splicing-temp ...) body) + (expand-ssp-body (id ...) (splicing-temp ...) (orig-id ...) body) ...))])) (define-syntax (expand-ssp-body stx) (syntax-case stx () - [(_ (sp-id ...) (temp-id ...) body) + [(_ (sp-id ...) (temp-id ...) (orig-id ...) body) (let ([body (local-expand #'(letrec-syntaxes/trans ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) (force-expand body)) @@ -197,14 +201,18 @@ #%provide ) [(begin expr ...) (syntax/loc body - (begin (expand-ssp-body (sp-id ...) (temp-id ...) expr) ...))] + (begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))] [(define-values (id ...) rhs) (syntax/loc body (define-values (id ...) (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) rhs)))] - [(define-syntaxes . _) body] - [(begin-for-syntax . _) body] + [(define-syntaxes ids rhs) + (syntax/loc body + (define-syntaxes ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + [(begin-for-syntax e ...) + (syntax/loc body + (begin-for-syntax (wrap-param-et e (orig-id ...) (temp-id ...)) ...))] [(module . _) body] [(module* . _) body] [(#%require . _) body] @@ -233,3 +241,48 @@ #f)) 'certify-mode 'transparent)])) + +(define-for-syntax (parameter-of id) + (let* ([rt (syntax-local-value id)] + [sp (if (set!-transformer? rt) + (set!-transformer-procedure rt) + rt)]) + (syntax-parameter-target-parameter + (syntax-parameter-target sp)))) + +(begin-for-syntax + (define-syntax (wrap-param-et stx) + (syntax-case stx () + [(_ e (orig-id ...) (temp-id ...)) + (let ([as-expression + (lambda () + #'(parameterize ([(parameter-of (quote-syntax orig-id)) + (quote-syntax temp-id)] + ...) + e))]) + (if (eq? (syntax-local-context) 'expression) + (as-expression) + (let ([e (local-expand #'e + (syntax-local-context) + (kernel-form-identifier-list) + #f)]) + (syntax-case e (begin + define-syntaxes define-values + begin-for-syntax + module module* + #%require #%provide + quote-syntax) + [(begin form ...) + (syntax/loc e + (begin (wrap-param-et form (orig-id ...) (temp-id ...)) ...))] + [(define-syntaxes . _) e] + [(begin-for-syntax . _) e] + [(define-values ids rhs) + (syntax/loc e + (define-values ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + [(module . _) e] + [(module* . _) e] + [(#%require . _) e] + [(#%provide . _) e] + [(quote-syntax . _) e] + [else (as-expression)]))))]))) diff --git a/collects/racket/stxparam.rkt b/collects/racket/stxparam.rkt index 4ea659e950..ab198b4f06 100644 --- a/collects/racket/stxparam.rkt +++ b/collects/racket/stxparam.rkt @@ -30,4 +30,4 @@ gen-id))))))])) (define-syntax (syntax-parameterize stx) - (do-syntax-parameterize stx #'let-syntaxes #f))) + (do-syntax-parameterize stx #'let-syntaxes #f #f))) diff --git a/collects/tests/racket/mz-tests.rktl b/collects/tests/racket/mz-tests.rktl index d1df597114..26b52eaefb 100644 --- a/collects/tests/racket/mz-tests.rktl +++ b/collects/tests/racket/mz-tests.rktl @@ -12,6 +12,7 @@ (load-relative "stx.rktl") (load-relative "module.rktl") (load-relative "submodule.rktl") +(load-relative "stxparam.rktl") (load-relative "number.rktl") (load-relative "unsafe.rktl") (load-relative "object.rktl") diff --git a/collects/tests/racket/stxparam.rktl b/collects/tests/racket/stxparam.rktl new file mode 100644 index 0000000000..7ea6853fd0 --- /dev/null +++ b/collects/tests/racket/stxparam.rktl @@ -0,0 +1,94 @@ + +(load-relative "loadtest.rktl") + +(Section 'stxparam) + +(require racket/stxparam + racket/splicing) + +(define-syntax-parameter tHIs (lambda (stx) #'(quote orig))) +(define-syntax-rule (inDIRECt) tHIs) + +(test 'orig values tHIs) +(test 'orig values (inDIRECt)) + +(test 'sub values (syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))]) + tHIs)) +(test 'sub values (syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))]) + (inDIRECt))) +(test 'sub values (splicing-syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))]) + (inDIRECt))) + +(module check-splicing-stxparam-1 racket/base + (require (for-syntax racket/base) + racket/stxparam + racket/splicing) + (define-syntax-parameter sp 'orig) + (define-syntax (m stx) + (define v (syntax-parameter-value #'sp)) + (syntax-case stx () + [(_ id) #`(define id (quote #,v))])) + (m x) + (splicing-syntax-parameterize ([sp 'sub]) + (begin + (define other 'other) + (m y))) + + (begin-for-syntax (define sp-val-1 (syntax-parameter-value #'sp))) + (define-syntax (m1 stx) + (syntax-case stx () + [(_ id) #`(define id (quote #,sp-val-1))])) + (m1 z) + + (splicing-syntax-parameterize ([sp 'sub2]) + (begin-for-syntax (define sp-val-2 (syntax-parameter-value #'sp)))) + (define-syntax (m2 stx) + (syntax-case stx () + [(_ id) #`(define id (quote #,sp-val-2))])) + (m2 w) + + (splicing-syntax-parameterize ([sp 'unused]) + ;; make sure that `splicing-syntax-parameterize' can + ;; deal with a variety of compile-time forms + (begin-for-syntax + (require racket/base) + (define x 11) + (provide x))) + + (define (f) + (splicing-syntax-parameterize ([sp 'nested]) + (define-syntax m (let ([v (syntax-parameter-value #'sp)]) + (lambda (stx) + #`(quote #,v))))) + (m)) + + (define (g) + (syntax-parameterize ([sp 'hidden]) + (splicing-syntax-parameterize ([sp 'also-nested]) + (define-syntax m (let ([v (syntax-parameter-value #'sp)]) + (lambda (stx) + #`(quote #,v))))) + (m))) + + (provide x y z w f g)) + +(test 'orig dynamic-require ''check-splicing-stxparam-1 'x) +(test 'sub dynamic-require ''check-splicing-stxparam-1 'y) +(test 'orig dynamic-require ''check-splicing-stxparam-1 'z) +(test 'sub2 dynamic-require ''check-splicing-stxparam-1 'w) +(test 'nested values ((dynamic-require ''check-splicing-stxparam-1 'f))) +(test 'also-nested values ((dynamic-require ''check-splicing-stxparam-1 'g))) + +(module check-splicing-stxparam-et racket/base + (require (for-syntax racket/base) + 'check-splicing-stxparam-1) + (define-syntax (m stx) (datum->syntax stx x)) + (define q (m)) + (provide q)) + +(test 11 dynamic-require ''check-splicing-stxparam-et 'q) + +;; ---------------------------------------- + +(report-errs) +