suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add splicing-parameterize to racket/splicing

Browse Source
This commit is contained in:
Alexis King 2018-01-31 10:41:39 -08:00
parent 9981a15901
commit 02f6162283
3 changed files with 121 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/racket-doc/scribblings/reference/splicing.scrbl
View File

@ -21,14 +21,16 @@
@defidform[splicing-letrec-syntaxes]
@defidform[splicing-letrec-syntaxes+values]
@defidform[splicing-local]
@defidform[splicing-parameterize]
)]{
Like @racket[let], @racket[letrec], @racket[let-values],
@racket[letrec-values], @racket[let-syntax], @racket[letrec-syntax],
@racket[let-syntaxes], @racket[letrec-syntaxes],
@racket[letrec-syntaxes+values], and @racket[local], except that in a
definition context, the body forms are spliced into the enclosing
definition context (in the same way as for @racket[begin]).
@racket[letrec-syntaxes+values], @racket[local], and
@racket[parameterize], except that in a definition context, the body
forms are spliced into the enclosing definition context (in the same
way as for @racket[begin]).
@examples[
#:eval splice-eval
@ -57,7 +59,10 @@ splicing body, then the identifier should have a true value for the
example, @racket[splicing-let] itself adds the property to
locally-bound identifiers as it expands to a sequence of definitions,
so that nesting @racket[splicing-let] within a splicing form works as
expected (without any ambiguous bindings).}
expected (without any ambiguous bindings).
@history[
#:changed "6.12.0.2" @elem{Added @racket[splicing-parameterize].}]}
@defidform[splicing-syntax-parameterize]{

48
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

@ -1660,6 +1660,54 @@
(inspect-prop (splicing-let ()
(define-syntaxes/prop [] (values)))))))
(test 42 'splicing-parameterize
(let ([param (make-parameter #f)])
(splicing-parameterize ([param 42])
(param))))
(test 42 'splicing-parameterize
(let ([param (make-parameter #f)])
(splicing-parameterize ([param 42])
(define x (param)))
x))
(test #f 'splicing-parameterize
(let ([param (make-parameter #f)])
(splicing-parameterize ([param 42])
(define (f) (param)))
(f)))
(test #t 'splicing-parameterize
(let ([param (make-parameter #f)])
(splicing-parameterize ([param 42])
(param #t)
(define x (param)))
x))
(test #f 'splicing-parameterize
(let-syntax ([deflocal (lambda (stx)
(syntax-case stx ()
[(_ id rhs)
#`(define #,(syntax-property #'id 'definition-intended-as-local #t)
rhs)]))])
(let ([param (make-parameter #f)])
(define x (param))
(splicing-parameterize ([param 42])
(deflocal x (param)))
x)))
(test 42 'splicing-parameterize
(let-syntax ([deflocal (lambda (stx)
(syntax-case stx ()
[(_ id rhs)
#`(define #,(syntax-property #'id 'definition-intended-as-local #t)
rhs)]))])
(let ([param (make-parameter #f)])
(define x (param))
(splicing-parameterize ([param 42])
(deflocal x (param))
x))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check keyword & optionals for define-syntax
;; and define-syntax-for-values:

65
racket/collects/racket/splicing.rkt
View File

@ -19,7 +19,8 @@
splicing-letrec-values
splicing-letrec-syntaxes+values
splicing-local
splicing-syntax-parameterize)
splicing-syntax-parameterize
splicing-parameterize)
(module syntax/loc/props racket/base
(require (for-syntax racket/base))
@ -456,3 +457,65 @@
[(#%declare . _) e]
[(quote-syntax . _) e]
[else (as-expression)]))))])))
;; ----------------------------------------
(define-syntax (splicing-parameterize stx)
(syntax-case stx ()
[(_ ([param value] ...) body ...)
(with-syntax ([(param/checked ...)
(for/list ([param-stx (in-list (syntax->list #'(param ...)))])
#`(let ([param-val #,param-stx])
(unless (parameter? param-val)
(raise-argument-error 'splicing-parameterize "parameter?" param-val))
param-val))])
(if (eq? (syntax-local-context) 'expression)
#'(parameterize ([param/checked value] ...)
body ...)
(let ([introduce (make-syntax-introducer #t)])
(with-syntax ([scopeless-id (datum->syntax #f 'scopeless-id)]
[scoped-id (introduce (datum->syntax #f 'scoped-id))]
[(scoped-body ...) (map introduce (syntax->list #'(body ...)))]
; make sure the parameterization can be GC’d at the top/module level
[(free-parameterization-expr ...)
(case (syntax-local-context)
[(top-level module) #'((set! new-parameterization #f))]
[else #'()])])
#'(begin
(define new-parameterization
(parameterize ([param/checked value] ...)
(current-parameterization)))
(splicing-parameterize-body
scopeless-id scoped-id new-parameterization scoped-body) ...
free-parameterization-expr ...)))))]))
(define-syntax (splicing-parameterize-body stx)
(syntax-case stx ()
[(_ scopeless-id scoped-id parameterization body)
(let* ([introducer (make-syntax-delta-introducer #'scoped-id #'scopeless-id)]
[unintro (λ (stx) (introducer stx 'remove))]
[expanded-body (local-expand #'body (syntax-local-context)
(kernel-form-identifier-list))])
(kernel-syntax-case expanded-body #f
[(begin new-body ...)
(syntax/loc/props expanded-body
(begin
(splicing-parameterize-body parameterization new-body)
...))]
[(define-values ids rhs)
(quasisyntax/loc/props expanded-body
(define-values #,(map (maybe unintro) (syntax->list #'ids))
(call-with-parameterization parameterization (λ () rhs))))]
[(define-syntaxes ids rhs)
(quasisyntax/loc/props expanded-body
(define-syntaxes #,(map (maybe unintro) (syntax->list #'ids)) rhs))]
[(begin-for-syntax . _) expanded-body]
[(module . _) (unintro expanded-body)]
[(module* . _) expanded-body]
[(#%require . _) (unintro expanded-body)]
[(#%provide . _) expanded-body]
[(#%declare . _) expanded-body]
[expr
(syntax/loc/props expanded-body
(call-with-parameterization parameterization (λ () expr)))]))]))