local-transformer-expand: catch lifts in 'top-level mode

Change the one expansion mode as far as I can tell) that disables
lifts so that lifts are now allowed, which means that
`(syntax-transforming?)` implies `(syntax-transforming--with-lifts?)`.

The old documentation incorrectly characterized when lifts
were allowed. Ryan noticed the documentation problem, and that
observation led to this simplication.

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"]}
 

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)

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;

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]))

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;

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,