Attachment "219166.patch" to
ticket [219166ffff]
added by
msofer
2001-09-07 20:07:23.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.582
diff -u -r1.582 ChangeLog
--- ChangeLog 2001/09/07 02:43:11 1.582
+++ ChangeLog 2001/09/07 13:02:45
@@ -1,3 +1,14 @@
+2001-09-07 Miguel Sofer <[email protected]>
+
+ * generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd,
+ TclCompileIfCmd, TclCompileWhileCmd):
+ * tests/for.test:
+ * tests/foreach.test:
+ * tests/if.test
+ * tests/while.test: Forced outline compiling when compiling the
+ commands could cause substitution errors - the "simple minded
+ solution" mentioned by Scott Stanton in [Bug 219166].
+
2001-09-06 Don Porter <[email protected]>
* doc/http.n:
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.13
diff -u -r1.13 tclCompCmds.c
--- generic/tclCompCmds.c 2001/09/01 00:51:31 1.13
+++ generic/tclCompCmds.c 2001/09/07 13:02:46
@@ -561,6 +561,18 @@
}
/*
+ * 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 @@
* 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 @@
}
/*
+ * 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 @@
loopIndex++;
}
}
- bodyTokenPtr = tokenPtr;
/*
* Initialize the temporary var that holds the count of loop iterations.
@@ -1195,6 +1217,23 @@
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 @@
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
- numWords = parsePtr->numWords;
while (wordIdx < numWords) {
/*
* Stop looping if the token isn't "if" or "elseif".
@@ -2511,11 +2549,16 @@
* 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;
}
Index: tests/for.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/for.test,v
retrieving revision 1.6
diff -u -r1.6 for.test
--- tests/for.test 2000/04/10 17:18:59 1.6
+++ tests/for.test 2001/09/07 13:02:47
@@ -587,8 +587,8 @@
# 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,12 +597,34 @@
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
Index: tests/foreach.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/foreach.test,v
retrieving revision 1.7
diff -u -r1.7 foreach.test
--- tests/foreach.test 2001/04/07 03:17:24 1.7
+++ tests/foreach.test 2001/09/07 13:02:47
@@ -222,7 +222,7 @@
# 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] "
Index: tests/if.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/if.test,v
retrieving revision 1.5
diff -u -r1.5 if.test
--- tests/if.test 2000/04/10 17:19:00 1.5
+++ tests/if.test 2001/09/07 13:02:47
@@ -1013,34 +1013,69 @@
# 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 @@
"
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
Index: tests/while.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/while.test,v
retrieving revision 1.6
diff -u -r1.6 while.test
--- tests/while.test 2000/04/10 17:19:06 1.6
+++ tests/while.test 2001/09/07 13:02:47
@@ -609,13 +609,20 @@
# 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
