fix expansion loop in a definition context

Add the current definition context's scope to any expression that is
produced by macro expansion before trying to expand again, in case the
expansion needs to refer to a definition introduced by a previous
expansion.

Previously, the scope was added before any expansion and after any
expansion, but that misses intermediate points.

The old expander had this bug, too (some of the new tests fail there),
but it showed up less often and was sometimes considered correct, for
various reasons.

pkgs/racket-test-core/tests/racket/macro.rktl

@@ -1171,6 +1171,93 @@
        
        ((mylam (x) (x 1 2)) 'any))))))
 
+;; ----------------------------------------
+;; Make sure an internal-definition context expansion
+;; propagates the context's scope while expanding an expression:
+;; (Test from Spencer Florence)
+
+(module check-intfdef-expansion-scope racket/base
+  (require (for-syntax syntax/parse
+                       racket/base))
+
+  ;; a standard context for identifiers
+  (define-for-syntax ctx #'ctx)
+
+  ;; create an ID with the context `ctx`, and the current
+  ;; expander mark (so that the mark is canceled later),
+  ;; and the location loc
+  (define-for-syntax (make-id loc)
+    (syntax-local-introduce
+     (datum->syntax ctx 'id loc)))
+
+  ;; This introduces a binding
+  (define-syntax (def stx)
+    (syntax-parse stx
+      [(def)
+       (with-syntax ([id (make-id #'here)])
+         #'(define id 5))]))
+
+  ;; this attempts to use the binding introduced by `def`
+  (define-syntax (use stx)
+    (syntax-parse stx
+      [(use)
+       (with-syntax ([id (make-id #'here)])
+         #'id)]))
+
+  (let ()
+    (def)
+    (use)))
+
+;; ----------------------------------------
+;; Similar to preceding, but at module level using an initialy
+;; empty scope set:
+
+(module check-module-recur-expansion-scope racket/kernel
+  (#%require racket/base)
+  (require (for-syntax racket/base
+                       syntax/parse))
+  ;; empty context:
+  (define-for-syntax ctx (datum->syntax #f 'ctx))
+  (define-for-syntax (make-id loc)
+    (syntax-local-introduce
+     (datum->syntax ctx 'id loc)))
+  (define-syntax (def stx)
+    (syntax-parse stx
+      [(def)
+       (with-syntax ([id (make-id #'here)])
+         #'(define-syntax-rule (id) (define x 1)))]))
+  (define-syntax (use stx)
+    (syntax-parse stx
+      [(use)
+       (with-syntax ([id (make-id #'here)])
+         #'(id))]))
+  (begin
+    (def)
+    (use)))
+
+;; Module body is expanded with `local-expand`:
+(module check-module-local-expand-recur-expansion-scope racket/base
+  (require (for-syntax racket/base
+                       syntax/parse))
+  ;; empty context:
+  (define-for-syntax ctx (datum->syntax #f 'ctx))
+  (define-for-syntax (make-id loc)
+    (syntax-local-introduce
+     (datum->syntax ctx 'id loc)))
+  (define-syntax (def stx)
+    (syntax-parse stx
+      [(def)
+       (with-syntax ([id (make-id #'here)])
+         #'(define-syntax-rule (id) (define x 1)))]))
+  (define-syntax (use stx)
+    (syntax-parse stx
+      [(use)
+       (with-syntax ([id (make-id #'here)])
+         #'(id))]))
+  (begin
+    (def)
+    (use)))
+
 ;; ----------------------------------------
 
 (report-errs)

pkgs/racket-test/tests/units/test-unit.rkt

@@ -1811,6 +1811,26 @@
         (define-values/invoke-unit u@ (import) (export s^))
         x))
 
+;; ----------------------------------------
+;; May sure unit body expansion doesn't mangle context:
+
+(test 5
+      (invoke-unit
+       (let ([x 5])
+         (define-syntax-rule (m) x)
+         (unit (import) (export)
+           (define x 6)
+           (m)))))
+
+(test 5
+      (invoke-unit
+       (let-syntax ([x (syntax-rules ()
+                         [(_) 5])])
+         (define-syntax-rule (m) (x))
+         (unit (import) (export)
+           (define (x) 6)
+           (m)))))
+
 ;; ----------------------------------------
 
 ;; Make sure that right-hand side of a `define-values`

racket/src/racket/src/compile.c

@@ -4964,6 +4964,12 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
   form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope);
   SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
 
+  if (env->expand_result_adjust) {
+    Scheme_Expand_Result_Adjust_Proc adjust;
+    adjust = env->expand_result_adjust;
+    form = adjust(form, env->expand_result_adjust_arg);
+  }
+
   if (rec[drec].comp)
     goto top;
   else {
@@ -5640,6 +5646,11 @@ static Scheme_Object *beginify(Scheme_Comp_Env *env, Scheme_Object *lst)
                                 0, 0);
 }
 
+static Scheme_Object *add_scope_at_arbitrary_phase(Scheme_Object *stx, Scheme_Object *rib)
+{
+  return scheme_stx_add_scope(stx, rib, scheme_make_integer(0));
+}
+
 static Scheme_Object *
 compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
                      Scheme_Compile_Expand_Info *rec, int drec,
@@ -5685,10 +5696,13 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
                                      env);
   env->intdef_name = ectx;
 
+  env->expand_result_adjust = add_scope_at_arbitrary_phase;
+  env->expand_result_adjust_arg = rib;
+
   forms = scheme_datum_to_syntax(forms, scheme_false, scheme_false, 0, 0);
 
   old = forms;
-  forms = scheme_stx_add_scope(forms, rib, scheme_env_phase(env->genv));
+  forms = add_scope_at_arbitrary_phase(forms, rib);
   SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer, forms, old);
 
  try_again:
@@ -5709,16 +5723,10 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
     is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms));
 
     result = forms;
-    old = first;
 
     /* Check for macro expansion, which could mask the real
        define-values, define-syntax, etc.: */
     first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last);
-
-    if (!SAME_OBJ(first, old)) {
-      old = first;
-      first = scheme_stx_add_scope(first, rib, scheme_env_phase(env->genv));
-    }
     
     if (SAME_OBJ(gval, scheme_begin_syntax)) {
       /* Inline content */
@@ -5925,6 +5933,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  /* Remember extended environment */
           env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, frame_scopes, new_env);
           env->intdef_name = ectx;
+          env->expand_result_adjust = add_scope_at_arbitrary_phase;
+          env->expand_result_adjust_arg = rib;
 	}
 
       define_try_again:

racket/src/racket/src/eval.c

@@ -3972,7 +3972,7 @@ static void *compile_k(void)
   Resolve_Prefix *rp;
   Resolve_Info *ri;
   Optimize_Info *oi;
-  Scheme_Object *gval, *insp;
+  Scheme_Object *gval, *insp, *rib;
   Scheme_Comp_Env *cenv;
 
   form = (Scheme_Object *)p->ku.k.p1;
@@ -3992,7 +3992,9 @@ static void *compile_k(void)
   /* Renamings for requires: */
   if (rename) {
     form = scheme_top_introduce(form, genv);
-  }
+    rib = genv->stx_context;
+  } else
+    rib = NULL;
 
   tl_queue = scheme_null;
 
@@ -4036,6 +4038,11 @@ static void *compile_k(void)
                                SCHEME_TOPLEVEL_FRAME
                                | SCHEME_KEEP_SCOPES_FRAME);
 
+    if (rib) {
+      cenv->expand_result_adjust = scheme_stx_push_introduce_module_context;
+      cenv->expand_result_adjust_arg = rib;
+    }
+
     if (for_eval) {
       /* Need to look for top-level `begin', and if we
 	 find one, break it up to eval first expression
@@ -4833,9 +4840,9 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_O
   return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0);
 }
 
-static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming, Scheme_Object *phase)
+static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming)
 {
-  Scheme_Object *rl = renaming;
+  Scheme_Object *rl = renaming, *phase = scheme_make_integer(0);
 
   if (SCHEME_PAIRP(renaming)) {
     while (!SCHEME_NULLP(rl)) {
@@ -4877,7 +4884,7 @@ 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)
 {
-  Scheme_Comp_Env *env, *orig_env, **ip;
+  Scheme_Comp_Env *env, *orig_env, *adjust_env = NULL, **ip;
   Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL;
   int cnt, pos, kind, is_modstar;
   int bad_sub_env = 0, bad_intdef = 0, keep_ref_ids = 0;
@@ -4900,9 +4907,10 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
 
   if (for_expr)
     kind = 0; /* expression */
-  else if (!for_stx && SAME_OBJ(argv[1], module_symbol))
+  else if (!for_stx && SAME_OBJ(argv[1], module_symbol)) {
     kind = SCHEME_MODULE_FRAME | SCHEME_USE_SCOPES_TO_NEXT; /* module body */
-  else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol))
+    adjust_env = orig_env;
+  } else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol))
     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;
@@ -4988,6 +4996,12 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
 					 | kind),
 				     NULL,
                                      env);
+
+  if (adjust_env && adjust_env->expand_result_adjust) {
+    env->expand_result_adjust = adjust_env->expand_result_adjust;
+    env->expand_result_adjust_arg = adjust_env->expand_result_adjust_arg;
+  }
+  
   if (catch_lifts < 0) {
     /* Note: extra frames can get inserted after env by pair_lifted */
     ip = MALLOC_N(Scheme_Comp_Env *, 1);
@@ -5090,8 +5104,11 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
   }
 
-  if (renaming)
+  if (renaming) {
-    l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
+    l = add_intdef_renamings(l, renaming);
+    env->expand_result_adjust = add_intdef_renamings;
+    env->expand_result_adjust_arg = renaming;
+  }
 
   SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
 
@@ -5148,7 +5165,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
 
   if (renaming)
-    l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
+    l = add_intdef_renamings(l, renaming);
 
   if (for_expr) {
     /* Package up expanded expr with the environment. */

racket/src/racket/src/module.c

@@ -8682,6 +8682,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
 
   rn_set = env->genv->stx_context;
 
+  xenv->expand_result_adjust = introduce_to_module_context;
+  xenv->expand_result_adjust_arg = rn_set;
+    
   vec = get_table(bxs->tables, scheme_make_integer(phase));
   if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[0]))
     SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel;

racket/src/racket/src/mzmark_compenv.inc

@@ -25,6 +25,8 @@ static int mark_comp_env_MARK(void *p, struct NewGC *gc) {
   gcMARK2(e->use, gc);
   gcMARK2(e->lifts, gc);
 
+  gcMARK2(e->expand_result_adjust_arg, gc);
+
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }
@@ -49,6 +51,8 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) {
   gcFIXUP2(e->use, gc);
   gcFIXUP2(e->lifts, gc);
 
+  gcFIXUP2(e->expand_result_adjust_arg, gc);
+
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }

racket/src/racket/src/mzmarksrc.c

@@ -1269,6 +1269,8 @@ mark_comp_env {
   gcMARK2(e->use, gc);
   gcMARK2(e->lifts, gc);
 
+  gcMARK2(e->expand_result_adjust_arg, gc);
+
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }

racket/src/racket/src/schpriv.h

@@ -2547,6 +2547,8 @@ typedef struct Comp_Prefix
   Scheme_Hash_Table *stxes;     /* syntax objects */
 } Comp_Prefix;
 
+typedef Scheme_Object *(*Scheme_Expand_Result_Adjust_Proc)(Scheme_Object *stx, Scheme_Object *arg);
+
 typedef struct Scheme_Comp_Env
 {
   MZTAG_IF_REQUIRED
@@ -2579,6 +2581,9 @@ typedef struct Scheme_Comp_Env
   Scheme_Hash_Tree *skip_table; /* for jumping ahead in the chain */
   int skip_depth;                /* depth in simple frames, used to trigger skip_table creation */
 
+  Scheme_Expand_Result_Adjust_Proc expand_result_adjust;
+  Scheme_Object *expand_result_adjust_arg;
+
   struct Scheme_Comp_Env *next;
 } Scheme_Comp_Env;