Added fix for Bug #494348; the [foreach] implementation was doing some

cacheing that didn't seem to be safe, and which wouldn't gain very much
performance either. Removing it fixed the bug.

3 files changed, 39 insertions, 42 deletions

diff --git a/ChangeLog b/ChangeLog
index 53ece91..19e64a3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,16 @@
 2002-01-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
 
+	* tests/basic.test (basic-39.4): Greatly simplified test while
+	still leaving it so that it crashes when run without the fix to
+	the [foreach] implementation.
+	* generic/tclCmdAH.c (Tcl_ForeachObjCmd): Stopped Bug #494348 from
+	happening by not trying to be so clever with cacheing; if nothing
+	untoward is happening anyway, the less efficient technique will
+	only add a few instruction cycles (one function call and a few
+	derefs/assigns per list per iteration, with no change in the
+	number of tests) and if something odd *is* going on, the code is
+	now far more robust.
+
 	* tests/basic.test (basic-39.4): Reproducable script from Bug #494348
 
 2002-01-02  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 1645ad3..489f370 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.16 2001/09/20 01:03:08 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.17 2002/01/03 18:23:47 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1730,24 +1730,23 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
     for (j = 0;  j < maxj;  j++) {
 	for (i = 0;  i < numLists;  i++) {
 	    /*
-	     * If a variable or value list object has been converted to
-	     * another kind of Tcl object, convert it back to a list object
-	     * and refetch the pointer to its element array.
+	     * Refetch the list members; we assume that the sizes are
+	     * the same, but the array of elements might be different
+	     * if the internal rep of the objects has been lost and
+	     * recreated (it is too difficult to accurately tell when
+	     * this happens, which can lead to some wierd crashes,
+	     * like Bug #494348...)
 	     */
 
-	    if (argObjv[1+i*2]->typePtr != &tclListType) {
-		result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
-		        &varcList[i], &varvList[i]);
-		if (result != TCL_OK) {
-		    panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
-		}
+	    result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
+		    &varcList[i], &varvList[i]);
+	    if (result != TCL_OK) {
+		panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
 	    }
-	    if (argObjv[2+i*2]->typePtr != &tclListType) {
-		result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
-	                &argcList[i], &argvList[i]);
-		if (result != TCL_OK) {
-		    panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
-		}
+	    result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+		    &argcList[i], &argvList[i]);
+	    if (result != TCL_OK) {
+		panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
 	    }
 	    
 	    for (v = 0;  v < varcList[i];  v++) {
diff --git a/tests/basic.test b/tests/basic.test
index 251d82e..f088b41 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: basic.test,v 1.13 2002/01/03 11:58:25 dkf Exp $
+# RCS: @(#) $Id: basic.test,v 1.14 2002/01/03 18:23:47 dkf Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -495,32 +495,19 @@ test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of tra
 test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
     testcmdtrace deletetest {set stuff [info tclversion]}
 } $tclvers
-test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace knownBug} {
-    proc inst {args} {}
-    proc Something {} {inst}
-    proc Test {level} {
-	incr level 
-	puts "Test: level = $level"
-	#inst "a"
-	Something ;# you may call inst directly
-	if {$level == 1} {
-	    set instlist {1 2}
-	} else {
-	    set instlist {}
-	}
-	puts "instlist = /$instlist/"
-
-	foreach inst $instlist { 
-	    puts "inst = /$inst/" 
-	    Test $level 
-	}
+test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
+    # Note that the proc call is the same as the variable name, and that
+    # the call can be direct or indirect by way of another procedure
+    proc tracer {args} {}
+    proc tracedLoop {level} {
+	incr level
+	tracer
+	foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
     }
-
-    testcmdtrace tracetest {Test 0}
-} {}
-catch {rename inst {}}
-catch {rename Test {}}
-catch {rename Something {}}
+    testcmdtrace tracetest {tracedLoop 0}
+} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
+catch {rename tracer {}}
+catch {rename tracedLoop {}}
 
 test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
 } {}