Merge to feature branch

6 files changed, 108 insertions, 72 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 64348ad..95532d3 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4446,12 +4446,9 @@ SelectObjFromSublist(
 	    return NULL;
 	}
 	if (currentObj == NULL) {
-	    char buffer[TCL_INTEGER_SPACE];
-
-	    TclFormatInt(buffer, index);
-	    Tcl_AppendResult(infoPtr->interp, "element ", buffer,
-		    " missing from sublist \"", TclGetString(objPtr), "\"",
-		    NULL);
+            Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+                    "element %d missing from sublist \"%s\"",
+                    index, TclGetString(objPtr)));
             Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
                     "INDEXFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ae633ea..026503b 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2449,8 +2449,16 @@ TclInitByteCodeObj(
 	     * a value contains a literal which is that same value.
 	     * If this is allowed to happen, refcount decrements may not
 	     * reach zero, and memory may leak.  Bugs 467523, 3357771
+	     *
+	     * NOTE:  [Bugs 3392070, 3389764] We make a copy based completely
+	     * on the string value, and do not call Tcl_DuplicateObj() so we
+             * can be sure we do not have any lingering cycles hiding in
+	     * the intrep.
 	     */
-	    codePtr->objArrayPtr[i] = Tcl_DuplicateObj(objPtr);
+	    int numBytes;
+	    const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+
+	    codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
 	    Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
 	    Tcl_DecrRefCount(objPtr);
 	} else {
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 76c2dea..6f378a4 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -359,7 +359,6 @@ Tcl_GetIndexFromObjStruct(
 	int count;
 
 	TclNewObj(resultPtr);
-	Tcl_SetObjResult(interp, resultPtr);
 	Tcl_AppendStringsToObj(resultPtr,
 		(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
 		msg, " \"", key, NULL);
@@ -379,6 +378,7 @@ Tcl_GetIndexFromObjStruct(
 		}
 	    }
 	}
+	Tcl_SetObjResult(interp, resultPtr);
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
     }
     return TCL_ERROR;
@@ -410,7 +410,7 @@ SetIndexFromAny(
     register Tcl_Obj *objPtr)	/* The object to convert. */
 {
     if (interp) {
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 	    "can't convert value to index except via Tcl_GetIndexFromObj API",
 	    -1));
     }
