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)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)
|
||||
|
|
|
@ -448,6 +448,8 @@
|
|||
(lambda (s ctx)
|
||||
(log-expand ctx 'prim-if)
|
||||
(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 expr-ctx (as-expression-context ctx))
|
||||
(define tail-ctx (as-tail-context expr-ctx #:wrt ctx))
|
||||
|
|
|
@ -20,6 +20,7 @@
|
|||
"require+provide.rkt"
|
||||
"../common/module-path.rkt"
|
||||
"lift-context.rkt"
|
||||
"lift-key.rkt"
|
||||
"../namespace/core.rkt"
|
||||
"context.rkt"
|
||||
"use-site.rkt"
|
||||
|
@ -309,6 +310,7 @@
|
|||
[def-ctx-scopes def-ctx-scopes]
|
||||
[need-eventually-defined need-eventually-defined] ; used only at phase 1 and up
|
||||
[declared-submodule-names declared-submodule-names]
|
||||
[lift-key #:parent root-expand-context (generate-lift-key)]
|
||||
[lifts (make-lift-context
|
||||
(make-wrap-as-definition self frame-id
|
||||
inside-scope all-scopes-s
|
||||
|
@ -714,6 +716,7 @@
|
|||
(log-expand partial-body-ctx 'next)
|
||||
(define exp-body (performance-region
|
||||
['expand 'form-in-module/1]
|
||||
;; --- expand to core form ---
|
||||
(expand (car bodys) partial-body-ctx)))
|
||||
(define disarmed-exp-body (syntax-disarm exp-body))
|
||||
(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