Subject: Converting to stringType no longer loses the existing internal representation of a value.

From: pooryorick <[email-masked]>
Date: Tue, 26 Jul 2016 18:36:41 +0000

---
 generic/tclDictObj.c     | 44 +++++++++++++++---------------
 generic/tclInt.h         | 24 ++++++++++++++++-
 generic/tclListObj.c     | 70 +++++++++++++++++++++++++-----------------------
 generic/tclObj.c         | 40 +++++++++++++++++++++++++++
 generic/tclStringObj.c   | 40 +++++++++++++++++++++++++--
 generic/tclThreadAlloc.c |  5 ++++
 unix/tcl.m4              |  2 +-
 7 files changed, 167 insertions(+), 58 deletions(-)

diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ad52ba3..613cdc8 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -500,19 +500,15 @@ UpdateStringOfDict(
     const char *elem;
     char *dst;
     const int maxFlags = UINT_MAX / sizeof(int);
-    void *tmp;
+    Tcl_Obj *listObj;
     int numElems;
 
     if (dictPtr->internalRep.twoPtrValue.ptr2 != NULL) {
-	tmp = dictPtr->internalRep.twoPtrValue.ptr1;
-	dictPtr->internalRep.twoPtrValue.ptr1 = dictPtr->internalRep.twoPtrValue.ptr2;
-	dictPtr->typePtr = &tclListType ;
-	if (TclGetString(dictPtr) == NULL) {
-	    Tcl_Panic("Could not update dict string from internal list");
-	}
-	dictPtr->internalRep.twoPtrValue.ptr2 = dictPtr->internalRep.twoPtrValue.ptr1;
-	dictPtr->internalRep.twoPtrValue.ptr1 = tmp;
-	dictPtr->typePtr = &tclDictType;
+	listObj = dictPtr->internalRep.twoPtrValue.ptr2;
+	TclGetString(listObj);
+	dictPtr->bytes = listObj->bytes;
+	dictPtr->length = listObj->length;
+	listObj->bytes = NULL;
 	return;
     }
 
@@ -623,6 +619,7 @@ SetDictFromAny(
     Tcl_HashEntry *hPtr;
     int isNew, needlist = 0;
     Dict *dict = ckalloc(sizeof(Dict));
+    Tcl_Obj *listObj;
 
     InitChainTable(dict);
 
@@ -632,12 +629,14 @@ SetDictFromAny(
      * the conversion from lists to dictionaries.
      */
 
-    if (objPtr->typePtr == &tclListType) {
+
+    listObj = TclObjLookupTyped(objPtr, &tclListType);
+    if (listObj != NULL) {
 	int objc, i;
 	Tcl_Obj **objv;
 
 	/* Cannot fail, we already know the Tcl_ObjType is "list". */
-	TclListObjGetElements(NULL, objPtr, &objc, &objv);
+	TclListObjGetElements(NULL, listObj, &objc, &objv);
 	if (objc & 1) {
 	    goto missingValue;
 	}
@@ -647,8 +646,9 @@ SetDictFromAny(
 	    /* Store key and value in the hash table we're building. */
 	    hPtr = CreateChainEntry(dict, objv[i], &isNew);
 	    if (!isNew) {
+		Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
 		needlist = 1;
-		continue;
+		Tcl_DecrRefCount(discardedValue);
 	    }
 	    Tcl_SetHashValue(hPtr, objv[i+1]);
 	    Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
@@ -724,9 +724,13 @@ SetDictFromAny(
     dict->refcount = 1;
     if (needlist) {
 	/* squirrel the list intrep away for use by SetListFromAny  */
-	objPtr->internalRep.twoPtrValue.ptr2 = objPtr->internalRep.twoPtrValue.ptr1;
+	listObj = Tcl_DuplicateObj(listObj);
+	Tcl_IncrRefCount(listObj);
+    }
+    TclFreeIntRep(objPtr);
+    if (needlist) {
+	objPtr->internalRep.twoPtrValue.ptr2 = listObj;
     } else {
-	TclFreeIntRep(objPtr);
 	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
     }
     DICT(objPtr) = dict;
@@ -894,13 +898,11 @@ InvalidateDictChain(
 static void InvalidateListRep(
     Tcl_Obj *dictObj
 ) {
-    void *tmp;
+    Tcl_Obj *listObj;
 
     if (dictObj->internalRep.twoPtrValue.ptr2 != NULL) {
-	tmp = dictObj->internalRep.twoPtrValue.ptr1;
-	dictObj->internalRep.twoPtrValue.ptr1 = dictObj->internalRep.twoPtrValue.ptr2;
-	TclFreeListInternalRep(dictObj);
-	dictObj->internalRep.twoPtrValue.ptr1 = tmp;
+	listObj = dictObj->internalRep.twoPtrValue.ptr2;
+	Tcl_DecrRefCount(listObj);
 	dictObj->internalRep.twoPtrValue.ptr2 = NULL;
     }
 }
@@ -1464,7 +1466,7 @@ Tcl_DbNewDictObj(
     Dict *dict;
 
     TclDbNewObj(dictPtr, file, line);
-    InvalidateOtherReps(dictPtr);
+    TclInvalidateStringRep(dictPtr);
     dict = ckalloc(sizeof(Dict));
     InitChainTable(dict);
     dict->epoch = 0;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ca34bd7..94fa713 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2512,6 +2512,28 @@ typedef struct List {
 
 #define DICT_PATH_NON_EXISTENT	((Tcl_Obj *) (void *) 1)
 
+/* 
+ * Macros for tclStringType objects
+ */
+
+#define TclStringGetPrev(objPtr)					    \
+    ((Tcl_Obj *)((objPtr)->internalRep.twoPtrValue.ptr2))
+#define TclStringSetPrev(objPtr,prevPtr)				    \
+    do {								    \
+	(objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (prevPtr);   \
+    } while (0)
+#define TclStringInvalidatePrev(objPtr)				    \
+    do {								    \
+	if (TclStringGetPrev((objPtr)) != NULL) {			    \
+	    Tcl_DecrRefCount(TclStringGetPrev((objPtr)));		    \
+	}								    \
+	(objPtr)->internalRep.twoPtrValue.ptr2 = NULL;		    \
+    } while (0)
+
+#define TclStringPrevIs(objPtr, checkTypePtr) \
+    (TclStringGetPrev((objPtr))->typePtr == &(checkTypePtr))
+
+
 /*
  *----------------------------------------------------------------
  * Data structures related to the filesystem internals
@@ -3018,7 +3040,6 @@ MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
 MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
 			    int *lines, Tcl_Obj *const *elems);
 MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
-MODULE_SCOPE void	TclFreeListInternalRep(Tcl_Obj *listPtr);
 MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
 MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
@@ -3040,6 +3061,7 @@ MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
 MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[],
 			    Tcl_Namespace *nsPtr, int flags);
+MODULE_SCOPE Tcl_Obj *	TclObjLookupTyped (Tcl_Obj * objPtr, Tcl_ObjType *typeptr);
 MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
 			    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
 MODULE_SCOPE int	TclParseBackslash(const char *src,
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index dc40a53..0852c8c 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -21,6 +21,7 @@
 static List *		AttemptNewList(Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
 static List *		NewListIntRep(int objc, Tcl_Obj *const objv[], int p);
+static void		FreeListInternalRep(Tcl_Obj *listPtr);
 static void		DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
 static int		SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static void		UpdateStringOfList(Tcl_Obj *listPtr);
@@ -40,7 +41,7 @@ static void		UpdateStringOfList(Tcl_Obj *listPtr);
 
 const Tcl_ObjType tclListType = {
     "list",			/* name */
-    TclFreeListInternalRep,	/* freeIntRepProc */
+    FreeListInternalRep,	/* freeIntRepProc */
     DupListInternalRep,		/* dupIntRepProc */
     UpdateStringOfList,		/* updateStringProc */
     SetListFromAny		/* setFromAnyProc */
@@ -1736,7 +1737,7 @@ TclListObjSetElement(
 /*
  *----------------------------------------------------------------------
  *
- * TclFreeListInternalRep --
+ * FreeListInternalRep --
  *
  *	Deallocate the storage associated with a list object's internal
  *	representation.
@@ -1752,8 +1753,8 @@ TclListObjSetElement(
  *----------------------------------------------------------------------
  */
 
-void
-TclFreeListInternalRep(
+static void
+FreeListInternalRep(
     Tcl_Obj *listPtr)		/* List object with internal rep to free. */
 {
     List *listRepPtr = ListRepPtr(listPtr);
@@ -1822,16 +1823,27 @@ SetListFromAny(
     Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
     Tcl_Obj *objPtr)		/* The object to convert. */
 {
+    Tcl_Obj *listPtr;
     List *listRepPtr;
     Tcl_Obj **elemPtrs;
 
     /*
-     * Dictionaries are a special case; they have a string representation such
-     * that *all* valid dictionaries are valid lists. Hence we can convert
-     * more directly.
-     
+     * Dictionaries are a special case; they may have stored a previous list
+     * representation
      */
 
+     listPtr = TclObjLookupTyped(objPtr, &tclListType);
+     if (listPtr != NULL) {
+	Tcl_IncrRefCount(listPtr);
+	TclFreeIntRep(objPtr);
+	DupListInternalRep(listPtr, objPtr); 
+	Tcl_DecrRefCount(listPtr);
+	objPtr->typePtr = &tclListType;
+	/* To Do: Maybe keep the dict intrep around in case this object is
+	 * used as a dict again */
+	return TCL_OK;
+     }
+
     if (objPtr->typePtr == &tclDictType) {
 	Tcl_Obj *keyPtr, *valuePtr;
 	Tcl_DictSearch search;
@@ -1846,33 +1858,25 @@ SetListFromAny(
 	 * dictionary or iterating over it will not fail.
 	 */
 
-	if (objPtr->internalRep.twoPtrValue.ptr2 != NULL) {
-	    /* A usable list representation exists.  */
-	    listRepPtr = objPtr->internalRep.twoPtrValue.ptr2;
-	    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
-	    /* To Do: Maybe keep the dict intrep around in case this object is
-	     * used as a dict again */
-	} else {
-	    Tcl_DictObjSize(NULL, objPtr, &size);
-	    listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
-	    if (!listRepPtr) {
-		return TCL_ERROR;
-	    }
-	    listRepPtr->elemCount = 2 * size;
+	Tcl_DictObjSize(NULL, objPtr, &size);
+	listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
+	if (!listRepPtr) {
+	    return TCL_ERROR;
+	}
+	listRepPtr->elemCount = 2 * size;
 
-	    /*
-	     * Populate the list representation.
-	     */
+	/*
+	 * Populate the list representation.
+	 */
 
-	    elemPtrs = &listRepPtr->elements;
-	    Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
-	    while (!done) {
-		*elemPtrs++ = keyPtr;
-		*elemPtrs++ = valuePtr;
-		Tcl_IncrRefCount(keyPtr);
-		Tcl_IncrRefCount(valuePtr);
-		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
-	    }
+	elemPtrs = &listRepPtr->elements;
+	Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
+	while (!done) {
+	    *elemPtrs++ = keyPtr;
+	    *elemPtrs++ = valuePtr;
+	    Tcl_IncrRefCount(keyPtr);
+	    Tcl_IncrRefCount(valuePtr);
+	    Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
 	}
     } else {
 	int estCount, length;
diff --git a/generic/tclObj.c b/generic/tclObj.c
index df17f13..ea1e5ae 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4492,6 +4492,46 @@ Tcl_RepresentationCmd(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TclLookupObjTyped  --
+ *
+ *	Given a Tcl_Obj, find an corresponding object, if one exists, of a
+ *	given type.
+ *
+ * Results:
+ *	The found object, or, if no such corresponding object was found, NULL.
+ *	
+ *
+ * Side effects:
+ *	None
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclObjLookupTyped (Tcl_Obj * objPtr, Tcl_ObjType *typePtr) {
+    Tcl_Obj *foundPtr;
+    if (typePtr == objPtr->typePtr) {
+	return objPtr;
+    }
+    if (objPtr->typePtr == &tclStringType) {
+	foundPtr = TclStringGetPrev(objPtr);
+	if (foundPtr == NULL) {
+	    return NULL;
+	}
+	return TclObjLookupTyped(foundPtr, typePtr);
+    }
+    if (typePtr == &tclListType) {
+	if (objPtr->typePtr == &tclDictType && objPtr->internalRep.twoPtrValue.ptr2 != NULL) {
+	    /* A usable list representation exists.  */
+	    return objPtr->internalRep.twoPtrValue.ptr2;
+	}
+    }
+    return NULL;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index e3cede6..8a95554 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -379,6 +379,7 @@ Tcl_NewUnicodeObj(
     Tcl_Obj *objPtr;
 
     TclNewObj(objPtr);
+    TclStringSetPrev(objPtr, NULL); 
     SetUnicodeObj(objPtr, unicode, numChars);
     return objPtr;
 }
@@ -942,11 +943,17 @@ Tcl_SetUnicodeObj(
     int numChars)		/* Number of characters in the unicode
 				 * string. */
 {
+    Tcl_Obj *prevPtr = NULL;
     if (Tcl_IsShared(objPtr)) {
 	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
     }
+    if (objPtr->typePtr != NULL && objPtr->typePtr != &tclStringType) {
+	prevPtr = Tcl_DuplicateObj(objPtr);
+	Tcl_IncrRefCount(prevPtr);
+    }
     TclFreeIntRep(objPtr);
     SetUnicodeObj(objPtr, unicode, numChars);
+    TclStringSetPrev(objPtr, prevPtr); 
 }
 
 static int
@@ -992,7 +999,6 @@ SetUnicodeObj(
     stringPtr->unicode[numChars] = 0;
     stringPtr->numChars = numChars;
     stringPtr->hasUnicode = 1;
-
     TclInvalidateStringRep(objPtr);
     stringPtr->allocated = 0;
 }
@@ -1328,6 +1334,9 @@ AppendUnicodeToUnicodeRep(
     }
 
     SetStringFromAny(NULL, objPtr);
+    if (appendNumChars > 0) {
+	TclStringInvalidatePrev(objPtr);
+    }
     stringPtr = GET_STRING(objPtr);
 
     /*
@@ -1481,6 +1490,7 @@ AppendUtfToUtfRep(
     if (numBytes == 0) {
 	return;
     }
+    TclStringInvalidatePrev(objPtr);
 
     /*
      * Copy the new string onto the end of the old string, then add the
@@ -2782,6 +2792,9 @@ ExtendUnicodeRepWithString(
     if (numAppendChars == -1) {
 	TclNumUtfChars(numAppendChars, bytes, numBytes);
     }
+    if (numAppendChars > 0) {
+	TclStringInvalidatePrev(objPtr);
+    }
     needed = numOrigChars + numAppendChars;
     stringCheckLimits(needed);
 
@@ -2829,6 +2842,7 @@ DupStringInternalRep(
 {
     String *srcStringPtr = GET_STRING(srcPtr);
     String *copyStringPtr = NULL;
+    Tcl_Obj *prevPtr;
 
     if (srcStringPtr->numChars == -1) {
 	/*
@@ -2870,10 +2884,15 @@ DupStringInternalRep(
      * code, so it doesn't contain any extra bytes that might exist in the
      * source object.
      */
-
     copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0;
 
     SET_STRING(copyPtr, copyStringPtr);
+    prevPtr = TclStringGetPrev(srcPtr);
+    if (prevPtr != NULL) {
+	prevPtr = Tcl_DuplicateObj(prevPtr);
+	Tcl_IncrRefCount(prevPtr);
+    }
+    TclStringSetPrev(copyPtr, prevPtr);
     copyPtr->typePtr = &tclStringType;
 }
 
@@ -2901,6 +2920,8 @@ SetStringFromAny(
 {
     if (objPtr->typePtr != &tclStringType) {
 	String *stringPtr = stringAlloc(0);
+	Tcl_Obj *prevPtr = Tcl_DuplicateObj(objPtr);
+	Tcl_IncrRefCount(prevPtr);
 
 	/*
 	 * Convert whatever we have into an untyped value. Just A String.
@@ -2919,6 +2940,7 @@ SetStringFromAny(
 	stringPtr->maxChars = 0;
 	stringPtr->hasUnicode = 0;
 	SET_STRING(objPtr, stringPtr);
+	TclStringSetPrev(objPtr, prevPtr);
 	objPtr->typePtr = &tclStringType;
     }
     return TCL_OK;
@@ -2977,6 +2999,7 @@ ExtendStringRepWithUnicode(
     if (numChars == 0) {
 	return 0;
     }
+    TclStringInvalidatePrev(objPtr);
 
     if (objPtr->bytes == NULL) {
 	objPtr->length = 0;
@@ -3038,10 +3061,23 @@ static void
 FreeStringInternalRep(
     Tcl_Obj *objPtr)		/* Object with internal rep to free. */
 {
+    Tcl_Obj * prevPtr = TclStringGetPrev(objPtr);
+    if (prevPtr != NULL) {
+	Tcl_DecrRefCount(prevPtr);
+    }
     ckfree(GET_STRING(objPtr));
     objPtr->typePtr = NULL;
 }
 
+static void InvalidateCachedReps(
+    Tcl_Obj *objPtr
+) {
+    Tcl_Obj * prevPtr = TclStringGetPrev(objPtr);
+    if (prevPtr != NULL) {
+	Tcl_DecrRefCount(TclStringGetPrev(objPtr));
+    }
+}
+
 /*
  * Local Variables:
  * mode: c
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 018f006..aa67895 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -620,15 +620,20 @@ void
 TclThreadFreeObj(
     Tcl_Obj *objPtr)
 {
+    return;
     Cache *cachePtr;
 
     GETCACHE(cachePtr);
 
+
     /*
      * Get this thread's list and push on the free Tcl_Obj.
      */
 
     objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
+    if (objPtr == 0x1c19247) {
+	Tcl_WriteChars(Tcl_GetStdChannel(TCL_STDOUT), "helloGro", -1);
+    }
     cachePtr->firstObjPtr = objPtr;
     if (cachePtr->numObjects == 0) {
 	cachePtr->lastPtr = objPtr;
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index f5aa84e..29bc0f5 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -734,7 +734,7 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [
     AC_MSG_CHECKING([for build with symbols])
     AC_ARG_ENABLE(symbols,
 	AC_HELP_STRING([--enable-symbols],
-	    [build with debugging symbols (default: off)]),
+	    [build with debugging symbols (all, compile, or mem) (default: off)]),
 	[tcl_ok=$enableval], [tcl_ok=no])
 # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
     DBGX=""
-- 
cgit v0.12