diff options
| -rw-r--r-- | generic/tclCompCmds.c | 90 | ||||
| -rw-r--r-- | tests/for.test | 32 | ||||
| -rw-r--r-- | tests/foreach.test | 4 | ||||
| -rw-r--r-- | tests/if.test | 69 | ||||
| -rw-r--r-- | tests/while.test | 15 |
5 files changed, 167 insertions, 43 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 73c4840..5e24b97 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.13 2001/09/01 00:51:31 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.14 2001/09/19 18:17:54 hobbs Exp $ */ #include "tclInt.h" @@ -561,6 +561,18 @@ TclCompileForCmd(interp, parsePtr, envPtr) } /* + * Bail out also if the body or the next expression require substitutions + * in order to insure correct behaviour [Bug 219166] + */ + + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + return TCL_OUT_LINE_COMPILE; + } + + /* * Create ExceptionRange records for the body and the "next" command. * The "next" command's ExceptionRange supports break but not continue * (and has a -1 continueOffset). @@ -609,8 +621,6 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Compile the loop body. */ - nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); envPtr->exceptArrayPtr[bodyRange].codeOffset = (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, bodyTokenPtr+1, @@ -805,6 +815,19 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) } /* + * Bail out if the body requires substitutions + * in order to insure correct behaviour [Bug 219166] + */ + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + } + bodyTokenPtr = tokenPtr; + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -946,7 +969,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) loopIndex++; } } - bodyTokenPtr = tokenPtr; /* * Initialize the temporary var that holds the count of loop iterations. @@ -1195,6 +1217,23 @@ TclCompileIfCmd(interp, parsePtr, envPtr) char *word; char buffer[100]; + /* + * Only compile the "if" command if all arguments are simple + * words, in order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + tokenPtr += 2; + } + + TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); maxDepth = 0; @@ -1207,7 +1246,6 @@ TclCompileIfCmd(interp, parsePtr, envPtr) tokenPtr = parsePtr->tokenPtr; wordIdx = 0; - numWords = parsePtr->numWords; while (wordIdx < numWords) { /* * Stop looping if the token isn't "if" or "elseif". @@ -2398,8 +2436,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) return TCL_OK; } case STR_MATCH: { - int i, length, nocase = 0, depth = 0; - char *str; + int i, length, exactMatch = 0, nocase = 0, depth = 0; + char c, *str; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { Tcl_SetResult(interp, "wrong # args: should be " @@ -2418,7 +2456,7 @@ TclCompileStringCmd(interp, parsePtr, envPtr) strncmp(str, "-nocase", (size_t) length) == 0) { nocase = 1; } else { - char c = str[length]; + c = str[length]; str[length] = '\0'; Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", str, "\": must be -nocase", @@ -2428,14 +2466,27 @@ TclCompileStringCmd(interp, parsePtr, envPtr) } varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - TclEmitPush(TclRegisterLiteral(envPtr, (nocase ? "1" : "0"), - 1, 0), envPtr); - depth++; for (i = 0; i < 2; i++) { if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterLiteral(envPtr, - varTokenPtr[1].start, varTokenPtr[1].size, + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if (!nocase && (i == 0)) { + /* + * On the first (pattern) arg, check to see if any + * glob special characters are in the word '*[]?\\'. + * If not, this is the same as 'string equal'. We + * can use strchr here because the glob chars are all + * in the ascii-7 range. If -nocase was specified, + * we can't do this because INST_STR_EQ has no support + * for nocase. + */ + c = str[length]; + str[length] = '\0'; + exactMatch = (strpbrk(str, "*[]?\\") == NULL); + str[length] = c; + } + TclEmitPush(TclRegisterLiteral(envPtr, str, length, 0), envPtr); depth++; } else { @@ -2449,8 +2500,12 @@ TclCompileStringCmd(interp, parsePtr, envPtr) varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } + if (exactMatch) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } envPtr->maxStackDepth = depth; - TclEmitOpcode(INST_STR_MATCH, envPtr); return TCL_OK; } } @@ -2511,11 +2566,16 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) * If the test expression requires substitutions, don't compile the * while command inline. E.g., the expression might cause the loop to * never execute or execute forever, as in "while "$x < 5" {}". + * + * Bail out also if the body expression requires substitutions + * in order to insure correct behaviour [Bug 219166] */ testTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_OUT_LINE_COMPILE; } diff --git a/tests/for.test b/tests/for.test index fe36719..95ed356 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for.test,v 1.6 2000/04/10 17:18:59 ericm Exp $ +# RCS: @(#) $Id: for.test,v 1.7 2001/09/19 18:17:54 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -587,8 +587,8 @@ test for-4.1 {break must reset the interp result} { # Test for incorrect "double evaluation" semantics -test for-5.1 {possible delayed substitution of increment command} {knownBug} { - # Increment should be 5, and lappend should always append 5 +test for-5.1 {possible delayed substitution of increment command} { + # Increment should be 5, and lappend should always append $a catch {unset a} catch {unset i} set a 5 @@ -597,13 +597,35 @@ test for-5.1 {possible delayed substitution of increment command} {knownBug} { set i } {1 6 11} -test for-5.2 {possible delayed substitution of body command} {knownBug} { - # Increment should be 5, and lappend should always append 5 +test for-5.2 {possible delayed substitution of increment command} { + # Increment should be 5, and lappend should always append $a + catch {rename p ""} + proc p {} { + set a 5 + set i {} + for {set a 1} {$a < 12} "incr a $a" {lappend i $a} + set i + } + p +} {1 6 11} +test for-5.3 {possible delayed substitution of body command} { + # Increment should be $a, and lappend should always append 5 set a 5 set i {} for {set a 1} {$a < 12} {incr a $a} "lappend i $a" set i } {5 5 5 5} +test for-5.4 {possible delayed substitution of body command} { + # Increment should be $a, and lappend should always append 5 + catch {rename p ""} + proc p {} { + set a 5 + set i {} + for {set a 1} {$a < 12} {incr a $a} "lappend i $a" + set i + } + p +} {5 5 5 5} # In the following tests we need to bypass the bytecode compiler by # substituting the command from a variable. This ensures that command diff --git a/tests/foreach.test b/tests/foreach.test index d753fe5..fa5b3ea 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.7 2001/04/07 03:17:24 msofer Exp $ +# RCS: @(#) $Id: foreach.test,v 1.8 2001/09/19 18:17:54 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -222,7 +222,7 @@ test foreach-5.5 {break tests} { # Test for incorrect "double evaluation" semantics -test foreach-6.1 {delayed substitution of body} {knownBug} { +test foreach-6.1 {delayed substitution of body} { proc foo {} { set a 0 foreach a [list 1 2 3] " diff --git a/tests/if.test b/tests/if.test index b6ea1e3..5cb269d 100644 --- a/tests/if.test +++ b/tests/if.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: if.test,v 1.5 2000/04/10 17:19:00 ericm Exp $ +# RCS: @(#) $Id: if.test,v 1.6 2001/09/19 18:17:54 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1013,34 +1013,69 @@ test if-9.1 {if cmd with namespace qualifiers} { # Test for incorrect "double evaluation semantics" -test if-10.1 {delayed substitution of then body} {knownBug} { +test if-10.1 {delayed substitution of then body} { set j 0 - if {[incr j] == 1} " + set if if + # this is not compiled + $if {[incr j] == 1} " set result $j " - set result -} {0} -test if-10.2 {delayed substitution of elseif expression} {knownBug} { + # this will be compiled + proc p {} { + set j 0 + if {[incr j]} " + set result $j + " + set result + } + append result [p] +} {00} +test if-10.2 {delayed substitution of elseif expression} { set j 0 - if {[incr j] == 0} { + set if if + # this is not compiled + $if {[incr j] == 0} { set result badthen } elseif "$j == 1" { set result badelseif } else { - set result ok + set result 0 } - set result -} {ok} -test if-10.3 {delayed substitution of elseif body} {knownBug} { + # this will be compiled + proc p {} { + set j 0 + if {[incr j] == 0} { + set result badthen + } elseif "$j == 1" { + set result badelseif + } else { + set result 0 + } + set result + } + append result [p] +} {00} +test if-10.3 {delayed substitution of elseif body} { set j 0 - if {[incr j] == 0} { + set if if + # this is not compiled + $if {[incr j] == 0} { set result badthen } elseif {1} " set result $j " - set result -} {0} -test if-10.4 {delayed substitution of else body} {knownBug} { + # this will be compiled + proc p {} { + set j 0 + if {[incr j] == 0} { + set result badthen + } elseif {1} " + set result $j + " + } + append result [p] +} {00} +test if-10.4 {delayed substitution of else body} { set j 0 if {[incr j] == 0} { set result badthen @@ -1049,13 +1084,13 @@ test if-10.4 {delayed substitution of else body} {knownBug} { " set result } {0} -test if-10.5 {substituted control words} {knownBug} { +test if-10.5 {substituted control words} { set then then; proc then {} {return badthen} set else else; proc else {} {return badelse} set elseif elseif; proc elseif {} {return badelseif} list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a } {0 ok} -test if-10.6 {double invocation of variable traces} {knownBug} { +test if-10.6 {double invocation of variable traces} { set iftracecounter 0 proc iftraceproc {args} { upvar #0 iftracecounter counter diff --git a/tests/while.test b/tests/while.test index f34bf64..b10afdc 100644 --- a/tests/while.test +++ b/tests/while.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: while.test,v 1.6 2000/04/10 17:19:06 ericm Exp $ +# RCS: @(#) $Id: while.test,v 1.7 2001/09/19 18:17:54 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -609,13 +609,20 @@ test while-6.5 {continue tests, long command body with computed command names} { # Test for incorrect "double evaluation" semantics -test while-7.1 {delayed substitution of body} {knownBug} { +test while-7.1 {delayed substitution of body} { set i 0 while {[incr i] < 10} " set result $i " - set result -} {0} + proc p {} { + set i 0 + while {[incr i] < 10} " + set result $i + " + set result + } + append result [p] +} {00} # cleanup ::tcltest::cleanupTests |