[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.

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}