diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 31 | ||||
| -rw-r--r-- | tests/basic.test | 39 |
3 files changed, 39 insertions, 42 deletions
@@ -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} { } {} |