summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclDictObj.c85
-rw-r--r--generic/tclInt.h25
-rw-r--r--generic/tclListObj.c25
-rw-r--r--generic/tclObj.c40
-rw-r--r--generic/tclStringObj.c40
-rw-r--r--generic/tclThreadAlloc.c1
-rw-r--r--unix/Makefile.in1
-rw-r--r--unix/tcl.m42
8 files changed, 184 insertions, 35 deletions
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 428173d..613cdc8 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -62,6 +62,8 @@ static int DictWithCmd(ClientData dummy, Tcl_Interp *interp,
static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeDictInternalRep(Tcl_Obj *dictPtr);
static void InvalidateDictChain(Tcl_Obj *dictObj);
+static void InvalidateListRep(Tcl_Obj *dictObj);
+static void InvalidateOtherReps(Tcl_Obj *dictObj);
static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDict(Tcl_Obj *dictPtr);
static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
@@ -426,6 +428,7 @@ FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
Dict *dict = DICT(dictPtr);
+ InvalidateListRep(dictPtr);
dict->refcount--;
if (dict->refcount <= 0) {
@@ -497,13 +500,24 @@ UpdateStringOfDict(
const char *elem;
char *dst;
const int maxFlags = UINT_MAX / sizeof(int);
+ Tcl_Obj *listObj;
+ int numElems;
+
+ if (dictPtr->internalRep.twoPtrValue.ptr2 != NULL) {
+ listObj = dictPtr->internalRep.twoPtrValue.ptr2;
+ TclGetString(listObj);
+ dictPtr->bytes = listObj->bytes;
+ dictPtr->length = listObj->length;
+ listObj->bytes = NULL;
+ return;
+ }
/*
* This field is the most useful one in the whole hash structure, and it
* is not exposed by any API function...
*/
- int numElems = dict->table.numEntries * 2;
+ numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
@@ -603,8 +617,9 @@ SetDictFromAny(
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
- int isNew;
+ int isNew, needlist = 0;
Dict *dict = ckalloc(sizeof(Dict));
+ Tcl_Obj *listObj;
InitChainTable(dict);
@@ -614,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;
}
@@ -630,16 +647,8 @@ SetDictFromAny(
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
-
- /*
- * Not really a well-formed dictionary as there are duplicate
- * keys, so better get the string rep here so that we can
- * convert back.
- */
-
- (void) Tcl_GetString(objPtr);
-
- TclDecrRefCount(discardedValue);
+ needlist = 1;
+ Tcl_DecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
@@ -710,12 +719,21 @@ SetDictFromAny(
* Tcl_GetStringFromObj, to use that old internalRep.
*/
- TclFreeIntRep(objPtr);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
+ if (needlist) {
+ /* squirrel the list intrep away for use by SetListFromAny */
+ listObj = Tcl_DuplicateObj(listObj);
+ Tcl_IncrRefCount(listObj);
+ }
+ TclFreeIntRep(objPtr);
+ if (needlist) {
+ objPtr->internalRep.twoPtrValue.ptr2 = listObj;
+ } else {
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
DICT(objPtr) = dict;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -866,7 +884,7 @@ InvalidateDictChain(
Dict *dict = DICT(dictObj);
do {
- TclInvalidateStringRep(dictObj);
+ InvalidateOtherReps(dictObj);
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
@@ -877,6 +895,25 @@ InvalidateDictChain(
} while (dict != NULL);
}
+static void InvalidateListRep(
+ Tcl_Obj *dictObj
+) {
+ Tcl_Obj *listObj;
+
+ if (dictObj->internalRep.twoPtrValue.ptr2 != NULL) {
+ listObj = dictObj->internalRep.twoPtrValue.ptr2;
+ Tcl_DecrRefCount(listObj);
+ dictObj->internalRep.twoPtrValue.ptr2 = NULL;
+ }
+}
+
+static void InvalidateOtherReps(
+ Tcl_Obj * dictObj
+) {
+ TclInvalidateStringRep(dictObj);
+ InvalidateListRep(dictObj);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -917,7 +954,7 @@ Tcl_DictObjPut(
}
if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
+ InvalidateOtherReps(dictPtr);
}
dict = DICT(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
@@ -1017,7 +1054,7 @@ Tcl_DictObjRemove(
dict = DICT(dictPtr);
if (DeleteChainEntry(dict, keyPtr)) {
if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
+ InvalidateOtherReps(dictPtr);
}
dict->epoch++;
}
@@ -1631,7 +1668,7 @@ DictReplaceCmd(
dictPtr = Tcl_DuplicateObj(dictPtr);
}
if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
+ InvalidateOtherReps(dictPtr);
}
for (i=2 ; i<objc ; i+=2) {
Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
@@ -1681,9 +1718,7 @@ DictRemoveCmd(
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ InvalidateOtherReps(dictPtr);
for (i=2 ; i<objc ; i++) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
@@ -2155,7 +2190,7 @@ DictIncrCmd(
}
}
if (code == TCL_OK) {
- TclInvalidateStringRep(dictPtr);
+ InvalidateOtherReps(dictPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
@@ -2244,7 +2279,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
} else if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
+ InvalidateOtherReps(dictPtr);
}
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4cf86c4..d5c4345 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -883,6 +883,7 @@ typedef struct VarInHash {
(TclIsVarDirectModifyable(varPtr) &&\
(!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE))))
+
/*
*----------------------------------------------------------------
* Data structures related to procedures. These are used primarily in
@@ -2424,6 +2425,7 @@ typedef struct List {
#define TclListObjIsCanonical(listPtr) \
(((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
@@ -2510,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
@@ -3042,6 +3066,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 14b8a14..0852c8c 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -13,6 +13,7 @@
#include "tclInt.h"
+#define LIST(listObj) ((List *)(listObj)->internalRep.twoPtrValue.ptr1)
/*
* Prototypes for functions defined later in this file:
*/
@@ -20,8 +21,8 @@
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 DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
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);
@@ -1822,18 +1823,28 @@ 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. Only do this when there's no existing string rep; if
- * there is, it is the string rep that's authoritative (because it could
- * describe duplicate keys).
+ * Dictionaries are a special case; they may have stored a previous list
+ * representation
*/
- if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
+ 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;
int done, size;
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 6b850e3..2cf8b4a 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;
}
@@ -987,11 +988,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
@@ -1037,7 +1044,6 @@ SetUnicodeObj(
stringPtr->unicode[numChars] = 0;
stringPtr->numChars = numChars;
stringPtr->hasUnicode = 1;
-
TclInvalidateStringRep(objPtr);
stringPtr->allocated = 0;
}
@@ -1373,6 +1379,9 @@ AppendUnicodeToUnicodeRep(
}
SetStringFromAny(NULL, objPtr);
+ if (appendNumChars > 0) {
+ TclStringInvalidatePrev(objPtr);
+ }
stringPtr = GET_STRING(objPtr);
/*
@@ -1526,6 +1535,7 @@ AppendUtfToUtfRep(
if (numBytes == 0) {
return;
}
+ TclStringInvalidatePrev(objPtr);
/*
* Copy the new string onto the end of the old string, then add the
@@ -2827,6 +2837,9 @@ ExtendUnicodeRepWithString(
if (numAppendChars == -1) {
TclNumUtfChars(numAppendChars, bytes, numBytes);
}
+ if (numAppendChars > 0) {
+ TclStringInvalidatePrev(objPtr);
+ }
needed = numOrigChars + numAppendChars;
stringCheckLimits(needed);
@@ -2874,6 +2887,7 @@ DupStringInternalRep(
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
+ Tcl_Obj *prevPtr;
if (srcStringPtr->numChars == -1) {
/*
@@ -2915,10 +2929,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;
}
@@ -2946,6 +2965,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.
@@ -2964,6 +2985,7 @@ SetStringFromAny(
stringPtr->maxChars = 0;
stringPtr->hasUnicode = 0;
SET_STRING(objPtr, stringPtr);
+ TclStringSetPrev(objPtr, prevPtr);
objPtr->typePtr = &tclStringType;
}
return TCL_OK;
@@ -3022,6 +3044,7 @@ ExtendStringRepWithUnicode(
if (numChars == 0) {
return 0;
}
+ TclStringInvalidatePrev(objPtr);
if (objPtr->bytes == NULL) {
objPtr->length = 0;
@@ -3083,10 +3106,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..12ce1c3 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -624,6 +624,7 @@ TclThreadFreeObj(
GETCACHE(cachePtr);
+
/*
* Get this thread's list and push on the free Tcl_Obj.
*/
diff --git a/unix/Makefile.in b/unix/Makefile.in
index eb083e0..7d967e3 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -718,6 +718,7 @@ gdb-test: ${TCLTEST_EXE}
@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
+ @echo "$(GDBSCRIPT)" >> gdb.run
$(GDB) ./${TCLTEST_EXE} --command=gdb.run
rm gdb.run
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=""
generated by cgit v0.12 at 2024-12-03 17:52:37 (GMT)