Ensure block does not evaluate define-syntaxes RHSs multiple times
As described in #3635, there isn’t currently any good way to use first-class definition contexts without evaluating define-syntaxes RHSs multiple times. For macros like `class` and `unit`, it’s unclear if that can be avoided, but for `block`, the first-class definition context turns out to not be necessary. This commit changes the implementation strategy used by `block` to a trampolining macro rather than a first-class definition context. This has the nice side-effect of avoiding the issue described in #3198, too.
This commit is contained in:
Alexis King
parent
e4a4bdf52a
commit
c54ab626f7
|
|
@ -2604,5 +2604,19 @@
|
|||
(def-h h x)]
|
||||
(test 'ok values (f 'ok))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Make sure that `block` does not evaluate phase 1 expressions multiple times
|
||||
|
||||
(module block-define-syntax-evaluation racket/base
|
||||
(require (for-syntax racket/base) racket/block)
|
||||
(provide final-counter)
|
||||
|
||||
(define-for-syntax counter 0)
|
||||
(define-syntax (get-counter stx) #`'#,counter)
|
||||
(block (define-syntax m (set! counter (add1 counter))))
|
||||
(define final-counter (get-counter)))
|
||||
|
||||
(test 1 dynamic-require ''block-define-syntax-evaluation 'final-counter)
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,100 +1,33 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
racket/base
|
||||
syntax/stx
|
||||
syntax/transformer
|
||||
syntax/context
|
||||
"private/intdef-util.rkt"))
|
||||
(require (for-syntax syntax/context
|
||||
syntax/kerncase
|
||||
syntax/transformer
|
||||
racket/base)
|
||||
syntax/parse/define)
|
||||
|
||||
(provide block)
|
||||
|
||||
(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))]))))))
|
||||
(syntax-parser
|
||||
[(_ defn-or-expr ...)
|
||||
(quasisyntax/loc this-syntax
|
||||
(let () (block-trampoline #,(generate-expand-context #t) #f defn-or-expr ...)))])))
|
||||
|
||||
(define-syntax-parser block-trampoline
|
||||
[(_ _ #f) #'(void)]
|
||||
[(_ _ #t) #'(begin)]
|
||||
[(_ context-v follows-expr? defn-or-expr more ...)
|
||||
(syntax-parse (local-expand #'defn-or-expr
|
||||
(list (syntax-e #'context-v))
|
||||
(kernel-form-identifier-list))
|
||||
#:literal-sets [kernel-literals]
|
||||
[(head:begin defn-or-expr ...)
|
||||
(syntax-track-origin #'(block-trampoline context-v follows-expr? defn-or-expr ... more ...)
|
||||
this-syntax
|
||||
(syntax-local-introduce #'head))]
|
||||
[({~or define-values define-syntaxes} . _)
|
||||
#`(begin #,this-syntax (block-trampoline context-v #f more ...))]
|
||||
[_
|
||||
#`(begin #,this-syntax (block-trampoline context-v #t more ...))])])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user