summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclCmdAH.c31
-rw-r--r--tests/basic.test39
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} {
} {}