suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reinstate the stop list after #%module-begin performs partial expansion

Browse Source
This commit is contained in:
Alexis King 2018-11-04 10:16:45 -06:00
parent fd8c2b2c20
commit bc34ba884b
3 changed files with 36 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -2774,6 +2774,18 @@ case of module-leve bindings; it doesn't cover local bindings.
(test 6 dynamic-require ''shaodws-c-and-imports-the-rest 'result)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure #%module-begin respects the stop list when module* is present
(module module-begin-stop-list racket/base
(require (for-syntax racket/base))
(define-syntax (stop stx)
(raise-syntax-error #f "don't expand me!" stx))
(begin-for-syntax
(local-expand #'(#%plain-module-begin (#%expression (stop)))
'module-begin
(list #'module* #'stop))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

9
racket/src/expander/expand/module.rkt
View File

@ -296,7 +296,7 @@
;; Passes 1 and 2 are nested via `begin-for-syntax`:
(define expression-expanded-bodys
(let pass-1-and-2-loop ([bodys bodys] [phase phase])
(let pass-1-and-2-loop ([bodys bodys] [phase phase] [keep-stops? (stop-at-module*? ctx)])
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Pass 1: partially expand to discover all bindings and install all
@ -305,7 +305,6 @@
;; Need to accumulate definition contexts created during
;; partial expansion:
(define def-ctx-scopes (box null))
(define to-parsed? (expand-context-to-parsed? ctx))
(define partial-body-ctx (struct*-copy expand-context ctx
[context 'module]
@ -356,7 +355,9 @@
(log-expand partial-body-ctx 'next-group)
(define body-ctx (struct*-copy expand-context (accumulate-def-ctx-scopes partial-body-ctx def-ctx-scopes)
[stops empty-free-id-set]
[stops (if keep-stops?
(expand-context-stops ctx)
empty-free-id-set)]
[def-ctx-scopes #f]
[post-expansion #:parent root-expand-context #f]
[to-module-lifts (make-to-module-lift-context phase
@ -756,7 +757,7 @@
(prepare-next-phase-namespace partial-body-ctx)
(log-expand partial-body-ctx 'phase-up)
(define-match m disarmed-exp-body '(begin-for-syntax e ...))
(define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase)))
(define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase) #f))
(log-expand partial-body-ctx 'next-group)
(namespace-run-available-modules! m-ns (add1 phase)) ; to support running `begin-for-syntax`
(eval-nested-bodys nested-bodys (add1 phase) ct-m-ns self partial-body-ctx)

32
racket/src/racket/src/startup.inc
View File

@ -1815,7 +1815,9 @@ static const char *startup_source =
" \" (procedure-arity-includes/c 1)\\n\""
" \" (procedure-arity-includes/c 1))\")"
" v_0)))"
"(vector->immutable-vector v_0)))))"
"(vector->immutable-vector v_0)))"
" '()"
" #t))"
"(define-values"
"(prop:gen-sequence sequence-via-prop? sequence-ref)"
"(make-struct-type-property"
@ -72413,15 +72415,13 @@ static const char *startup_source =
"(let-values(((expression-expanded-bodys_0)"
"((letrec-values(((pass-1-and-2-loop_0)"
"(lambda(bodys_2"
" phase_1)"
" phase_1"
" keep-stops?_0)"
"(begin"
" 'pass-1-and-2-loop"
"(let-values(((def-ctx-scopes_0)"
"(box"
" null)))"
"(let-values(((to-parsed?_0)"
"(expand-context-to-parsed?"
" ctx_1)))"
"(let-values(((partial-body-ctx_0)"
"(let-values(((v_0)"
" ctx_1))"
@ -72545,7 +72545,7 @@ static const char *startup_source =
" the-struct_1)))"
"(raise-argument-error"
" 'struct-copy"
" \"expand-context/inner?\""
" \"expand-context/inner?\""
" the-struct_1)))))"
"(expand-context/outer1.1"
" inner328_0"
@ -72576,7 +72576,7 @@ static const char *startup_source =
" the-struct_0)))"
"(raise-argument-error"
" 'struct-copy"
" \"expand-context/outer?\""
" \"expand-context/outer?\""
" the-struct_0))))))"
"(let-values(((partially-expanded-bodys_0)"
"(let-values(((bodys346_0)"
@ -72661,7 +72661,10 @@ static const char *startup_source =
"(if(expand-context/inner?"
" the-struct_1)"
"(let-values(((stops365_0)"
" empty-free-id-set)"
"(if keep-stops?_0"
"(expand-context-stops"
" ctx_1)"
" empty-free-id-set))"
"((to-module-lifts366_0)"
"(let-values(((phase367_0)"
" phase_1)"
@ -72726,7 +72729,7 @@ static const char *startup_source =
" the-struct_1)))"
"(raise-argument-error"
" 'struct-copy"
" \"expand-context/inner?\""
" \"expand-context/inner?\""
" the-struct_1)))))"
"(expand-context/outer1.1"
" inner364_0"
@ -72758,7 +72761,7 @@ static const char *startup_source =
" the-struct_0)))"
"(raise-argument-error"
" 'struct-copy"
" \"expand-context/outer?\""
" \"expand-context/outer?\""
" the-struct_0))))))"
"(let-values(((partially-expanded-bodys317_0)"
" partially-expanded-bodys_0)"
@ -72784,10 +72787,12 @@ static const char *startup_source =
" mpis-to-reset324_0"
" phase318_0"
" self320_0"
" partially-expanded-bodys317_0))))))))))))"
" partially-expanded-bodys317_0)))))))))))"
" pass-1-and-2-loop_0)"
" bodys_1"
" phase_0)))"
" phase_0"
"(stop-at-module*?"
" ctx_1))))"
"(let-values((()"
"(begin"
"(check-defined-by-now"
@ -74063,7 +74068,8 @@ static const char *startup_source =
"(pass-1-and-2-loop_0"
" e470_0"
"(add1"
" phase_0))))"
" phase_0)"
" #f)))"
"(begin"
"(let-values(((obs_0)"
"(expand-context-observer"