@@ -593,14 +593,16 @@ PrefixMatchObjCmd(
 	case PRFMATCH_MESSAGE:
 	    if (i > (objc - 4)) {
 		Tcl_AppendResult(interp, "missing message", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
 		return TCL_ERROR;
 	    }
 	    i++;
 	    message = Tcl_GetString(objv[i]);
 	    break;
 	case PRFMATCH_ERROR:
-	    if (i > (objc - 4)) {
+	    if (i > objc-4) {
 		Tcl_AppendResult(interp, "missing error options", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
 		return TCL_ERROR;
 	    }
 	    i++;
@@ -611,6 +613,7 @@ PrefixMatchObjCmd(
 	    if ((errorLength % 2) != 0) {
 		Tcl_AppendResult(interp, "error options must have an even"
 			" number of elements", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
 		return TCL_ERROR;
 	    }
 	    errorPtr = objv[i];
@@ -1093,7 +1096,7 @@ Tcl_ParseArgsObjv(
 				/* Pointer to the current entry in the table
 				 * of argument descriptions. */
     const Tcl_ArgvInfo *matchPtr;
-				/* Descriptor that matches current argument. */
+				/* Descriptor that matches current argument */
     Tcl_Obj *curArg;		/* Current argument */
     const char *str = NULL;
     register char c;		/* Second character of current arg (used for
@@ -1106,7 +1109,7 @@ Tcl_ParseArgsObjv(
 				 * being processed, primarily for error
 				 * reporting. */
     int objc;			/* # arguments in objv still to process. */
-    int length;			/* Number of characters in current argument. */
+    int length;			/* Number of characters in current argument */
 
     if (remObjv != NULL) {
 	/*
@@ -1147,8 +1150,7 @@ Tcl_ParseArgsObjv(
 
 	matchPtr = NULL;
 	infoPtr = argTable;
-	for (; (infoPtr != NULL) && (infoPtr->type != TCL_ARGV_END);
-		infoPtr++) {
+	for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {
 	    if (infoPtr->keyStr == NULL) {
 		continue;
 	    }
@@ -1242,7 +1244,8 @@ Tcl_ParseArgsObjv(
 	    objc--;
 	    break;
 	case TCL_ARGV_FUNC: {
-	    Tcl_ArgvFuncProc *handlerProc;
+	    Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
+		    infoPtr->srcPtr;
 	    Tcl_Obj *argObj;
 
 	    if (objc == 0) {
@@ -1250,7 +1253,6 @@ Tcl_ParseArgsObjv(
 	    } else {
 		argObj = objv[srcIndex];
 	    }
-	    handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr;
 	    if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
 		srcIndex++;
 		objc--;
@@ -1258,9 +1260,9 @@ Tcl_ParseArgsObjv(
 	    break;
 	}
 	case TCL_ARGV_GENFUNC: {
-	    Tcl_ArgvGenFuncProc *handlerProc;
+	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
+		    infoPtr->srcPtr;
 
-	    handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr;
 	    objc = handlerProc(infoPtr->clientData, interp, objc,
 		    &objv[srcIndex], infoPtr->dstPtr);
 	    if (objc < 0) {
@@ -1271,15 +1273,11 @@ Tcl_ParseArgsObjv(
 	case TCL_ARGV_HELP:
 	    PrintUsage(interp, argTable);
 	    goto error;
-	default: {
-	    char buf[64 + TCL_INTEGER_SPACE];
-
-	    sprintf(buf, "bad argument type %d in Tcl_ArgvInfo",
-		    infoPtr->type);
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+	default:
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
 	    goto error;
 	}
-	}
     }
 
     /*
@@ -1444,18 +1442,18 @@ int
 TclGetCompletionCodeFromObj(
     Tcl_Interp *interp,		/* Current interpreter. */
     Tcl_Obj *value,
-    int *code)	/* Argument objects. */
+    int *code)			/* Argument objects. */
 {
     static const char *const returnCodes[] = {
-	    "ok", "error", "return", "break", "continue", NULL
+	"ok", "error", "return", "break", "continue", NULL
     };
 
     if ((value->typePtr != &indexType)
 	    && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
 	return TCL_OK;
     }
-    if (TCL_OK == Tcl_GetIndexFromObj(
-	    NULL, value, returnCodes, NULL, TCL_EXACT, code)) {
+    if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
+		TCL_EXACT, code)) {
 	return TCL_OK;
     }
     /*
@@ -1472,7 +1470,7 @@ TclGetCompletionCodeFromObj(
     }
     return TCL_ERROR;
 }
-
+
 /*
  * Local Variables:
  * mode: c
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index ac87628..3668b45 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -49,7 +49,6 @@ const Tcl_ObjType tclListType = {
 #ifndef TCL_MIN_ELEMENT_GROWTH
 #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
 #endif
-
 
 /*
  *----------------------------------------------------------------------
@@ -518,7 +517,10 @@ Tcl_ListObjAppendList(
 	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
     }
 
-    /* Pull the elements to append from elemListPtr */
+    /*
+     * Pull the elements to append from elemListPtr.
+     */
+
     if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
 	return TCL_ERROR;
     }
@@ -600,7 +602,10 @@ Tcl_ListObjAppendElement(
     }
 
     if (needGrow && !isShared) {
-	/* Need to grow + unshared intrep => try to realloc */
+	/*
+	 * Need to grow + unshared intrep => try to realloc
+	 */
+
 	attempt = 2 * numRequired;
 	if (attempt <= LIST_MAX) {
 	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
@@ -626,10 +631,10 @@ Tcl_ListObjAppendElement(
 	Tcl_Obj **dst, **src = &listRepPtr->elements;
 
 	/*
-	 * Either we have a shared intrep and we must copy to write,
-	 * or we need to grow and realloc attempts failed.
-	 * Attempt intrep copy.
+	 * Either we have a shared intrep and we must copy to write, or we
+	 * need to grow and realloc attempts failed.  Attempt intrep copy.
 	 */
+
 	attempt = 2 * numRequired;
 	newPtr = AttemptNewList(NULL, attempt, NULL);
 	if (newPtr == NULL) {
@@ -644,7 +649,10 @@ Tcl_ListObjAppendElement(
 	    newPtr = AttemptNewList(interp, attempt, NULL);
 	}
 	if (newPtr == NULL) {
-	    /* All growth attempts failed; throw the error */
+	    /*
+	     * All growth attempts failed; throw the error.
+	     */
+
 	    return TCL_ERROR;
 	}
 
@@ -655,8 +663,8 @@ Tcl_ListObjAppendElement(
 
 	if (isShared) {
 	    /*
-	     * The original intrep must remain undisturbed.
-	     * Copy into the new one and bump refcounts
+	     * The original intrep must remain undisturbed.  Copy into the new
+	     * one and bump refcounts
 	     */
 	    while (numElems--) {
 		*dst = *src++;
@@ -664,9 +672,11 @@ Tcl_ListObjAppendElement(
 	    }
 	    listRepPtr->refCount--;
 	} else {
-	    /* Old intrep to be freed, re-use refCounts */
-	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
+	    /*
+	     * Old intrep to be freed, re-use refCounts.
+	     */
 
+	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
 	    ckfree(listRepPtr);
 	}
 	listRepPtr = newPtr;
@@ -854,11 +864,10 @@ Tcl_ListObjReplace(
     }
     if (listPtr->typePtr != &tclListType) {
 	if (listPtr->bytes == tclEmptyStringRep) {
-	    if (objc) {
-		Tcl_SetListObj(listPtr, objc, NULL);
-	    } else {
+	    if (!objc) {
 		return TCL_OK;
 	    }
+	    Tcl_SetListObj(listPtr, objc, NULL);
 	} else {
 	    int result = SetListFromAny(interp, listPtr);
 
@@ -891,8 +900,9 @@ Tcl_ListObjReplace(
     } else if (numElems < first+count || first+count < 0) {
 	/*
 	 * The 'first+count < 0' condition here guards agains integer
-	 * overflow in determining 'first+count'
+	 * overflow in determining 'first+count'.
 	 */
+
 	count = numElems - first;
     }
 
@@ -1075,8 +1085,6 @@ TclLindexList(
 {
 
     int index;			/* Index into the list. */
-    Tcl_Obj **indices;		/* Array of list indices. */
-    int indexCount;		/* Size of the array of list indices. */
     Tcl_Obj *indexListCopy;
 
     /*
@@ -1116,8 +1124,19 @@ TclLindexList(
 	return TclLindexFlat(interp, listPtr, 1, &argPtr);
     }
 
-    TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
-    listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+    if (indexListCopy->typePtr == &tclListType) {
+	List *listRepPtr = ListRepPtr(indexListCopy);
+
+	listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
+		&listRepPtr->elements);
+    } else {
+	int indexCount = -1;	/* Size of the array of list indices. */
+	Tcl_Obj **indices = NULL;
+				/* Array of list indices. */
+
+	Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
+	listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+    }
     Tcl_DecrRefCount(indexListCopy);
     return listPtr;
 }
@@ -1375,6 +1394,7 @@ TclLsetFlat(
 
     retValuePtr = subListPtr;
     chainPtr = NULL;
+    result = TCL_OK;
 
     /*
      * Loop through all the index arguments, and for each one dive into the
@@ -1385,11 +1405,14 @@ TclLsetFlat(
 	int elemCount;
 	Tcl_Obj *parentList, **elemPtrs;
 
-	/* Check for the possible error conditions... */
-	result = TCL_ERROR;
+	/*
+	 * Check for the possible error conditions...
+	 */
+
 	if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
 		!= TCL_OK) {
 	    /* ...the sublist we're indexing into isn't a list at all. */
+	    result = TCL_ERROR;
 	    break;
 	}
 
@@ -1401,6 +1424,7 @@ TclLsetFlat(
 	if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
 		!= TCL_OK)  {
 	    /* ...the index we're trying to use isn't an index at all. */
+	    result = TCL_ERROR;
 	    indexArray++;
 	    break;
 	}
@@ -1411,9 +1435,10 @@ TclLsetFlat(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_NewStringObj("list index out of range", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+			"BADINDEX", NULL);
 	    }
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
-		    NULL);
+	    result = TCL_ERROR;
 	    break;
 	}
 
@@ -1424,7 +1449,6 @@ TclLsetFlat(
 	 * modify it.
 	 */
 
-	result = TCL_OK;
 	if (--indexCount) {
 	    parentList = subListPtr;
 	    if (index == elemCount) {
@@ -1514,10 +1538,13 @@ TclLsetFlat(
     }
 
     /*
-     * Store valuePtr in proper sublist and return.
+     * Store valuePtr in proper sublist and return. The -1 is to avoid a
+     * compiler warning (not a problem because we checked that we have a
+     * proper list - or something convertible to one - above).
      */
 
-    Tcl_ListObjLength(NULL, subListPtr, &len);
+    len = -1;
+    TclListObjLength(NULL, subListPtr, &len);
     if (index == len) {
 	Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
     } else {
@@ -1586,9 +1613,9 @@ TclListObjSetElement(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_NewStringObj("list index out of range", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+			"BADINDEX", NULL);
 	    }
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
-		    NULL);
 	    return TCL_ERROR;
 	}
 	result = SetListFromAny(interp, listPtr);
@@ -1811,19 +1838,23 @@ SetListFromAny(
 	 */
 
 	estCount = TclMaxListLength(nextElem, length, &limit);
-	estCount += (estCount == 0); /* Smallest List struct holds 1 element. */
+	estCount += (estCount == 0);	/* Smallest list struct holds 1
+					 * element. */
 	listRepPtr = AttemptNewList(interp, estCount, NULL);
 	if (listRepPtr == NULL) {
 	    return TCL_ERROR;
 	}
 	elemPtrs = &listRepPtr->elements;
 
-	/* Each iteration, parse and store a list element */
+	/*
+	 * Each iteration, parse and store a list element.
+	 */
+
 	while (nextElem < limit) {
 	    const char *elemStart;
 	    int elemSize, literal;
 
-	    if (TCL_OK != TclFindElement(interp, nextElem, (limit - nextElem),
+	    if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
 		    &elemStart, &nextElem, &elemSize, &literal)) {
 		while (--elemPtrs >= &listRepPtr->elements) {
 		    Tcl_DecrRefCount(*elemPtrs);
@@ -1904,7 +1935,9 @@ UpdateStringOfList(
 
     listRepPtr->canonicalFlag = 1;
 
-    /* Handle empty list case first, so rest of the routine is simpler */
+    /*
+     * Handle empty list case first, so rest of the routine is simpler.
+     */
 
     if (numElems == 0) {
 	listPtr->bytes = tclEmptyStringRep;
@@ -1919,12 +1952,15 @@ UpdateStringOfList(
     if (numElems <= LOCAL_SIZE) {
 	flagPtr = localFlags;
     } else {
-	/* We know numElems <= LIST_MAX, so this is safe. */
+	/*
+	 * We know numElems <= LIST_MAX, so this is safe.
+	 */
+
 	flagPtr = ckalloc(numElems * sizeof(int));
     }
     elemPtrs = &listRepPtr->elements;
     for (i = 0; i < numElems; i++) {
-	flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
+	flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
 	elem = TclGetStringFromObj(elemPtrs[i], &length);
 	bytesNeeded += TclScanElement(elem, length, flagPtr+i);
 	if (bytesNeeded < 0) {
@@ -1944,7 +1980,7 @@ UpdateStringOfList(
     listPtr->bytes = ckalloc(bytesNeeded);
     dst = listPtr->bytes;
     for (i = 0; i < numElems; i++) {
-	flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
+	flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
 	elem = TclGetStringFromObj(elemPtrs[i], &length);
 	dst += TclConvertElement(elem, length, dst, flagPtr[i]);
 	*dst++ = ' ';
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 652074e..114d2c3 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -392,7 +392,7 @@ Tcl_MainEx(
 	/*
 	 * Arrange for final deletion of the main interp
 	 */
-	// ARGH Munchhausen effect 
+	/* ARGH Munchhausen effect  */
 	Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
     }
 
@@ -928,7 +928,7 @@ FreeMainInterp(
 {
 	Tcl_Interp *interp = (Tcl_Interp *) clientData;
 
-	//if (TclInExit()) return;
+	/*if (TclInExit()) return;*/
 
 	if (!Tcl_InterpDeleted(interp)) {
 	    Tcl_DeleteInterp(interp);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 62bf1c4..4df5d43 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3077,21 +3077,18 @@ ArrayStartSearchCmd(
     hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
     if (isNew) {
 	searchPtr->id = 1;
-	Tcl_AppendResult(interp, "s-1-", varName, NULL);
 	varPtr->flags |= VAR_SEARCH_ACTIVE;
 	searchPtr->nextPtr = NULL;
     } else {
-	char string[TCL_INTEGER_SPACE];
-
 	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
-	TclFormatInt(string, searchPtr->id);
-	Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
 	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
     }
     searchPtr->varPtr = varPtr;
     searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
 	    &searchPtr->search);
     Tcl_SetHashValue(hPtr, searchPtr);
+    Tcl_SetObjResult(interp,
+	    Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
     return TCL_OK;
 }