change internal definition expansion, simplifying, fixing douplicate-id checking, and fixing binding resolution through extensible ribs

svn: r12563

src/mzscheme/src/env.c

@@ -2123,7 +2123,8 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
   }
 
   while (env != upto) {
-    if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
+    if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME 
+                        | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
       int i, count;
       
       /* How many slots filled in the frame so far?  This can change
@@ -2311,6 +2312,26 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
 	    stx = scheme_add_rename(stx, l);
 	}
       }
+    } else if (env->flags & SCHEME_INTDEF_SHADOW) {
+      /* Just extract existing uids from identifiers, and don't need to
+         add renames to syntax objects. */
+      if (!env->uids) {
+        Scheme_Object **uids, *uid;
+        int i;
+        
+        uids = MALLOC_N(Scheme_Object *, env->num_bindings);
+        env->uids = uids;
+        
+        for (i = env->num_bindings; i--; ) {
+          uid = scheme_stx_moduleless_env(env->values[i]);
+          if (SCHEME_FALSEP(uid))
+            scheme_signal_error("intdef shadow binding is #f for %d/%s",
+                                SCHEME_TYPE(env->values[i]),
+                                scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), 
+                                                       NULL));
+          env->uids[i] = uid;
+        }
+      }
     }
 
     env = env->next;
@@ -2446,7 +2467,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
 	if (frame->values[i]) {
 	  if (frame->uids) 
 	    uid = frame->uids[i];
-	  if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
+          if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
 	      && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase))
 		  || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)
 		      && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym))

src/mzscheme/src/error.c

@@ -778,7 +778,7 @@ scheme_signal_error (const char *msg, ...)
   if (scheme_current_thread->current_local_env) {
     char *s2 = " [during expansion]";
     strcpy(buffer + len, s2);
-    len = strlen(s2);
+    len += strlen(s2);
   }
 
   buffer[len] = 0;

src/mzscheme/src/eval.c

@@ -4563,6 +4563,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
     /* should be always NULL */
     dest[i].observer = src[drec].observer;
     dest[i].pre_unwrapped = 0;
+    dest[i].env_already = 0;
   }
 }
 
@@ -4581,6 +4582,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
     dest[i].certs = src[drec].certs;
     dest[i].observer = src[drec].observer;
     dest[i].pre_unwrapped = 0;
+    dest[i].env_already = 0;
   }
 }
 
@@ -4603,6 +4605,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
   lam[dlrec].certs = src[drec].certs;
   lam[dlrec].observer = src[drec].observer;
   lam[dlrec].pre_unwrapped = 0;
+  lam[dlrec].env_already = 0;
 }
 
 void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
@@ -4850,6 +4853,7 @@ static void *compile_k(void)
     rec.certs = NULL;
     rec.observer = NULL;
     rec.pre_unwrapped = 0;
+    rec.env_already = 0;
 
     cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
 
@@ -6289,7 +6293,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  if (!SCHEME_STX_SYMBOLP(var))
 	    scheme_wrong_syntax(NULL, var, first, 
 				"name must be an identifier");
-	  scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
+	  // scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
 	  vars = SCHEME_STX_CDR(vars);
 	  cnt++;
 	}
@@ -6359,6 +6363,16 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	    scheme_set_local_syntax(cnt++, a, scheme_false, new_env);
 	  }
 
+	  /* Extend shared rib with renamings */
+	  scheme_add_env_renames(rib, new_env, env);
+
+          /* Check for duplicates after extending the rib with renamings,
+             since the renamings properly track marks. */
+          for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
+	    a = SCHEME_STX_CAR(l);
+            scheme_dup_symbol_check(&r, "internal definition", a, "binding", first);
+          }
+
 	  if (!is_val) {
 	    /* Evaluate and bind syntaxes */
 	    scheme_prepare_exp_env(new_env->genv);
@@ -6371,9 +6385,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 				 &pos);
 	  }
 
