From bc34ba884ba27c411ee8790961c9c5c38a67c9cf Mon Sep 17 00:00:00 2001 From: Alexis King Date: Sun, 4 Nov 2018 10:16:45 -0600 Subject: [PATCH] Reinstate the stop list after #%module-begin performs partial expansion --- .../racket-test-core/tests/racket/module.rktl | 12 +++++++ racket/src/expander/expand/module.rkt | 9 +++--- racket/src/racket/src/startup.inc | 32 +++++++++++-------- 3 files changed, 36 insertions(+), 17 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index a6e2f3667c..ae5df56829 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -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) diff --git a/racket/src/expander/expand/module.rkt b/racket/src/expander/expand/module.rkt index 0ff0f11a9c..69121ce10a 100644 --- a/racket/src/expander/expand/module.rkt +++ b/racket/src/expander/expand/module.rkt @@ -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) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 35d87d30c3..abb35b8a1d 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -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"