merge trunk

11 files changed, 62 insertions, 40 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/tclCmdMZ.c b/generic/tclCmdMZ.c
index 95debf8..f9f2a28 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1540,7 +1540,8 @@ StringIsCmd(
     case STR_IS_BOOL:
     case STR_IS_TRUE:
     case STR_IS_FALSE:
-	if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) {
+	if ((objPtr->typePtr != &tclBooleanType)
+		&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
 	    if (strict) {
 		result = 0;
 	    } else {
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 33d67ff..4069cf0 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -789,8 +789,7 @@ SetByteCodeFromAny(
     if (interp == NULL) {
 	return TCL_ERROR;
     }
-    TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
-    return TCL_OK;
+    return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
 }
 
 /*
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 4c19b55..97e8c7b 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -137,7 +137,7 @@ Tcl_GetBoolean(
     obj.length = strlen(src);
     obj.typePtr = NULL;
 
-    code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);
+    code = TclSetBooleanFromAny(interp, &obj);
     if (obj.refCount > 1) {
 	Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
     }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6a63f54..ddbae7a 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3134,6 +3134,7 @@ MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
 			    Tcl_Obj *cmdPrefix);
 MODULE_SCOPE void	TclSetBignumIntRep(Tcl_Obj *objPtr,
 			    mp_int *bignumValue);
+MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 MODULE_SCOPE void	TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    Command *cmdPtr);
 MODULE_SCOPE void	TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 1d86534..f2ec565 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -208,7 +208,6 @@ static Tcl_ThreadDataKey pendingObjDataKey;
  */
 
 static int		ParseBoolean(Tcl_Obj *objPtr);
-static int		SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static int		SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static int		SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static void		UpdateStringOfDouble(Tcl_Obj *objPtr);
@@ -250,14 +249,14 @@ static const Tcl_ObjType oldBooleanType = {
     NULL,			/* freeIntRepProc */
     NULL,			/* dupIntRepProc */
     NULL,			/* updateStringProc */
-    SetBooleanFromAny		/* setFromAnyProc */
+    TclSetBooleanFromAny		/* setFromAnyProc */
 };
 const Tcl_ObjType tclBooleanType = {
     "booleanString",		/* name */
     NULL,			/* freeIntRepProc */
     NULL,			/* dupIntRepProc */
     NULL,			/* updateStringProc */
-    SetBooleanFromAny		/* setFromAnyProc */
+    TclSetBooleanFromAny		/* setFromAnyProc */
 };
 const Tcl_ObjType tclDoubleType = {
     "double",			/* name */
@@ -1911,7 +1910,7 @@ Tcl_GetBooleanFromObj(
 /*
  *----------------------------------------------------------------------
  *
- * SetBooleanFromAny --
+ * TclSetBooleanFromAny --
  *
  *	Attempt to generate a boolean internal form for the Tcl object
  *	"objPtr".
@@ -1928,8 +1927,8 @@ Tcl_GetBooleanFromObj(
  *----------------------------------------------------------------------
  */
 
-static int
-SetBooleanFromAny(
+int
+TclSetBooleanFromAny(
     Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
     register Tcl_Obj *objPtr)	/* The object to convert. */
 {
@@ -4171,7 +4170,7 @@ Tcl_GetCommandFromObj(
      * had is invalid one way or another.
      */
 
-    if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
+    if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) {
         return NULL;
     }
     resPtr = objPtr->internalRep.twoPtrValue.ptr1;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index b3ead45..b7f3dcf 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1156,7 +1156,7 @@ Tcl_FSConvertToPathType(
 	FreeFsPathInternalRep(pathPtr);
     }
 
-    return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
+    return SetFsPathFromAny(interp, pathPtr);
 
     /*
      * We used to have more complex code here:
@@ -1873,7 +1873,7 @@ Tcl_FSGetNormalizedPath(
 		UpdateStringOfFsPath(pathPtr);
 	    }
 	    FreeFsPathInternalRep(pathPtr);
-	    if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
+	    if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
 		return NULL;
 	    }
 	    fsPathPtr = PATHOBJ(pathPtr);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index a261cd4..e66b8ea 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2095,7 +2095,7 @@ TclProcCompileProc(
 
 	iPtr->invokeWord = 0;
 	iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
-	tclByteCodeType.setFromAnyProc(interp, bodyPtr);
+	TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
 	iPtr->invokeCmdFramePtr = NULL;
 	TclPopStackFrame(interp);
     } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -2720,7 +2720,6 @@ TclNRApplyObjCmd(
     else {
 	/*
 	 * Joe English's suggestion to allow cmdNames to function as lambdas.
-	 * Also requires making tclCmdNameType non-static in tclObj.c
 	 */
 
 	Tcl_Obj *elemPtr;
@@ -2960,10 +2959,9 @@ Tcl_DisassembleObjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "script");
 	    return TCL_ERROR;
 	}
-	if (objv[2]->typePtr != &tclByteCodeType) {
-	    if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
-		return TCL_ERROR;
-	    }
+	if ((objv[2]->typePtr != &tclByteCodeType)
+		&& (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+	    return TCL_ERROR;
 	}
 	codeObjPtr = objv[2];
 	break;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 2d1479d..befcc26 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -475,6 +475,9 @@ TclObjLookupVar(
 
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
+	if (createPart2) {
+	    Tcl_IncrRefCount(part2Ptr);
+	}
     }
 
     resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -487,6 +490,12 @@ TclObjLookupVar(
     return resPtr;
 }
 
+/*
+ *	When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ *	plan to DecrRefCount it.
+ *	When createPart2 is 1, callers must IncrRefCount part2Ptr if they
+ *	plan to DecrRefCount it.
+ */
 Var *
 TclObjLookupVarEx(
     Tcl_Interp *interp,		/* Interpreter to use for lookup. */
@@ -627,7 +636,9 @@ TclObjLookupVarEx(
 	    part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
 	    if (newPart2) {
 		part2Ptr = Tcl_NewStringObj(newPart2, -1);
-		Tcl_IncrRefCount(part2Ptr);
+		if (createPart2) {
+		    Tcl_IncrRefCount(part2Ptr);
+		}
 	    }
 	    part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
 	    typePtr = part1Ptr->typePtr;
@@ -673,7 +684,9 @@ TclObjLookupVarEx(
 		*(newPart2+len2) = '\0';
 		part2 = newPart2;
 		part2Ptr = Tcl_NewStringObj(newPart2, -1);
-		Tcl_IncrRefCount(part2Ptr);
+		if (createPart2) {
+		    Tcl_IncrRefCount(part2Ptr);
+		}
 
 		/*
 		 * Free the internal rep of the original part1Ptr, now renamed
@@ -1083,6 +1096,8 @@ TclLookupSimpleVar(
  *	The variable at arrayPtr may be converted to be an array if
  *	createPart1 is 1. A new hashtable entry may be created if createPart2
  *	is 1.
+ *	When createElem is 1, callers must incr elNamePtr if they plan
+ *	to decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -1217,11 +1232,9 @@ Tcl_GetVar(
 				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
 				 * bits. */
 {
-    Tcl_Obj *varNamePtr, *resultPtr;
+    Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
+    Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
 
-    varNamePtr = Tcl_NewStringObj(varName, -1);
-    Tcl_IncrRefCount(varNamePtr);
-    resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
     TclDecrRefCount(varNamePtr);
 
     if (resultPtr == NULL) {
@@ -1265,15 +1278,12 @@ Tcl_GetVar2(
 				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
 				 * bits. */
 {
-    Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
+    Tcl_Obj *resultPtr;
+    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
 
-    part1Ptr = Tcl_NewStringObj(part1, -1);
-    Tcl_IncrRefCount(part1Ptr);
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
 	Tcl_IncrRefCount(part2Ptr);
-    } else {
-	part2Ptr = NULL;
     }
 
     resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1326,6 +1336,7 @@ Tcl_GetVar2Ex(
 
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
+	Tcl_IncrRefCount(part2Ptr);
     }
 
     resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1358,6 +1369,8 @@ Tcl_GetVar2Ex(
  *	the returned reference; if you want to keep a reference to the object
  *	you must increment its ref count yourself.
  *
+ *	Callers must incr part2Ptr if they plan to decr it.
+ *
  *----------------------------------------------------------------------
  */
 
@@ -1563,17 +1576,13 @@ Tcl_SetVar(
 				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
 				 * TCL_LEAVE_ERR_MSG. */
 {
-    Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
+    Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
 
-    varNamePtr = Tcl_NewStringObj(varName, -1);
     Tcl_IncrRefCount(varNamePtr);
-    valuePtr = Tcl_NewStringObj(newValue, -1);
-    Tcl_IncrRefCount(valuePtr);
-
-    varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
-
+    varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, 
+	    Tcl_NewStringObj(newValue, -1), flags);
     Tcl_DecrRefCount(varNamePtr);
-    Tcl_DecrRefCount(valuePtr);
+
     if (varValuePtr == NULL) {
 	return NULL;
     }
@@ -1721,6 +1730,7 @@ Tcl_SetVar2Ex(
  *	The value of the given variable is set. If either the array or the
  *	entry didn't exist then a new variable is created.
  *	Callers must Incr part1Ptr if they plan to Decr it.
+ *	Callers must Incr part2Ptr if they plan to Decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -2011,6 +2021,7 @@ TclPtrSetVar(
  *	incremented to reflect the returned reference; if you want to keep a
  *	reference to the object you must increment its ref count yourself.
  *	Callers must Incr part1Ptr if they plan to Decr it.
+ *	Callers must Incr part2Ptr if they plan to Decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -5108,7 +5119,8 @@ ParseSearchId(
      * Parse the id.
      */
 
-    if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
+    if ((handleObj->typePtr != &tclArraySearchType)
+	    && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
 	return NULL;
     }
 
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 6016c6d..8ec1288 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -579,7 +579,7 @@ GetOSTypeFromObj(
     int result = TCL_OK;
 
     if (objPtr->typePtr != &tclOSTypeType) {
-	result = tclOSTypeType.setFromAnyProc(interp, objPtr);
+	result = SetOSTypeFromAny(interp, objPtr);
     }
     *osTypePtr = (OSType) objPtr->internalRep.longValue;
     return result;
diff --git a/tests/set.test b/tests/set.test
index 1d88553..18119f5 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -524,6 +524,11 @@ test set-5.1 {error on malformed array name} testset2 {
     list $msg $msg1
 } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
 
+# In a mem-debug build, this test will crash unless Bug 3602706 is fixed.
+test set-5.2 {Bug 3602706} -body {
+    testset2 ::tcl_platform not-in-there
+} -returnCodes error -result * -match glob
+
 # cleanup
 catch {unset a}
 catch {unset b}