-	  /* Extend shared rib with renamings */
-	  scheme_add_env_renames(rib, new_env, env);
-	  
 	  /* Remember extended environment */
 	  SCHEME_PTR1_VAL(ctx) = new_env;
 	  env = new_env;
@@ -6441,6 +6452,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
     }
 
     if (!more) {
+      /* We've converted to a letrec or letrec-values+syntaxes */
+      rec[drec].env_already = 1;
+
       if (rec[drec].comp) {
 	result = scheme_compile_expr(result, env, rec, drec);
         return scheme_make_pair(result, scheme_null);
@@ -8720,6 +8734,7 @@ static void *expand_k(void)
     erec1.certs = certs;
     erec1.observer = observer;
     erec1.pre_unwrapped = 0;
+    erec1.env_already = 0;
 
     if (catch_lifts_key)
       scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
@@ -9201,7 +9216,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     l = scheme_add_rename(l, renaming);
 
   if (for_expr) {
-    /* Package up expanded expr with the enviornment. */
+    /* Package up expanded expr with the environment. */
     while (1) {
       if (orig_env->flags & SCHEME_FOR_STOPS)
         orig_env = orig_env->next;
@@ -9552,6 +9567,7 @@ local_eval(int argc, Scheme_Object **argv)
     rec.certs = certs;
     rec.observer = observer;
     rec.pre_unwrapped = 0;
+    rec.env_already = 0;
     
     /* Evaluate and bind syntaxes */
     expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);

src/mzscheme/src/module.c

@@ -5773,6 +5773,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	erec1.certs = rec[drec].certs;
         erec1.observer = rec[drec].observer;
         erec1.pre_unwrapped = 0;
+        erec1.env_already = 0;
 	e = scheme_expand_expr(e, xenv, &erec1, 0);	
       }
 
@@ -5975,6 +5976,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  mrec.certs = rec[drec].certs;
           mrec.observer = NULL;
           mrec.pre_unwrapped = 0;
+          mrec.env_already = 0;
 
 	  if (!rec[drec].comp) {
 	    Scheme_Expand_Info erec1;
@@ -5984,6 +5986,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	    erec1.certs = rec[drec].certs;
             erec1.observer = rec[drec].observer;
             erec1.pre_unwrapped = 0;
+            erec1.env_already = 0;
 	    SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
 	    code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
 	  }

src/mzscheme/src/schpriv.h

@@ -1837,6 +1837,7 @@ typedef struct Scheme_Compile_Expand_Info
   char resolve_module_ids;
   char pre_unwrapped;
   int depth;
+  int env_already;
 } Scheme_Compile_Expand_Info;
 
 typedef Scheme_Compile_Expand_Info Scheme_Compile_Info;
@@ -2301,6 +2302,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
 #define SCHEME_FOR_STOPS 128
 #define SCHEME_FOR_INTDEF 256
 #define SCHEME_CAPTURE_LIFTED 512
+#define SCHEME_INTDEF_SHADOW 1024
 
 /* Flags used with scheme_static_distance */
 #define SCHEME_ELIM_CONST 1

src/mzscheme/src/stxobj.c

@@ -2982,12 +2982,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
   return scheme_false;
 }
 
-XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
+XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
-				     Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
 /* Compares the marks in two wraps lists. A result of 2 means that the
-   result depended on a barrier env. Use #f for barrier_env
+   result depended on a barrier env. For a rib-based renaming, we need
-   to treat no rib envs as barriers; we check for barrier_env only in ribs
+   to check only up to the rib, and the barrier effect important for
-   because simpliciation eliminates the need for these checks(?). */
+   when a rib-based renaming is layered with another renaming (such as
+   when an internal-definition-base local-expand is used to form a new
+   set of bindings, as in the unit form); simplification cleans up the
+   layers, so that we only need to check in ribs. */
 {
   WRAP_POS awl;
   WRAP_POS bwl;
@@ -3015,9 +3017,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
 	  WRAP_POS_INC(awl);
 	}
       } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
