expander: fix lift context for multiple #%module-begin
s
Also, restore the old syntax-error message for an `if` without an "else" clause.
This commit is contained in:
parent
1d8e04896e
commit
e707d7decd
|
@ -2285,6 +2285,39 @@ case of module-leve bindings; it doesn't cover local bindings.
|
||||||
|
|
||||||
(test 5 dynamic-require ''likely-inlines-across-two-submodules 'result)
|
(test 5 dynamic-require ''likely-inlines-across-two-submodules 'result)
|
||||||
|
|
||||||
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Check that the lift context is different for multiple
|
||||||
|
;; `#%module-begin` expansions. That's important, for example, to make
|
||||||
|
;; sure that a lift in the first pass record by the contract system
|
||||||
|
;; isn't assumed to be from a lexically earlier expression within a
|
||||||
|
;; second pass.
|
||||||
|
|
||||||
|
(module module-begin-and-unique-context-check racket/base
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
|
||||||
|
(provide (except-out (all-from-out racket/base)
|
||||||
|
#%module-begin)
|
||||||
|
(rename-out [module-begin #%module-begin])
|
||||||
|
check-unique-context)
|
||||||
|
|
||||||
|
(define-for-syntax prev-key #f)
|
||||||
|
|
||||||
|
(define-syntax (module-begin stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ form ...)
|
||||||
|
(with-syntax ([(pmb new-form ...) (local-expand #'(#%plain-module-begin form ...) 'module-begin null)])
|
||||||
|
#'(#%plain-module-begin new-form ... (check-unique-context)))]))
|
||||||
|
|
||||||
|
(define-syntax (check-unique-context stx)
|
||||||
|
(define key (syntax-local-lift-context))
|
||||||
|
(when (eq? key prev-key)
|
||||||
|
(raise-syntax-error #f "context didn't change"))
|
||||||
|
(set! prev-key key)
|
||||||
|
#'(void)))
|
||||||
|
|
||||||
|
(module use-module-begin-and-unique-context-check 'module-begin-and-unique-context-check
|
||||||
|
(#%expression (check-unique-context)))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
|
|
|
@ -448,6 +448,8 @@
|
||||||
(lambda (s ctx)
|
(lambda (s ctx)
|
||||||
(log-expand ctx 'prim-if)
|
(log-expand ctx 'prim-if)
|
||||||
(define disarmed-s (syntax-disarm s))
|
(define disarmed-s (syntax-disarm s))
|
||||||
|
(define-match bad-m disarmed-s #:try '(_ _ _))
|
||||||
|
(when (bad-m) (raise-syntax-error #f "missing an \"else\" expression" s))
|
||||||
(define-match m disarmed-s '(if tst thn els))
|
(define-match m disarmed-s '(if tst thn els))
|
||||||
(define expr-ctx (as-expression-context ctx))
|
(define expr-ctx (as-expression-context ctx))
|
||||||
(define tail-ctx (as-tail-context expr-ctx #:wrt ctx))
|
(define tail-ctx (as-tail-context expr-ctx #:wrt ctx))
|
||||||
|
|
|
@ -20,6 +20,7 @@
|
||||||
"require+provide.rkt"
|
"require+provide.rkt"
|
||||||
"../common/module-path.rkt"
|
"../common/module-path.rkt"
|
||||||
"lift-context.rkt"
|
"lift-context.rkt"
|
||||||
|
"lift-key.rkt"
|
||||||
"../namespace/core.rkt"
|
"../namespace/core.rkt"
|
||||||
"context.rkt"
|
"context.rkt"
|
||||||
"use-site.rkt"
|
"use-site.rkt"
|
||||||
|
@ -309,6 +310,7 @@
|
||||||
[def-ctx-scopes def-ctx-scopes]
|
[def-ctx-scopes def-ctx-scopes]
|
||||||
[need-eventually-defined need-eventually-defined] ; used only at phase 1 and up
|
[need-eventually-defined need-eventually-defined] ; used only at phase 1 and up
|
||||||
[declared-submodule-names declared-submodule-names]
|
[declared-submodule-names declared-submodule-names]
|
||||||
|
[lift-key #:parent root-expand-context (generate-lift-key)]
|
||||||
[lifts (make-lift-context
|
[lifts (make-lift-context
|
||||||
(make-wrap-as-definition self frame-id
|
(make-wrap-as-definition self frame-id
|
||||||
inside-scope all-scopes-s
|
inside-scope all-scopes-s
|
||||||
|
@ -714,6 +716,7 @@
|
||||||
(log-expand partial-body-ctx 'next)
|
(log-expand partial-body-ctx 'next)
|
||||||
(define exp-body (performance-region
|
(define exp-body (performance-region
|
||||||
['expand 'form-in-module/1]
|
['expand 'form-in-module/1]
|
||||||
|
;; --- expand to core form ---
|
||||||
(expand (car bodys) partial-body-ctx)))
|
(expand (car bodys) partial-body-ctx)))
|
||||||
(define disarmed-exp-body (syntax-disarm exp-body))
|
(define disarmed-exp-body (syntax-disarm exp-body))
|
||||||
(define lifted-defns (get-and-clear-lifts! (expand-context-lifts partial-body-ctx)))
|
(define lifted-defns (get-and-clear-lifts! (expand-context-lifts partial-body-ctx)))
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user