diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 154d369318..8829121ec7 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -218,6 +218,14 @@ bindings listed in @secref["fully-expanded"] plus the @racket[letrec-syntaxes+values] form and @racket[#%expression] in any expression position. +When @racket[#%plain-module-begin] is not itself in @racket[stop-ids] +and @racket[module*] is in @racket[stop-ids], then the +@racket[#%plain-module-begin] transformer refrains from expanding +@racket[module*] sub-forms. Otherwise, the +@racket[#%plain-module-begin] transformer detects and expands sub-forms +(such as @racket[define-values]) independent of the correspond +identifier's presence in @racket[stop-ids]. + The optional @racket[intdef-ctx] argument must be either @racket[#f], the result of @racket[syntax-local-make-definition-context], or a list of such results. In the latter two cases, lexical information for diff --git a/collects/tests/racket/macro.rktl b/collects/tests/racket/macro.rktl index d73091929e..cdfc23b9ae 100644 --- a/collects/tests/racket/macro.rktl +++ b/collects/tests/racket/macro.rktl @@ -459,7 +459,7 @@ (define q 8) (nab h)) -;; #'module* in sto plist shouldn't add all the rest: +;; #'module* in stop list shouldn't add all the rest: (let () (define-syntax (m stx) (syntax-case stx () [(_ e) @@ -470,6 +470,31 @@ #'(void))])) (m (+ 1 2))) +;; #'module* in stop list should stop: +(module m1-for-local-expand racket/base + (require (for-syntax racket/base)) + (provide (rename-out [mb #%module-begin]) + (except-out (all-from-out racket/base) #%module-begin)) + (define-syntax (mb stx) + (syntax-case stx () + [(_ 10) #'(#%plain-module-begin 10)] + [(_ 11) #'(#%plain-module-begin 11)] + [(_ form ...) + (let ([e (local-expand #'(#%plain-module-begin form ...) + 'module-begin + (list #'module*))]) + (syntax-case e (module module* quote #%plain-app) + [(mod-beg + (#%plain-app + (quote 1) (quote 2)) + (module* q #f 10) + (module* z #f 11)) + 'ok] + [else (error 'test "bad local-expand result: ~s" (syntax->datum e))]) + e)]))) +(module m2-for-local-expand 'm1-for-local-expand + (+ 1 2) + (module* q #f 10) (module* z #f 11)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (module rename-transformer-tests scheme/base diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 7b76acf14a..d62b75e492 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -150,6 +150,7 @@ static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, static void check_formerly_unbound(Scheme_Object *unbounds, Scheme_Comp_Env *env); static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx); +static int is_modulestar_stop(Scheme_Comp_Env *env); static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p); @@ -7727,8 +7728,18 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env (void)do_module_execute(o, env->genv, 0, 1, root_module_name); } - expanded_modules = expand_submodules(rec, drec, env, bxs->saved_submodules, 1, bxs, !rec[drec].comp); - + if (!rec[drec].comp && (is_modulestar_stop(env))) { + Scheme_Object *l = bxs->saved_submodules; + expanded_modules = NULL; + while (!SCHEME_NULLP(l)) { + expanded_modules = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(l)), + expanded_modules); + l = SCHEME_CDR(l); + } + bxs->saved_submodules = scheme_null; + } else + expanded_modules = expand_submodules(rec, drec, env, bxs->saved_submodules, 1, bxs, !rec[drec].comp); + if (!rec[drec].comp) { (void)fixup_expanded(expanded_l, expanded_modules, 0, MODULE_MODFORM_KIND); } @@ -8936,6 +8947,20 @@ static void check_formerly_unbound(Scheme_Object *unbounds, } } +static int is_modulestar_stop(Scheme_Comp_Env *env) +{ + Scheme_Object *p; + p = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, scheme_sys_wraps(env), 0, 0); + p = scheme_lookup_binding(p, env, + (SCHEME_NULL_FOR_UNBOUND + + SCHEME_DONT_MARK_USE + + SCHEME_ENV_CONSTANTS_OK + + (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)), + env->in_modidx, + NULL, NULL, NULL, NULL); + return (scheme_get_stop_expander() == p); +} + static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx) { Scheme_Object *stop, *w, *s;