Force expression context for local and block
* Document liberal-defines? argument of generate-expand-context * Add make-expression-transformer * Ensure `block` expands in an expression context Also refactors block to depend on racket/base and syntax/ modules rather than private pre-base dependencies so it can use `make-expression-transformer` and `generate-expand-context`. * Ensure `local` expands in an expression context * Add macro.rktl tests for block and local
This commit is contained in:
Michael Ballantyne
GitHub
parent
aafdafb1cf
commit
a17621bec9
|
|
@ -13,6 +13,11 @@ Returns a list suitable for use as a context argument to
|
|||
expansion. The context list builds on @racket[(syntax-local-context)]
|
||||
if it is a list.}
|
||||
|
||||
@defproc[(generate-expand-context) list?]{
|
||||
@defproc[(generate-expand-context [liberal-definitions? boolean? #f]) list?]{
|
||||
|
||||
Calls @racket[build-expand-context] with a generated symbol.}
|
||||
Calls @racket[build-expand-context] with a generated unique value.
|
||||
When @racket[liberal-definitions?] is true, the value is an instance of
|
||||
a structure type with a true value for the @racket[prop:liberal-define-context]
|
||||
property.
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -42,3 +42,15 @@ op
|
|||
}
|
||||
|
||||
@close-eval[the-eval]
|
||||
|
||||
@defproc[(make-expression-transformer
|
||||
[transformer (-> syntax? syntax?)])
|
||||
(-> syntax? syntax?)]{
|
||||
|
||||
Creates a transformer derived from @racket[transformer] that ensures it expands
|
||||
in an expression context. When invoked in an expression context, it calls
|
||||
@racket[transformer]. When invoked in any other context, the new
|
||||
transformer wraps the argument syntax with @racket[#%expression].
|
||||
|
||||
@history[#:added "7.7.0.9"]{}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2491,5 +2491,54 @@
|
|||
(test #t values found-it?))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Make sure that `block` forces an expression context with #%expression
|
||||
|
||||
(let ()
|
||||
(define-syntax-rule (m x) (set! x 'outer))
|
||||
(define res #f)
|
||||
(let ()
|
||||
(block
|
||||
(m res))
|
||||
(define-syntax-rule (m x) (set! x 'inner))
|
||||
(void))
|
||||
(test 'inner values res))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Make sure that `block` works normally in a non-expression context
|
||||
(let ()
|
||||
(block
|
||||
; ensure forward references work
|
||||
(define (f x) (g x))
|
||||
; ensure definition splices
|
||||
(define-syntax-rule (def-g name)
|
||||
(define (name x) (h x)))
|
||||
; ensure use-site binder doesn't capture
|
||||
(define-syntax-rule (def-h name arg)
|
||||
(define (name x)
|
||||
(let ([arg 'bad])
|
||||
x)))
|
||||
(def-g g)
|
||||
(def-h h x)
|
||||
(test 'ok values (f 'ok))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Make sure that `local` works normally in a non-expression context
|
||||
|
||||
(require racket/local)
|
||||
(let ()
|
||||
(local [; ensure forward references work
|
||||
(define (f x) (g x))
|
||||
; ensure definition splices
|
||||
(define-syntax-rule (def-g name)
|
||||
(define (name x) x))
|
||||
; ensure use-site binder doesn't capture
|
||||
(define-syntax-rule (def-h name arg)
|
||||
(define (name x)
|
||||
(let ([arg 'bad])
|
||||
x)))
|
||||
(def-g g)
|
||||
(def-h h x)]
|
||||
(test 'ok values (f 'ok))))
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,108 +1,100 @@
|
|||
(module block '#%kernel
|
||||
(#%require "private/define.rkt"
|
||||
(for-syntax '#%kernel
|
||||
"private/stx.rkt"
|
||||
"private/qq-and-or.rkt"
|
||||
"private/define-et-al.rkt"
|
||||
"private/cond.rkt"
|
||||
"private/stxcase-scheme.rkt"
|
||||
"private/qqstx.rkt"
|
||||
"private/intdef-util.rkt"))
|
||||
#lang racket/base
|
||||
|
||||
(#%provide block)
|
||||
(require
|
||||
(for-syntax
|
||||
racket/base
|
||||
syntax/stx
|
||||
syntax/transformer
|
||||
syntax/context
|
||||
"private/intdef-util.rkt"))
|
||||
|
||||
(define-values-for-syntax (make-context)
|
||||
(let-values ([(struct: mk ? ref set)
|
||||
(make-struct-type 'in-liberal-define-context #f 0 0 #f
|
||||
(list (cons prop:liberal-define-context #t)))])
|
||||
mk))
|
||||
(provide block)
|
||||
|
||||
(define-syntax (block stx)
|
||||
;; Body can have mixed exprs and defns. Wrap expressions with
|
||||
;; `(define-values () ... (values))' as needed, and add a (void)
|
||||
;; at the end if needed.
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (list (make-context))]
|
||||
;; [kernel-forms (kernel-form-identifier-list)]
|
||||
[stoplist (list #'begin #'define-syntaxes #'define-values)]
|
||||
[init-exprs (let ([v (syntax->list stx)])
|
||||
(unless v (raise-syntax-error #f "bad syntax" stx))
|
||||
(cdr v))]
|
||||
[exprs
|
||||
(let loop ([todo init-exprs] [r '()])
|
||||
(if (null? todo)
|
||||
(reverse r)
|
||||
(let ([expr (local-expand (car todo) ctx stoplist def-ctx)]
|
||||
[todo (cdr todo)])
|
||||
(syntax-case expr (begin define-syntaxes define-values)
|
||||
[(begin . rest)
|
||||
(loop (append (syntax->list #'rest) todo) r)]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs 'expression null)])
|
||||
(syntax-local-bind-syntaxes
|
||||
(syntax->list #'(id ...))
|
||||
#'rhs def-ctx)
|
||||
(with-syntax ([(id ...) (map syntax-local-identifier-as-binding
|
||||
(syntax->list #'(id ...)))])
|
||||
(loop todo (cons (datum->syntax
|
||||
expr
|
||||
(list #'define-syntaxes #'(id ...) #'rhs)
|
||||
expr
|
||||
expr)
|
||||
r))))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(with-syntax ([(id ...) (map syntax-local-identifier-as-binding
|
||||
(syntax->list #'(id ...)))])
|
||||
(loop todo (cons (datum->syntax
|
||||
expr
|
||||
(list #'define-values #'(id ...) #'rhs)
|
||||
expr
|
||||
expr)
|
||||
r))))]
|
||||
[else (loop todo (cons expr r))]))))])
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(let loop ([exprs exprs]
|
||||
[prev-stx-defns null]
|
||||
[prev-defns null]
|
||||
[prev-exprs null])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(add-decl-props
|
||||
def-ctx
|
||||
(append prev-stx-defns prev-defns)
|
||||
#`(letrec-syntaxes+values
|
||||
#,(map stx-cdr (reverse prev-stx-defns))
|
||||
#,(map stx-cdr (reverse prev-defns))
|
||||
#,@(if (null? prev-exprs)
|
||||
(list #'(void))
|
||||
(reverse prev-exprs))))]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(free-identifier=? #'define-syntaxes (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
(cons (car exprs) prev-stx-defns)
|
||||
prev-defns
|
||||
prev-exprs)]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(free-identifier=? #'define-values (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
(cons (car exprs)
|
||||
(append
|
||||
(map (lambda (expr)
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
prev-exprs)
|
||||
prev-defns))
|
||||
null)]
|
||||
[else (loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
prev-defns
|
||||
(cons (car exprs) prev-exprs))]))))
|
||||
|
||||
)
|
||||
(define-syntax block
|
||||
(make-expression-transformer
|
||||
(lambda (stx)
|
||||
;; Body can have mixed exprs and defns. Wrap expressions with
|
||||
;; `(define-values () ... (values))' as needed, and add a (void)
|
||||
;; at the end if needed.
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (generate-expand-context #t)]
|
||||
;; [kernel-forms (kernel-form-identifier-list)]
|
||||
[stoplist (list #'begin #'define-syntaxes #'define-values)]
|
||||
[init-exprs (let ([v (syntax->list stx)])
|
||||
(unless v (raise-syntax-error #f "bad syntax" stx))
|
||||
(cdr v))]
|
||||
[exprs
|
||||
(let loop ([todo init-exprs] [r '()])
|
||||
(if (null? todo)
|
||||
(reverse r)
|
||||
(let ([expr (local-expand (car todo) ctx stoplist def-ctx)]
|
||||
[todo (cdr todo)])
|
||||
(syntax-case expr (begin define-syntaxes define-values)
|
||||
[(begin . rest)
|
||||
(loop (append (syntax->list #'rest) todo) r)]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs 'expression null)])
|
||||
(syntax-local-bind-syntaxes
|
||||
(syntax->list #'(id ...))
|
||||
#'rhs def-ctx)
|
||||
(with-syntax ([(id ...) (map syntax-local-identifier-as-binding
|
||||
(syntax->list #'(id ...)))])
|
||||
(loop todo (cons (datum->syntax
|
||||
expr
|
||||
(list #'define-syntaxes #'(id ...) #'rhs)
|
||||
expr
|
||||
expr)
|
||||
r))))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(with-syntax ([(id ...) (map syntax-local-identifier-as-binding
|
||||
(syntax->list #'(id ...)))])
|
||||
(loop todo (cons (datum->syntax
|
||||
expr
|
||||
(list #'define-values #'(id ...) #'rhs)
|
||||
expr
|
||||
expr)
|
||||
r))))]
|
||||
[else (loop todo (cons expr r))]))))])
|
||||
(let loop ([exprs exprs]
|
||||
[prev-stx-defns null]
|
||||
[prev-defns null]
|
||||
[prev-exprs null])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(add-decl-props
|
||||
def-ctx
|
||||
(append prev-stx-defns prev-defns)
|
||||
#`(letrec-syntaxes+values
|
||||
#,(map stx-cdr (reverse prev-stx-defns))
|
||||
#,(map stx-cdr (reverse prev-defns))
|
||||
#,@(if (null? prev-exprs)
|
||||
(list #'(void))
|
||||
(reverse prev-exprs))))]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(free-identifier=? #'define-syntaxes (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
(cons (car exprs) prev-stx-defns)
|
||||
prev-defns
|
||||
prev-exprs)]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(free-identifier=? #'define-values (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
(cons (car exprs)
|
||||
(append
|
||||
(map (lambda (expr)
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
prev-exprs)
|
||||
prev-defns))
|
||||
null)]
|
||||
[else (loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
prev-defns
|
||||
(cons (car exprs) prev-exprs))]))))))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base)
|
||||
(require (for-syntax racket/base syntax/transformer)
|
||||
"private/local.rkt")
|
||||
(provide local)
|
||||
|
||||
(define-syntax (local stx)
|
||||
(do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys)
|
||||
(quasisyntax/loc stx
|
||||
(letrec-syntaxes+values
|
||||
#,sbindings
|
||||
#,vbindings
|
||||
#,@bodys)))))
|
||||
(define-syntax local
|
||||
(make-expression-transformer
|
||||
(lambda (stx)
|
||||
(do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys)
|
||||
(quasisyntax/loc stx
|
||||
(letrec-syntaxes+values
|
||||
#,sbindings
|
||||
#,vbindings
|
||||
#,@bodys)))))))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,9 @@
|
|||
|
||||
(require (for-template racket/base))
|
||||
|
||||
(provide make-variable-like-transformer)
|
||||
(provide
|
||||
make-variable-like-transformer
|
||||
make-expression-transformer)
|
||||
|
||||
(struct variable-like-transformer [procedure]
|
||||
#:property prop:procedure (struct-field-index procedure)
|
||||
|
|
@ -31,3 +33,11 @@
|
|||
[(id . args)
|
||||
(let ([stx* (cons #'(#%expression id) (cdr (syntax-e stx)))])
|
||||
(datum->syntax stx stx* stx))]))))
|
||||
|
||||
(define (make-expression-transformer transformer)
|
||||
(unless (and (procedure? transformer) (procedure-arity-includes? transformer 1))
|
||||
(raise-argument-error 'make-expression-transformer "(-> syntax? syntax?)" transformer))
|
||||
(lambda (stx)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
(transformer stx)
|
||||
#`(#%expression #,stx))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user