summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclCompCmds.c41
-rw-r--r--tests/var.test69
3 files changed, 99 insertions, 18 deletions
diff --git a/ChangeLog b/ChangeLog
index a329282..9e3ffb3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2013-02-04 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileArraySetCmd): [Bug 3603163]: Stop
+ crash in weird case where [eval] is used to make [array set] get
+ confused about whether there is a local variable table or not. Thanks
+ to Poor Yorick for identifying a reproducible crashing case.
+
2013-01-30 Andreas Kupries <andreask@activestate.com>
* library/platform/platform.tcl (::platform::LibcVersion): See
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 389c1ee..4751455 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -284,7 +284,7 @@ TclCompileArraySetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
+ Tcl_Token *varTokenPtr, *dataTokenPtr;
int simpleVarName, isScalar, localIndex;
int dataVar, iterVar, keyVar, valVar, infoIndex;
int back, fwd, offsetBack, offsetFwd, savedStackDepth;
@@ -294,10 +294,10 @@ TclCompileArraySetCmd(
return TCL_ERROR;
}
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
- tokenPtr = TokenAfter(tokenPtr);
+ dataTokenPtr = TokenAfter(varTokenPtr);
if (!isScalar) {
return TCL_ERROR;
}
@@ -307,7 +307,8 @@ TclCompileArraySetCmd(
* operation.
*/
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+ if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD
+ && dataTokenPtr[1].size == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
@@ -326,7 +327,16 @@ TclCompileArraySetCmd(
return TCL_OK;
}
- if (envPtr->procPtr == NULL) {
+ /*
+ * Prepare for the internal foreach.
+ */
+
+ dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+ if (dataVar < 0) {
/*
* Right number of arguments, but not compilable as we can't allocate
* (unnamed) local variables to manage the internal iteration.
@@ -343,21 +353,16 @@ TclCompileArraySetCmd(
cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
+ if (localIndex >= 0) {
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ } else {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ }
+ CompileWord(envPtr, dataTokenPtr, interp, 2);
TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr);
return TCL_OK;
}
- /*
- * Prepare for the internal foreach.
- */
-
- dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-
infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->firstValueTemp = dataVar;
@@ -372,7 +377,7 @@ TclCompileArraySetCmd(
* Start issuing instructions to write to the array.
*/
- CompileWord(envPtr, tokenPtr, interp, 2);
+ CompileWord(envPtr, dataTokenPtr, interp, 2);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
PushLiteral(envPtr, "1", 1);
diff --git a/tests/var.test b/tests/var.test
index ed7e930..5939100 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -793,6 +793,75 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} {
foo ; # This crashes without the fix for the bug
rename foo {}
} {}
+
+test var-20.1 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.2 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {}
+ }}
+ array size x
+} -result 0
+test var-20.3 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.4 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {}
+ }}
+ array size x
+} -result 0
+test var-20.5 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.6 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {}}
+ }}
+ array size x
+} -result 0
+test var-20.7 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {}}
+ }}
+ array size x
+} -result 0
catch {namespace delete ns}
catch {unset arr}