summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2001-09-19 18:17:54 (GMT)
committerhobbs <hobbs>2001-09-19 18:17:54 (GMT)
commit93f8aa9a4503e99c92cc046261e09d99e638c188 (patch)
treebd67a555349bc2a086720174d0243daff86a7c77
parenteaecbc2b998c46334ae14212a09eadfce713b4ab (diff)
downloadtcl-93f8aa9a4503e99c92cc046261e09d99e638c188.zip
tcl-93f8aa9a4503e99c92cc046261e09d99e638c188.tar.gz
tcl-93f8aa9a4503e99c92cc046261e09d99e638c188.tar.bz2
* generic/tclCompCmds.c (TclCompileStringCmd): INST_STR_MATCH -
Updated to Int1 instruction type and added special case to use INST_STR_EQ instead when no glob chars are specified in a static string. * tests/{for.test,foreach.test,if.test,while.test}: * generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd, TclCompileIfCmd, TclCompileWhileCmd): Corrected the overaggressive compiling of loop bodies enclosed in ""s. [Bug #219166] (msofer)
-rw-r--r--generic/tclCompCmds.c90
-rw-r--r--tests/for.test32
-rw-r--r--tests/foreach.test4
-rw-r--r--tests/if.test69
-rw-r--r--tests/while.test15
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