* generic/tclExecute.c (INST_FOREACH_STEP4): Re-fetch pointers for

        * tests/foreach.test (foreach-10.1):    the value list each iteration
        of the loop as defense against shimmers.  [Bug 1671087]

3 files changed, 30 insertions, 7 deletions

diff --git a/ChangeLog b/ChangeLog
index 253c4e7..e76ab9e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2007-03-13  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclExecute.c (INST_FOREACH_STEP4):	Re-fetch pointers for
+	* tests/foreach.test (foreach-10.1):	the value list each iteration
+	of the loop as defense against shimmers.  [Bug 1671087]
+
 	* generic/tclVar.c (TclArraySet):	Re-fetch pointers for the list
 	* tests/var.test (var-17.1):	argument of [array set] each time
 	through the loop as defense against possible shimmer issues.
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 59412b8..4fd6dcc 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.94.2.20 2006/11/28 22:20:00 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.21 2007/03/13 16:26:32 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -4052,7 +4052,6 @@ TclExecuteByteCode(interp, codePtr)
 	    int numLists = infoPtr->numLists;
 	    Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
 	    Tcl_Obj *listPtr;
-	    List *listRepPtr;
 	    Var *iterVarPtr, *listVarPtr;
 	    int iterNum, listTmpIndex, listLen, numVars;
 	    int varIndex, valIndex, continueLoop, j;
@@ -4106,15 +4105,23 @@ TclExecuteByteCode(interp, codePtr)
 
 		    listVarPtr = &(compiledLocals[listTmpIndex]);
 		    listPtr = listVarPtr->value.objPtr;
-		    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
-		    listLen = listRepPtr->elemCount;
-			
+
 		    valIndex = (iterNum * numVars);
 		    for (j = 0;  j < numVars;  j++) {
+			Tcl_Obj **elements;
+
+			/*
+			 * The call to TclPtrSetVar might shimmer listPtr,
+			 * so re-fetch pointers every iteration for safety.
+			 * See test foreach-10.1.
+			 */
+
+			Tcl_ListObjGetElements(NULL, listPtr,
+				&listLen, &elements);
 			if (valIndex >= listLen) {
 			    TclNewObj(valuePtr);
 			} else {
-			    valuePtr = listRepPtr->elements[valIndex];
+			    valuePtr = elements[valIndex];
 			}
 			    
 			varIndex = varListPtr->varIndexes[j];
diff --git a/tests/foreach.test b/tests/foreach.test
index ee90ce2..a260576 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: foreach.test,v 1.8.8.2 2007/03/01 10:16:10 dkf Exp $
+# RCS: @(#) $Id: foreach.test,v 1.8.8.3 2007/03/13 16:26:33 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -243,6 +243,18 @@ test foreach-9.1 {compiled empty var list} {
     list [catch { foo } msg] $msg
 } {1 {foreach varlist is empty}}
 
+test foreach-10.1 {foreach: [Bug 1671087]} -setup {
+    proc demo {} {
+        set vals {1 2 3 4}
+        trace add variable x write {string length $vals ;# }
+        foreach {x y} $vals {format $y}
+    }
+} -body {
+    demo
+} -cleanup {
+    rename demo {}
+} -result {}
+
 # cleanup
 catch {unset a}
 catch {unset x}