fix bug in expand when adjusting the lexical-context info of a locally bound identifer

svn: r5056

collects/tests/mzscheme/stx.ss

@@ -1095,6 +1095,18 @@
 (require @!$m)
 (test '(10 20 #t) '@!$get @!$get)
 
+(unless building-flat-tests?
+  (test '(12)
+        eval
+        (expand
+         #'(let ([b 12])
+             (let-syntax ([goo (lambda (stx)
+                                 #`(let ()
+                                     (define #,(syntax-local-introduce #'b) 1)
+                                     (define z (list b))
+                                     z))])
+               (goo))))))
+  
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test lazy unmarshaling of renamings and module-name resolution
 

src/mzscheme/src/env.c

@@ -2274,7 +2274,13 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
 	    }
 	    /* Looks ok; return a lexical reference */
             if (_lexical_binding_id) {
-              val = scheme_stx_remove_extra_marks(find_id, frame->values[i]);
+              if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME))
+                val = scheme_stx_remove_extra_marks(find_id, frame->values[i],
+                                                    ((frame->flags & SCHEME_CAPTURE_LIFTED)
+                                                     ? NULL
+                                                     : uid));
+              else
+                val = find_id;
               *_lexical_binding_id = val;
             }
 	    if (flags & SCHEME_DONT_MARK_USE)

src/mzscheme/src/schpriv.h

@@ -596,7 +596,8 @@ void scheme_drop_first_rib_rename(Scheme_Object *ro);
 Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
 Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);
 
-Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to);
+Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to,
+                                             Scheme_Object *uid);
 
 #define mzMOD_RENAME_TOPLEVEL 0
 #define mzMOD_RENAME_NORMAL   1

src/mzscheme/src/stxobj.c

@@ -2636,111 +2636,6 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
   }
 }
 
-static Scheme_Object *prune_marks(Scheme_Stx *stx, Scheme_Object *keep_list)
-/* Returns a new wrap */
-{
-  WRAP_POS awl, acur_mark_l, shared_tail_l;
-  Scheme_Object *acur_mark, *w, *save_wraps = scheme_null, *acur_save_wraps = NULL, *shared_tail_save_wraps = NULL;
-  int wrap_c = 0, shared_tail_wrap_c = 0, acur_wrap_c = 0;
-
-  WRAP_POS_INIT(awl, stx->wraps);
-
-  /* Just so they're initialized: */
-  WRAP_POS_COPY(acur_mark_l, awl);
-  WRAP_POS_COPY(shared_tail_l, awl);
-
-  while (1) {
-    /* Skip over renames and cancelled marks: */
-    acur_mark = NULL;
-    while (1) {
-      if (WRAP_POS_END_P(awl))
-	break;
-      w = WRAP_POS_FIRST(awl);
-      if (SCHEME_NUMBERP(w) && IS_POSMARK(WRAP_POS_FIRST(awl))) {
-	if (acur_mark) {
-	  if (SAME_OBJ(acur_mark, w)) {
-	    acur_mark = NULL;
-	    WRAP_POS_INC(awl);
-	  } else
-	    break;
-	} else {
-	  acur_mark = WRAP_POS_FIRST(awl);
-	  WRAP_POS_INC(awl);
-          WRAP_POS_COPY(acur_mark_l, awl);
-          acur_wrap_c = wrap_c;
-          acur_save_wraps = save_wraps;
-	}
-      } else {
-        save_wraps = scheme_make_pair(w, save_wraps);
-        wrap_c++;
-	WRAP_POS_INC(awl);
-      }
-    }
-
-    if (!acur_mark)
-      break;
-
-    /* Same mark? */
-    if (SCHEME_PAIRP(keep_list) && SAME_OBJ(acur_mark, SCHEME_CAR(keep_list))) {
-      save_wraps = scheme_make_pair(acur_mark, save_wraps);
-      wrap_c++;
-      keep_list = SCHEME_CDR(keep_list);
-    } else {
-      /* We need to drop the mark, so shift the shared tail */
-      WRAP_POS_COPY(shared_tail_l, acur_mark_l);
-      shared_tail_save_wraps = acur_save_wraps;
-      shared_tail_wrap_c = acur_wrap_c;
-    }
-  }
-
-  if (!shared_tail_save_wraps) {
-    w = scheme_null;
-    shared_tail_save_wraps = save_wraps;
-    shared_tail_wrap_c = wrap_c;
-  } else {
-    /* save_wraps is the set of wraps (in reverse order) that we want to
-       keep, but there could be a shared tail; build on shared_tail_l
-       with shared_tail_save_wraps: */
-    while (1) {
-      w = WRAP_POS_PLAIN_TAIL(shared_tail_l);
-      if (w)
-        break;
-      shared_tail_save_wraps = scheme_make_pair(WRAP_POS_FIRST(shared_tail_l), 
-                                                shared_tail_save_wraps);
-      shared_tail_wrap_c++;
-      WRAP_POS_INC(shared_tail_l);
-    }
-  }
-
-  if (shared_tail_wrap_c) {
-    Wrap_Chunk *wc;
-    int i;
-
-    wc = MALLOC_WRAP_CHUNK(shared_tail_wrap_c);
-    wc->type = scheme_wrap_chunk_type;
-    wc->len = shared_tail_wrap_c;
-
-    for (i = shared_tail_wrap_c - 1; 
-         !SCHEME_NULLP(shared_tail_save_wraps);
-         shared_tail_save_wraps = SCHEME_CDR(shared_tail_save_wraps), --i) {
-      wc->a[i] = SCHEME_CAR(shared_tail_save_wraps);
-    }
-
-    w = scheme_make_pair((Scheme_Object *)wc, w);
-  }
-
-  /* Construct the new id: */
-  {
-    Scheme_Object *certs;
-    certs = stx->certs;
-    stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
-    stx->wraps = w;
-    stx->certs = certs;
-  }
-  
-  return (Scheme_Object *)stx;
-}
-
 #define QUICK_STACK_SIZE 10
 
 /* Although resolve_env may call itself recursively, the recursion
@@ -3466,7 +3361,8 @@ int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs,
   return 0;
 }
 
-Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to)
+Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to,
+                                             Scheme_Object *uid)
 {
   WRAP_POS aw;
   WRAP_POS bw;
@@ -3475,8 +3371,24 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
   WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
 
   if (!same_marks(&aw, &bw, NULL, NULL)) {
-    return prune_marks((Scheme_Stx *)a,
+    Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
-                       scheme_stx_extract_marks(relative_to));
+    if (uid) {
+      /* Add a rename record: */
+      Scheme_Object *rn;
+      rn = scheme_make_rename(uid, 1);
+      scheme_set_rename(rn, 0, relative_to);
+      wraps = scheme_make_pair(rn, wraps);
+    }
+
+    {
+      Scheme_Stx *stx = (Scheme_Stx *)a;
+      Scheme_Object *certs;
+      certs = stx->certs;
+      stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
+      stx->wraps = wraps;
+      stx->certs = certs;
+      a = (Scheme_Object *)stx;
+    }
    }
 
   return a;