-	if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) {
+	if (SCHEME_FALSEP(barrier_env)) {
-	  WRAP_POS_INC(awl);
-	} else if (SCHEME_FALSEP(barrier_env)) {
 	  WRAP_POS_INC(awl);
 	} else {
 	  /* See if the barrier environment is in this rib. */
@@ -3054,9 +3054,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
 	  WRAP_POS_INC(bwl);
 	}
       } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
-	if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) {
+	if (SCHEME_FALSEP(barrier_env)) {
-	  WRAP_POS_INC(bwl);
-	} else if (SCHEME_FALSEP(barrier_env)) {
 	  WRAP_POS_INC(bwl);
 	} else {
 	  /* See if the barrier environment is in this rib. */
@@ -3665,15 +3663,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 		       && !no_lexical)) {
       /* Lexical rename: */
       Scheme_Object *rename, *renamed;
-      int ri, c, istart, iend, is_rib;
+      int ri, c, istart, iend;
+      Scheme_Lexical_Rib *is_rib;
 
       if (rib) {
 	rename = rib->rename;
+	is_rib = rib;
 	rib = rib->next;
-	is_rib = 1;
       } else {
 	rename = WRAP_POS_FIRST(wraps);
-	is_rib = 0;
+	is_rib = NULL;
       }
 
       c = SCHEME_RENAME_LEN(rename);
@@ -3735,7 +3734,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	      {
 		WRAP_POS w2;
 		WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
-		same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
+		same = same_marks(&w2, &wraps, other_env);
                 if (!same)
                   EXPLAIN(printf("Different marks\n"));
 	      }
@@ -3755,7 +3754,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 		o_rename_stack = CONS(CONS(other_env, envname),
 				      o_rename_stack);
 	      }
-	      rib = NULL; /* skip rest of rib (if any) */
+              if (is_rib) {
+                /* skip rest of rib (if any) and future instances of the same rib */
+                rib = NULL;
+                skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
+              }
 	    }
 
 	    break;
@@ -4092,7 +4095,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
     WRAP_POS bw;
     WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
     WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
-    if (!same_marks(&aw, &bw, ae, NULL))
+    if (!same_marks(&aw, &bw, ae))
       return 0;
   }
 
@@ -4277,7 +4280,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
   WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
   WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
 
-  if (!same_marks(&aw, &bw, NULL, NULL)) {
+  if (!same_marks(&aw, &bw, scheme_false)) {
     Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
     if (uid) {
       /* Add a rename record: */
@@ -4647,7 +4650,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
 
               /* Check marks (now that we have the correct barriers). */
 	      WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
-	      if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) {
+	      if (!same_marks(&w2, &w, other_env)) {
 		other_env = NULL;
 	      }
 
@@ -4699,7 +4702,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
               }
 	    } else {
 	      WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
-	      if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib))
+	      if (same_marks(&w2, &w, scheme_false))
                 ok = SCHEME_VEC_ELS(v)[0];
 	      else
 		ok = NULL;
@@ -6759,7 +6762,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv)
   WRAP_POS_INIT(awl, stx->wraps);
   WRAP_POS_INIT_END(ewl);
 
-  if (same_marks(&awl, &ewl, scheme_false, NULL))
+  if (same_marks(&awl, &ewl, scheme_false))
     return scheme_true;
   else
     return scheme_false;

src/mzscheme/src/syntax.c

@@ -4092,6 +4092,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
   Scheme_Object *first = NULL;
   Scheme_Compiled_Let_Value *last = NULL, *lv;
   DupCheckRecord r;
+  int rec_env_already = rec[drec].env_already;
 
   i = scheme_stx_proper_list_length(form);
   if (i < 3)
@@ -4160,8 +4161,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
   names = MALLOC_N(Scheme_Object *, num_bindings);
   if (frame_already)
     frame = frame_already;
