diff --git a/pkgs/racket-doc/syntax/scribblings/context.scrbl b/pkgs/racket-doc/syntax/scribblings/context.scrbl index f20f412f74..2e2c0effb8 100644 --- a/pkgs/racket-doc/syntax/scribblings/context.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/context.scrbl @@ -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. + +} diff --git a/pkgs/racket-doc/syntax/scribblings/transformer.scrbl b/pkgs/racket-doc/syntax/scribblings/transformer.scrbl index 7b6d4fc530..28b0e5be4c 100644 --- a/pkgs/racket-doc/syntax/scribblings/transformer.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/transformer.scrbl @@ -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"]{} +} diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 65a97e0885..33d20d60a6 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -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) diff --git a/racket/collects/racket/block.rkt b/racket/collects/racket/block.rkt index 34aee402ee..6196dea8f8 100644 --- a/racket/collects/racket/block.rkt +++ b/racket/collects/racket/block.rkt @@ -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))])))))) diff --git a/racket/collects/racket/local.rkt b/racket/collects/racket/local.rkt index d732e2f806..977c794747 100644 --- a/racket/collects/racket/local.rkt +++ b/racket/collects/racket/local.rkt @@ -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))))))) diff --git a/racket/collects/syntax/transformer.rkt b/racket/collects/syntax/transformer.rkt index 9f78cd160a..dc7929c15c 100644 --- a/racket/collects/syntax/transformer.rkt +++ b/racket/collects/syntax/transformer.rkt @@ -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))))