diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index 7d46eb35b5..5b9452db09 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -365,11 +365,17 @@ avoids quadratic expansion times when local expansions are nested. Like @racket[local-expand], but @racket[stx] is expanded as a transformer expression instead of a run-time expression. -For @racket['expression] expansion, any -lifted expressions---from calls to + +Any lifted expressions---from calls to @racket[syntax-local-lift-expression] during the expansion of -@racket[stx]---are captured into a @racket[let-values] form in the -result.} +@racket[stx]---are captured in the result. If @racket[context-v] is +@racket['top-level], then lifts are captured in a @racket[begin] form, +otherwise lifts are captured in @racket[let-values] forms. If no +expressions are lifted during expansion, then no @racket[begin] +or @racket[let-values] wrapper is added. + +@history[#:changed "6.5.0.3" @elem{Allow and capture lifts in a + @racket['top-level] context.}]} @defproc[(local-expand/capture-lifts [stx any/c] @@ -887,11 +893,8 @@ Returns @racket[#t] if @racket[(syntax-transforming?)] produces @racket[#t] and a target context is available for lifting expressions (via @racket[syntax-local-lift-expression]), @racket[#f] otherwise. -For example, during an immedate macro expansion triggered by -@racket[local-expand], as opposed to -@racket[local-expand/capture-lifts], @racket[(syntax-transforming?)] -produces @racket[#t] while @racket[(syntax-transforming-with-lifts?)] -produces @racket[#f]. +Currently, @racket[(syntax-transforming?)] implies +@racket[(syntax-transforming-with-lifts?)]. @history[#:added "6.3.0.9"]} diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 410169e3f8..f35fe23962 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -1610,4 +1610,35 @@ ;; ---------------------------------------- +(module check-lift-during-local-transformer-expand racket/base + (require (for-syntax racket/base)) + + (begin-for-syntax + (require (for-syntax racket/base)) + (define-syntax (check stx) + (unless (syntax-transforming-with-lifts?) + (error "expected lifts to be allowed")) + (syntax-local-lift-expression #'foo) + #'1) + (define-syntax (check2 stx) + (unless (syntax-transforming-with-lifts?) + (error "expected lifts to be allowed")) + #'2)) + + (define-syntax (m stx) + (syntax-case stx () + [(_ e f) + (begin + (unless (eq? 'begin + (syntax-e (car (syntax-e (local-transformer-expand #'e 'top-level null))))) + (error "lift failed")) + (when (eq? 'begin + (syntax-e (car (syntax-e (local-transformer-expand #'f 'top-level null))))) + (error "lift introduced unexpected `begin`")) + #'(void))])) + + (m (check) (check2))) + +;; ---------------------------------------- + (report-errs) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index ef742fff15..38cd07921b 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -409,6 +409,15 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com } } +Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env) +{ + while (env && !env->lifts) { + env = env->next; + } + + return env; +} + Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) { return scheme_reverse(SCHEME_VEC_ELS(env->lifts)[0]); @@ -2058,9 +2067,7 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object "not currently transforming", NULL); - while (env && !env->lifts) { - env = env->next; - } + env = scheme_get_env_for_lifts(env); if (env) if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) @@ -2133,9 +2140,7 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object Scheme_Object * scheme_local_lift_context(Scheme_Comp_Env *env) { - while (env && !env->lifts) { - env = env->next; - } + env = scheme_get_env_for_lifts(env); if (!env) return scheme_false; diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index ec3f9ceda5..9020590bc5 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -2256,9 +2256,7 @@ now_transforming_with_lifts(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env = scheme_current_thread->current_local_env; - while (env && !env->lifts) { - env = env->next; - } + env = scheme_get_env_for_lifts(env); if (env) if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index c2a7ca8035..c5bca9ee4a 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -4640,7 +4640,7 @@ static void *expand_k(void) top_intro = p->ku.k.i2; just_to_top = p->ku.k.i3; catch_lifts_key = p->ku.k.p4; - as_local = p->ku.k.i4; /* < 0 => catch lifts to let */ + as_local = p->ku.k.i4; /* < 0 => catch lifts to let; 2 => catch lifts to optional `begin` */ p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; @@ -4725,7 +4725,7 @@ static void *expand_k(void) if ((depth >= 0) || as_local) break; } else { - if (as_local > 0) { + if ((as_local > 0) && (as_local < 2)) { obj = add_lifts_as_begin(obj, scheme_null, env); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(env->observer,obj); } @@ -5096,6 +5096,9 @@ static void update_intdef_chain(Scheme_Object *intdef) static Scheme_Object * do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) +/* catch_lifts == -1 => wrap as `let-values`; + catch_lifts == 1 => `begin`; + catch_lifts == 2 => `begin`, if any */ { Scheme_Comp_Env *env, *orig_env, *adjust_env = NULL, **ip; Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL; @@ -5128,7 +5131,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in kind = SCHEME_MODULE_BEGIN_FRAME; /* just inside module for expanding to `#%module-begin` */ else if (SAME_OBJ(argv[1], top_level_symbol)) { kind = SCHEME_TOPLEVEL_FRAME; - if (catch_lifts < 0) catch_lifts = 0; + if (catch_lifts < 0) catch_lifts = (for_stx ? 2 : 0); if (orig_env->flags & SCHEME_TOPLEVEL_FRAME) adjust_env = orig_env; } else if (SAME_OBJ(argv[1], expression_symbol)) @@ -5372,11 +5375,19 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in } if (catch_lifts_key) { + int observe = 1; if (catch_lifts < 0) xl = scheme_add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0); - else - xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env); - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl); + else { + l = scheme_frame_get_lifts(env); + if (SCHEME_PAIRP(l) || (catch_lifts < 2)) + xl = add_lifts_as_begin(xl, l, env); + else + observe = 0; + } + if (observe) { + SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl); + } } l = xl; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index b46d5fc1f9..0183ba6762 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3170,6 +3170,7 @@ Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_generate_lifts_key(void); Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env); +Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, intptr_t phase,