-  else
+  else {
-    frame = scheme_new_compilation_frame(num_bindings, 0, origenv, rec[drec].certs);
+    frame = scheme_new_compilation_frame(num_bindings, 
+                                         (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
+                                         origenv, 
+                                         rec[drec].certs);
+    if (rec_env_already)
+      frame_already = frame;
+  }
   env = frame;
 
   recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
@@ -4172,7 +4179,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
 
   defname = scheme_check_name_property(form, defname);
   
-  if (!star) {
+  if (!star && !frame_already) {
     scheme_begin_dup_symbol_check(&r, env);
   }
 
@@ -4216,7 +4223,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
       names[k++] = name;
     }
     
-    if (!star) {
+    if (!star && !frame_already) {
       for (m = pre_k; m < k; m++) {
 	scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
       }
@@ -4319,6 +4326,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   Scheme_Comp_Env *use_env, *env;
   Scheme_Expand_Info erec1;
   DupCheckRecord r;
+  int rec_env_already = erec[drec].env_already;
 
   vars = SCHEME_STX_CDR(form);
 
@@ -4385,8 +4393,8 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   }
   
   /* Note: no more letstar handling needed after this point */
-
+  if (!env_already && !rec_env_already)
-  scheme_begin_dup_symbol_check(&r, origenv);
+    scheme_begin_dup_symbol_check(&r, origenv);
 
   vlist = scheme_null;
   vs = vars;
@@ -4405,15 +4413,18 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
     {
       DupCheckRecord r2;
       Scheme_Object *names = name;
-      scheme_begin_dup_symbol_check(&r2, origenv);
+      if (!env_already && !rec_env_already)
+        scheme_begin_dup_symbol_check(&r2, origenv);
       while (SCHEME_STX_PAIRP(names)) {
 	name = SCHEME_STX_CAR(names);
 
 	scheme_check_identifier(NULL, name, NULL, origenv, form);
 	vlist = cons(name, vlist);
 
-	scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
+        if (!env_already && !rec_env_already) {
-	scheme_dup_symbol_check(&r, NULL, name, "binding", form);
+          scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
+          scheme_dup_symbol_check(&r, NULL, name, "binding", form);
+        }
 	
 	names = SCHEME_STX_CDR(names);
       }
@@ -4430,7 +4441,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
   if (env_already)
     env = env_already;
   else
-    env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs);
+    env = scheme_add_compilation_frame(vlist, 
+                                       origenv, 
+                                       (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
+                                       erec[drec].certs);
 
   if (letrec)
     use_env = env;
@@ -5526,6 +5540,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
   rec1.certs = rec[drec].certs;
   rec1.observer = NULL;
   rec1.pre_unwrapped = 0;
+  rec1.env_already = 0;
 
   if (for_stx) {
     names = defn_targets_syntax(names, exp_env, &rec1, 0);
@@ -5717,6 +5732,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
   mrec.certs = certs;
   mrec.observer = NULL;
   mrec.pre_unwrapped = 0;
+  mrec.env_already = 0;
 
   a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
 
@@ -5805,9 +5821,11 @@ do_letrec_syntaxes(const char *where,
   Scheme_Object *form, *bindings, *var_bindings, *body, *v;
   Scheme_Object *names_to_disappear;
   Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
-  int cnt, stx_cnt, var_cnt, i, j, depth, saw_var;
+  int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
   DupCheckRecord r;
 
+  env_already = rec[drec].env_already;
+
   form = SCHEME_STX_CDR(forms);
   if (!SCHEME_STX_PAIRP(form))
     scheme_wrong_syntax(NULL, NULL, forms, NULL);
@@ -5823,7 +5841,10 @@ do_letrec_syntaxes(const char *where,
 
   scheme_rec_add_certs(rec, drec, forms);
 
-  stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
+  if (env_already)
+    stx_env = origenv;
+  else
+    stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
 
   rhs_env = stx_env;
 
@@ -5846,8 +5867,8 @@ do_letrec_syntaxes(const char *where,
   else
     names_to_disappear = NULL;
 
-
+  if (!env_already)
-  scheme_begin_dup_symbol_check(&r, stx_env);
+    scheme_begin_dup_symbol_check(&r, stx_env);
 
   /* Pass 1: Check and Rename */
 
@@ -5881,8 +5902,10 @@ do_letrec_syntaxes(const char *where,
 
       for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
 	a = SCHEME_STX_CAR(l);
-	scheme_check_identifier(where, a, NULL, stx_env, forms);
+        if (!env_already) {
-	scheme_dup_symbol_check(&r, where, a, "binding", forms);
+          scheme_check_identifier(where, a, NULL, stx_env, forms);
+          scheme_dup_symbol_check(&r, where, a, "binding", forms);
+        }
 	cnt++;
       }
       if (i)
@@ -5895,30 +5918,35 @@ do_letrec_syntaxes(const char *where,
       var_cnt = cnt - stx_cnt;
   }
 
-  scheme_add_local_syntax(stx_cnt, stx_env);
+  if (!env_already)
-  if (saw_var)
+    scheme_add_local_syntax(stx_cnt, stx_env);
-    var_env = scheme_new_compilation_frame(var_cnt, 0, stx_env, rec[drec].certs);
+  
-  else
+  if (saw_var) {
+    var_env = scheme_new_compilation_frame(var_cnt, 
+                                           (env_already ? SCHEME_INTDEF_SHADOW : 0), 
+                                           stx_env, 
+                                           rec[drec].certs);
+  } else
     var_env = NULL;
 
-  for (i = 0; i < (var_env ? 2 : 1) ; i++) {
+  for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
     cnt = (i ? var_cnt : stx_cnt);
     if (cnt > 0) {
-      /* Add new syntax names to the environment: */
+      /* Add new syntax/variable names to the environment: */
       j = 0;
       for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
-	Scheme_Object *a, *l;
+        Scheme_Object *a, *l;
 	
-	a = SCHEME_STX_CAR(v);
+        a = SCHEME_STX_CAR(v);
-	for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
+        for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
-	  a = SCHEME_STX_CAR(l);
+          a = SCHEME_STX_CAR(l);
-	  if (i) {
+          if (i) {
-	    /* In compile mode, this will get re-written by the letrec compiler.
+            /* In compile mode, this will get re-written by the letrec compiler.
-	       But that's ok. We need it now for env_renames. */
+               But that's ok. We need it now for env_renames. */
-	    scheme_add_compilation_binding(j++, a, var_env);
+            scheme_add_compilation_binding(j++, a, var_env);
-	  } else
+          } else
-	    scheme_set_local_syntax(j++, a, NULL, stx_env);
+            scheme_set_local_syntax(j++, a, NULL, stx_env);
-	}
+        }
       }
     }
   }
@@ -5949,29 +5977,31 @@ do_letrec_syntaxes(const char *where,
   
   scheme_prepare_exp_env(stx_env->genv);
 
-  i = 0;
+  if (!env_already) {
+    i = 0;
 
-  for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
+    for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
-    Scheme_Object *a, *names;
+      Scheme_Object *a, *names;
 
-    SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
+      SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
 
-    a = SCHEME_STX_CAR(v);
+      a = SCHEME_STX_CAR(v);
-    names = SCHEME_STX_CAR(a);
+      names = SCHEME_STX_CAR(a);
-    a = SCHEME_STX_CDR(a);
+      a = SCHEME_STX_CDR(a);
-    a = SCHEME_STX_CAR(a);
+      a = SCHEME_STX_CAR(a);
 
-    scheme_bind_syntaxes(where, names, a,
+      scheme_bind_syntaxes(where, names, a,
-                         stx_env->genv->exp_env,
+                           stx_env->genv->exp_env,
-                         stx_env->insp,
+                           stx_env->insp,
-                         rec, drec,
+                           rec, drec,
-                         stx_env, rhs_env, 
+                           stx_env, rhs_env, 
-                         &i);
+                           &i);
+    }
   }
 
   SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
 
-  if (names_to_disappear) {
+  if (!env_already && names_to_disappear) {
     /* Need to add renaming for disappeared bindings. If they
        originated for internal definitions, then we need both
        pre-renamed and renamed, since some might have been