diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 810 |
1 files changed, 440 insertions, 370 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index 8869e9b..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -12,13 +12,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclObj.c,v 1.163 2009/10/18 10:39:41 mistachkin Exp $ */ #include "tclInt.h" #include "tommath.h" -#include <float.h> #include <math.h> /* @@ -56,9 +53,9 @@ char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * Structure for tracking the source file and line number where a given Tcl_Obj - * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity - * checking purposes. + * Structure for tracking the source file and line number where a given + * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, + * for sanity checking purposes. */ typedef struct ObjData { @@ -80,33 +77,28 @@ typedef struct ObjData { */ typedef struct ThreadSpecificData { - Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj - * generated by a call to the function - * EvalTokensStandard() from a literal text - * where bs+nl sequences occured in it, if - * any. I.e. this table keeps track of - * invisible/stripped continuation lines. Its - * keys are Tcl_Obj pointers, the values are - * ContLineLoc pointers. See the file - * tclCompile.h for the definition of this - * structure, and for references to all related - * places in the core. - */ + Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj + * generated by a call to the function + * TclSubstTokens() from a literal text + * where bs+nl sequences occured in it, if + * any. I.e. this table keeps track of + * invisible and stripped continuation lines. + * Its keys are Tcl_Obj pointers, the values + * are ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all + * related places in the core. */ #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) - /* - * Thread local table that is used to check that a Tcl_Obj was not - * allocated by some other thread. - */ - - Tcl_HashTable *objThreadMap; + Tcl_HashTable *objThreadMap;/* Thread local table that is used to check + * that a Tcl_Obj was not allocated by some + * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -static void ContLineLocFree (char* clientData); -static void TclThreadFinalizeContLines (ClientData clientData); -static ThreadSpecificData* TclGetContLineTable (void); +static void TclThreadFinalizeContLines(ClientData clientData); +static ThreadSpecificData *TclGetContLineTable(void); /* * Nested Tcl_Obj deletion management support @@ -155,11 +147,11 @@ typedef struct PendingObjData { #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ - * for our pointer chain: push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + * for our pointer chain: push onto the head of the stack. */ \ + (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) #define PopObjToDelete(contextPtr,objPtrVar) \ - (objPtrVar) = (contextPtr)->deletionStack; \ + (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* @@ -169,10 +161,14 @@ typedef struct PendingObjData { static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData +#elif HAVE_FAST_TSD +static __thread PendingObjData pendingObjData; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = (PendingObjData *) \ + PendingObjData *const contextPtr = \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif @@ -181,27 +177,27 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7fff) { \ - mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ - *temp = bignum; \ - (objPtr)->internalRep.ptrAndLongRep.ptr = temp; \ + if ((bignum).used > 0x7fff) { \ + mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.ptrAndLongRep.ptr = temp; \ (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \ - } else { \ - if ((bignum).alloc > 0x7fff) { \ - mp_shrink(&(bignum)); \ - } \ + } else { \ + if ((bignum).alloc > 0x7fff) { \ + mp_shrink(&(bignum)); \ + } \ (objPtr)->internalRep.ptrAndLongRep.ptr = (void *) (bignum).dp; \ (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } #define UNPACK_BIGNUM(objPtr, bignum) \ if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.ptrAndLongRep.ptr; \ + } else { \ + (bignum).dp = (objPtr)->internalRep.ptrAndLongRep.ptr; \ (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ - (bignum).alloc = \ + (bignum).alloc = \ ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ } @@ -211,12 +207,11 @@ 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); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt(Tcl_Obj *objPtr); static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif @@ -249,48 +244,48 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); */ static const Tcl_ObjType oldBooleanType = { - "boolean", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { - "double", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { - "bignum", /* name */ - FreeBignum, /* freeIntRepProc */ - DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* @@ -330,11 +325,11 @@ const Tcl_HashKeyType tclObjHashKeyType = { */ Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; /* @@ -414,7 +409,7 @@ TclInitObjSubsystem(void) /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_RegisterObjType(&tclWideIntType); #endif @@ -424,6 +419,7 @@ TclInitObjSubsystem(void) tclObjsFreed = 0; { int i; + for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } @@ -464,12 +460,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree((char *) objData); + ckfree(objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree((char *) tablePtr); + ckfree(tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -531,8 +527,8 @@ TclFinalizeObjects(void) *---------------------------------------------------------------------- */ -static ThreadSpecificData* -TclGetContLineTable() +static ThreadSpecificData * +TclGetContLineTable(void) { /* * Initialize the hashtable tracking invisible continuation lines. For @@ -543,10 +539,11 @@ TclGetContLineTable() */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); - Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); + Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } return tsdPtr; } @@ -569,23 +566,47 @@ TclGetContLineTable() *---------------------------------------------------------------------- */ -ContLineLoc* -TclContinuationsEnter(Tcl_Obj* objPtr, - int num, - int* loc) +ContLineLoc * +TclContinuationsEnter( + Tcl_Obj *objPtr, + int num, + int *loc) { int newEntry; ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry* hPtr = - Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); + ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); - ContLineLoc* clLocPtr = - (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); + if (!newEntry) { + /* + * We're entering ContLineLoc data for the same value more than one + * time. Taking care not to leak the old entry. + * + * This can happen when literals in a proc body are shared. See for + * example test info-30.19 where the action (code) for all branches of + * the switch command is identical, mapping them all to the same + * literal. An interesting result of this is that the number and + * locations (offset) of invisible continuation lines in the literal + * are the same for all occurences. + * + * Note that while reusing the existing entry is possible it requires + * the same actions as for a new entry because we have to copy the + * incoming num/loc data even so. Because we are called from + * TclContinuationsEnterDerived for this case, which modified the + * stored locations (Rebased to the proper relative offset). Just + * returning the stored entry would rebase them a second time, or + * more, hosing the data. It is easier to simply replace, as we are + * doing. + */ + + ckfree(Tcl_GetHashValue(hPtr)); + } clLocPtr->num = num; - memcpy (&clLocPtr->loc, loc, num*sizeof(int)); - clLocPtr->loc[num] = CLL_END; /* Sentinel */ - Tcl_SetHashValue (hPtr, clLocPtr); + memcpy(&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue(hPtr, clLocPtr); return clLocPtr; } @@ -610,8 +631,14 @@ TclContinuationsEnter(Tcl_Obj* objPtr, */ void -TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) +TclContinuationsEnterDerived( + Tcl_Obj *objPtr, + int start, + int *clNext) { + int length, end, num; + int *wordCLLast = clNext; + /* * We have to handle invisible continuations lines here as well, despite * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If @@ -632,20 +659,15 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) */ /* - * First compute the range of the word within the script. + * First compute the range of the word within the script. (Is there a + * better way which doesn't shimmer?) */ - int length, end, num; - int* wordCLLast = clNext; - Tcl_GetStringFromObj(objPtr, &length); - /* Is there a better way which doesn't shimmer ? */ - - end = start + length; /* first char after the word */ + end = start + length; /* First char after the word */ /* - * Then compute the table slice covering the range of - * the word. + * Then compute the table slice covering the range of the word. */ while (*wordCLLast >= 0 && *wordCLLast < end) { @@ -653,21 +675,19 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) } /* - * And generate the table from the slice, if it was - * not empty. + * And generate the table from the slice, if it was not empty. */ num = wordCLLast - clNext; if (num) { int i; - ContLineLoc* clLocPtr = - TclContinuationsEnter(objPtr, num, clNext); + ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); /* * Re-base the locations. */ - for (i=0;i<num;i++) { + for (i=0 ; i<num ; i++) { clLocPtr->loc[i] -= start; /* @@ -689,9 +709,9 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) * TclContinuationsCopy -- * * This procedure is a helper which copies the continuation line - * information associated with a Tcl_Obj* to another Tcl_Obj*. - * It is assumed that both contain the same string/script. Use - * this when a script is duplicated because it was shared. + * information associated with a Tcl_Obj* to another Tcl_Obj*. It is + * assumed that both contain the same string/script. Use this when a + * script is duplicated because it was shared. * * Results: * None. @@ -704,13 +724,16 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) */ void -TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) +TclContinuationsCopy( + Tcl_Obj *objPtr, + Tcl_Obj *originObjPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); if (hPtr) { - ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); + ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } @@ -725,8 +748,8 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) * information associated with a Tcl_Obj*, if it has any. * * Results: - * A reference to the continuation line location table, or NULL - * if the Tcl_Obj* has no such information associated with it. + * A reference to the continuation line location table, or NULL if the + * Tcl_Obj* has no such information associated with it. * * Side effects: * None. @@ -735,17 +758,18 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) *---------------------------------------------------------------------- */ -ContLineLoc* -TclContinuationsGet(Tcl_Obj* objPtr) +ContLineLoc * +TclContinuationsGet( + Tcl_Obj *objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); - if (hPtr) { - return (ContLineLoc*) Tcl_GetHashValue (hPtr); - } else { - return NULL; + if (!hPtr) { + return NULL; } + return Tcl_GetHashValue(hPtr); } /* @@ -767,7 +791,8 @@ TclContinuationsGet(Tcl_Obj* objPtr) */ static void -TclThreadFinalizeContLines (ClientData clientData) +TclThreadFinalizeContLines( + ClientData clientData) { /* * Release the hashtable tracking invisible continuation lines. @@ -778,46 +803,16 @@ TclThreadFinalizeContLines (ClientData clientData) Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - /* - * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because - * here we can be sure that the compiler will not hold references to - * the data in the hashtable, and using TEF might bork the - * finalization sequence. - */ - ContLineLocFree (Tcl_GetHashValue (hPtr)); - Tcl_DeleteHashEntry (hPtr); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); } - Tcl_DeleteHashTable (tsdPtr->lineCLPtr); - ckfree((char *) tsdPtr->lineCLPtr); + Tcl_DeleteHashTable(tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } /* - *---------------------------------------------------------------------- - * - * ContLineLocFree -- - * - * The freProc for continuation line location tables. - * - * Results: - * None. - * - * Side effects: - * Releases memory. - * - * TIP #280 - *---------------------------------------------------------------------- - */ - -static void -ContLineLocFree (char* clientData) -{ - ckfree (clientData); -} - -/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -935,7 +930,7 @@ Tcl_GetObjType( Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = (const Tcl_ObjType *) Tcl_GetHashValue(hPtr); + typePtr = Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -978,7 +973,12 @@ Tcl_ConvertToType( */ if (typePtr->setFromAnyProc == NULL) { - Tcl_Panic("may not convert object to type %s", typePtr->name); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't convert value to type %s", typePtr->name)); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + } + return TCL_ERROR; } return typePtr->setFromAnyProc(interp, objPtr); @@ -1079,12 +1079,11 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; - hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); + hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } @@ -1093,7 +1092,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *) ckalloc(sizeof(ObjData)); + objData = ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1228,7 +1227,7 @@ Tcl_DbNewObj( * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. + * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ @@ -1252,12 +1251,12 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *) ckalloc(bytesToAlloc); + basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } @@ -1302,13 +1301,27 @@ TclFreeObj( ObjInitDeletionContext(context); + /* + * Check for a double free of the same value. This is slightly tricky + * because it is customary to free a Tcl_Obj when its refcount falls + * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, + * and so on, is always a sign of a botch in the caller. + */ if (objPtr->refCount < -1) { - Tcl_Panic("Reference count for %lx was negative", objPtr); + Tcl_Panic("Reference count for %p was negative", objPtr); } + /* + * Now, in case we just approved drop from 1 to 0 as acceptable, make + * sure we do not accept a second free when falling from 0 to -1. + * Skip that possibility so any double free will trigger the panic. + */ + objPtr->refCount = -1; - /* Invalidate the string rep first so we can use the bytes value - * for our pointer chain, and signal an obj deletion (as opposed - * to shimmering) with 'length == -1' */ + /* + * Invalidate the string rep first so we can use the bytes value for our + * pointer chain, and signal an obj deletion (as opposed to shimmering) + * with 'length == -1'. + */ TclInvalidateStringRep(objPtr); objPtr->length = -1; @@ -1324,19 +1337,19 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context,objToFree); + PopObjToDelete(context, objToFree); TCL_DTRACE_OBJ_FREE(objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objToFree); + ckfree(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1345,22 +1358,23 @@ TclFreeObj( /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the - * finalization. We have to access it using the low-level call and then - * check for validity. This function can be called after - * TclFinalizeThreadData() has already killed the thread-global data - * structures. Performing TCL_TSD_INIT will leave us with an - * un-initialized memory block upon which we crash (if we where to access - * the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the finalization. + * We have to access it using the low-level call and then check for + * validity. This function can be called after TclFinalizeThreadData() has + * already killed the thread-global data structures. Performing + * TCL_TSD_INIT will leave us with an un-initialized memory block upon + * which we crash (if we where to access the uninitialized hashtable). */ { - ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + if (tsdPtr->lineCLPtr) { - Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); - Tcl_DeleteHashEntry (hPtr); + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); } } } @@ -1371,9 +1385,11 @@ void TclFreeObj( register Tcl_Obj *objPtr) /* The object to be freed. */ { - /* Invalidate the string rep first so we can use the bytes value - * for our pointer chain, and signal an obj deletion (as opposed - * to shimmering) with 'length == -1' */ + /* + * Invalidate the string rep first so we can use the bytes value for our + * pointer chain, and signal an obj deletion (as opposed to shimmering) + * with 'length == -1'. + */ TclInvalidateStringRep(objPtr); objPtr->length = -1; @@ -1417,7 +1433,8 @@ TclFreeObj( ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context,objToFree); + + PopObjToDelete(context, objToFree); TCL_DTRACE_OBJ_FREE(objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { @@ -1432,27 +1449,28 @@ TclFreeObj( /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the - * finalization. We have to access it using the low-level call and then - * check for validity. This function can be called after - * TclFinalizeThreadData() has already killed the thread-global data - * structures. Performing TCL_TSD_INIT will leave us with an - * un-initialized memory block upon which we crash (if we where to access - * the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the finalization. + * We have to access it using the low-level call and then check for + * validity. This function can be called after TclFinalizeThreadData() has + * already killed the thread-global data structures. Performing + * TCL_TSD_INIT will leave us with an un-initialized memory block upon + * which we crash (if we where to access the uninitialized hashtable). */ { - ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + if (tsdPtr->lineCLPtr) { - Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); - Tcl_DeleteHashEntry (hPtr); + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); } } } } -#endif +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -1478,7 +1496,6 @@ TclObjBeingDeleted( { return (objPtr->length == -1); } - /* *---------------------------------------------------------------------- @@ -1595,6 +1612,7 @@ Tcl_GetString( * must be written in such a way that (objPtr->bytes) never becomes * NULL. This panic was added in Tcl 8.1. */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } @@ -1671,7 +1689,6 @@ Tcl_InvalidateStringRep( { TclInvalidateStringRep(objPtr); } - /* *---------------------------------------------------------------------- @@ -1696,8 +1713,8 @@ Tcl_InvalidateStringRep( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewBooleanObj( @@ -1745,6 +1762,7 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -1797,6 +1815,7 @@ Tcl_DbNewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -1830,7 +1849,7 @@ Tcl_SetBooleanObj( int Tcl_GetBooleanFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get boolean. */ register int *boolPtr) /* Place to store resulting boolean. */ { @@ -1864,7 +1883,7 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; @@ -1878,7 +1897,7 @@ Tcl_GetBooleanFromObj( /* *---------------------------------------------------------------------- * - * SetBooleanFromAny -- + * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -1895,8 +1914,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. */ { @@ -1919,7 +1938,7 @@ SetBooleanFromAny( goto badBoolean; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { goto badBoolean; } @@ -1958,7 +1977,10 @@ ParseBoolean( const char *str = TclGetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { - /* longest valid boolean string rep. is "false" */ + /* + * Longest valid boolean string rep. is "false". + */ + return TCL_ERROR; } @@ -1984,6 +2006,7 @@ ParseBoolean( for (i=0; i < length; i++) { char c = str[i]; + switch (c) { case 'A': case 'E': case 'F': case 'L': case 'N': case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': @@ -2218,7 +2241,7 @@ Tcl_SetDoubleObj( int Tcl_GetDoubleFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get a double. */ register double *dblPtr) /* Place to store resulting double. */ { @@ -2228,6 +2251,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); } return TCL_ERROR; } @@ -2245,7 +2270,7 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; @@ -2315,8 +2340,8 @@ UpdateStringOfDouble( Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); - objPtr->bytes = (char *) ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2350,8 +2375,8 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewIntObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewIntObj( @@ -2391,6 +2416,7 @@ Tcl_NewIntObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetIntObj void Tcl_SetIntObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2431,7 +2457,7 @@ Tcl_SetIntObj( int Tcl_GetIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get a int. */ register int *intPtr) /* Place to store resulting int. */ { @@ -2479,6 +2505,7 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { long l; + return TclGetLongFromObj(interp, objPtr, &l); } @@ -2510,8 +2537,8 @@ UpdateStringOfInt( len = TclFormatInt(buffer, objPtr->internalRep.longValue); - objPtr->bytes = ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2692,7 +2719,7 @@ Tcl_SetLongObj( int Tcl_GetLongFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get a long. */ register long *longPtr) /* Place to store resulting long. */ { @@ -2701,7 +2728,7 @@ Tcl_GetLongFromObj( *longPtr = objPtr->internalRep.longValue; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX @@ -2712,6 +2739,7 @@ Tcl_GetLongFromObj( */ Tcl_WideInt w = objPtr->internalRep.wideValue; + if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { *longPtr = Tcl_WideAsLong(w); @@ -2722,12 +2750,9 @@ Tcl_GetLongFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -2747,7 +2772,8 @@ Tcl_GetLongFromObj( / DIGIT_BIT) { unsigned long value = 0, numBytes = sizeof(long); long scratch; - unsigned char *bytes = (unsigned char *)&scratch; + unsigned char *bytes = (unsigned char *) &scratch; + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; @@ -2760,7 +2786,7 @@ Tcl_GetLongFromObj( return TCL_OK; } } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif if (interp != NULL) { @@ -2776,7 +2802,7 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -2814,11 +2840,11 @@ UpdateStringOfWideInt( sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); - objPtr->bytes = ckalloc((unsigned) len + 1); + objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } -#endif /* !NO_WIDE_TYPE */ +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2973,7 +2999,7 @@ Tcl_SetWideIntObj( && (wideValue <= (Tcl_WideInt) LONG_MAX)) { TclSetLongObj(objPtr, (long) wideValue); } else { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG TclSetWideIntObj(objPtr, wideValue); #else mp_int big; @@ -3007,13 +3033,13 @@ Tcl_SetWideIntObj( int Tcl_GetWideIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; @@ -3025,12 +3051,9 @@ Tcl_GetWideIntFromObj( } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3076,7 +3099,7 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -3102,7 +3125,7 @@ SetWideIntFromAny( Tcl_WideInt w; return Tcl_GetWideIntFromObj(interp, objPtr, &w); } -#endif /* !NO_WIDE_TYPE */ +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3126,7 +3149,7 @@ FreeBignum( UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { - ckfree((char *) objPtr->internalRep.ptrAndLongRep.ptr); + ckfree(objPtr->internalRep.ptrAndLongRep.ptr); } objPtr->typePtr = NULL; } @@ -3211,13 +3234,13 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc((size_t) size); + stringVal = ckalloc(size); status = mp_toradix_n(&bignumVal, stringVal, 10, size); if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing null byte */ + objPtr->length = size - 1; /* size includes a trailing NUL byte. */ } /* @@ -3332,6 +3355,7 @@ GetBignumFromObj( if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; + UNPACK_BIGNUM(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { @@ -3349,7 +3373,7 @@ GetBignumFromObj( TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { TclBNInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); @@ -3358,12 +3382,9 @@ GetBignumFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3491,7 +3512,7 @@ Tcl_SetBignumObj( return; } tooLargeForLong: -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((size_t) bignumValue->used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; @@ -3523,6 +3544,24 @@ Tcl_SetBignumObj( TclSetBignumIntRep(objPtr, bignumValue); } +/* + *---------------------------------------------------------------------- + * + * TclSetBignumIntRep -- + * + * Install a bignum into the internal representation of an object. + * + * Results: + * None. + * + * Side effects: + * Object internal representation is updated and object type is set. The + * bignum value is cleared, since ownership has transferred to the + * object. + * + *---------------------------------------------------------------------- + */ + void TclSetBignumIntRep( Tcl_Obj *objPtr, @@ -3533,8 +3572,9 @@ TclSetBignumIntRep( /* * Clear the mp_int value. - * Don't call mp_clear() because it would free the digit array - * we just packed into the Tcl_Obj. + * + * Don't call mp_clear() because it would free the digit array we just + * packed into the Tcl_Obj. */ bignumValue->dp = NULL; @@ -3547,14 +3587,23 @@ TclSetBignumIntRep( * * TclGetNumberFromObj -- * + * Extracts a number (of any possible numeric type) from an object. + * * Results: + * Whether the extraction worked. The type is stored in the variable + * referred to by the typePtr argument, and a pointer to the + * representation is stored in the variable referred to by the + * clientDataPtr. * * Side effects: + * Can allocate thread-specific data for handling the copy-out space for + * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ -int TclGetNumberFromObj( +int +TclGetNumberFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, @@ -3567,18 +3616,18 @@ int TclGetNumberFromObj( } else { *typePtr = TCL_NUMBER_DOUBLE; } - *clientDataPtr = &(objPtr->internalRep.doubleValue); + *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &(objPtr->internalRep.longValue); + *clientDataPtr = &objPtr->internalRep.longValue; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; - *clientDataPtr = &(objPtr->internalRep.wideValue); + *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } #endif @@ -3642,23 +3691,21 @@ Tcl_DbIncrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to incr ref count of " - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "incr ref count"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ ++(objPtr)->refCount; } @@ -3707,19 +3754,17 @@ Tcl_DbDecrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to decr ref count of " - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "decr ref count"); } /* @@ -3730,14 +3775,15 @@ Tcl_DbDecrRefCount( ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree((char *) objData); + ckfree(objData); } Tcl_DeleteHashEntry(hPtr); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3787,22 +3833,21 @@ Tcl_DbIsShared( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; + if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to check shared status of" - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "check shared status"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -3814,7 +3859,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif +#endif /* TCL_COMPILE_STATS */ return ((objPtr)->refCount > 1); } @@ -3868,11 +3913,10 @@ AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; - Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr = keyPtr; + Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); - hPtr->key.oneWordValue = (char *) objPtr; + hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; @@ -3901,7 +3945,7 @@ TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; register const char *p1, *p2; register int l1, l2; @@ -3965,7 +4009,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree((char *) hPtr); + ckfree(hPtr); } /* @@ -3991,11 +4035,10 @@ TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; - const char *string = TclGetString(objPtr); - int length = objPtr->length; + Tcl_Obj *objPtr = keyPtr; + int length; + const char *string = TclGetStringFromObj(objPtr, &length); unsigned int result = 0; - int i; /* * I tried a zillion different hash functions and asked many other people @@ -4005,16 +4048,37 @@ TclHashObjKey( * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and *non-decimal strings. + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. + * + * Note that this function is very weak against malicious strings; it's + * very easy to generate multiple keys that have the same hashcode. On the + * other hand, that hardly ever actually occurs and this function *is* + * very cheap, even by comparison with industry-standard hashes like FNV. + * If real strength of hash is required though, use a custom hash based on + * Bob Jenkins's lookup3(), but be aware that it's significantly slower. + * Tcl does not use that level of strength because it typically does not + * need it (and some of the aspects of that strength are genuinely + * unnecessary given the rest of Tcl's hash machinery, and the fact that + * we do not either transfer hashes to another machine, use them as a true + * substitute for equality, or attempt to minimize work in rebuilding the + * hash table). + * + * See also HashStringKey in tclHash.c. + * See also HashString in tclLiteral.c. + * + * See [tcl-Feature Request #2958832] */ - for (i=0 ; i<length ; i++) { - result += (result << 3) + string[i]; + if (length > 0) { + result = UCHAR(*string); + while (--length) { + result += (result << 3) + UCHAR(*++string); + } } return result; } @@ -4049,9 +4113,6 @@ Tcl_GetCommandFromObj( * global namespace. */ { register ResolvedCmdName *resPtr; - register Command *cmdPtr; - Namespace *refNsPtr; - int result; /* * Get the internal representation, converting to a command type if @@ -4073,30 +4134,35 @@ Tcl_GetCommandFromObj( */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr != &tclCmdNameType) - || (resPtr == NULL) - || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) - || (interp != cmdPtr->nsPtr->interp) - || (cmdPtr->flags & CMD_IS_DELETED) - || (cmdPtr->nsPtr->flags & NS_DYING) - || ((resPtr->refNsPtr != NULL) && - (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp)) - != resPtr->refNsPtr) - || (resPtr->refNsId != refNsPtr->nsId) - || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch))) - ) { - - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((result == TCL_OK) && resPtr) { - cmdPtr = resPtr->cmdPtr; - } else { - cmdPtr = NULL; - } + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + register Command *cmdPtr = resPtr->cmdPtr; + + if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) + && !(cmdPtr->flags & CMD_IS_DELETED) + && (interp == cmdPtr->nsPtr->interp) + && !(cmdPtr->nsPtr->flags & NS_DYING)) { + register Namespace *refNsPtr = (Namespace *) + TclGetCurrentNamespace(interp); + + if ((resPtr->refNsPtr == NULL) + || ((refNsPtr == resPtr->refNsPtr) + && (resPtr->refNsId == refNsPtr->nsId) + && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { + return (Tcl_Command) cmdPtr; + } + } } - return (Tcl_Command) cmdPtr; + /* + * OK, must create a new internal representation (or fail) as any cache we + * had is invalid one way or another. + */ + + if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } /* @@ -4114,7 +4180,7 @@ Tcl_GetCommandFromObj( * The object's old internal rep is freed. It's string rep is not * changed. The refcount in the Command structure is incremented to keep * it from being freed if the command is later deleted until - * TclExecuteByteCode has a chance to recognize that it was deleted. + * TclNRExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ @@ -4138,7 +4204,7 @@ TclSetCmdNameObj( } cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr = ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; @@ -4214,7 +4280,7 @@ FreeCmdNameInternalRep( Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - ckfree((char *) resPtr); + ckfree(resPtr); } } objPtr->typePtr = NULL; @@ -4287,6 +4353,10 @@ SetCmdNameFromAny( Namespace *currNsPtr; register ResolvedCmdName *resPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Find the Command structure, if any, that describes the command called * "name". Build a ResolvedCmdName that holds a cached pointer to this @@ -4307,7 +4377,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* @@ -4321,7 +4391,7 @@ SetCmdNameFromAny( } } else { TclFreeIntRep(objPtr); - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr = ckalloc(sizeof(ResolvedCmdName)); resPtr->refCount = 1; objPtr->internalRep.twoPtrValue.ptr1 = resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -4364,7 +4434,7 @@ SetCmdNameFromAny( * Implementation of the "tcl::unsupported::representation" command. * * Results: - * Reports the current representation (Tcl_Obj type) of its argument. + * Reports the current representation (Tcl_Obj type) of its argument. * * Side effects: * None. @@ -4379,44 +4449,44 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char refcountBuffer[TCL_INTEGER_SPACE+1]; - char objPtrBuffer[TCL_INTEGER_SPACE+3]; - char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2]; -#define TCLOBJ_TRUNCATE_STRINGREP 16 - char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1]; + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } - + /* - * value is a bignum with a refcount of 14, object pointer at - * 0x12345678, internal representation 0x45671234:0x98765432, - * string representation "1872361827361287" + * Value is a bignum with a refcount of 14, object pointer at 0x12345678, + * internal representation 0x45671234:0x98765432, string representation + * "1872361827361287" */ - sprintf(refcountBuffer, "%d", objv[1]->refCount); - sprintf(objPtrBuffer, "%p", (void *)objv[1]); - Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ? - objv[1]->typePtr->name : "pure string", " with a refcount of ", - refcountBuffer, ", object pointer at ", objPtrBuffer, NULL); + sprintf(ptrBuffer, "%p", (void *) objv[1]); + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, ptrBuffer); + if (objv[1]->typePtr) { - sprintf(internalRepBuffer, "%p:%p", - (void *)objv[1]->internalRep.twoPtrValue.ptr1, - (void *)objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendResult(interp, ", internal representation ", - internalRepBuffer, NULL); + sprintf(ptrBuffer, "%p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + Tcl_AppendPrintfToObj(descObj, ", internal representation %s", + ptrBuffer); } + if (objv[1]->bytes) { - strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP); - stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0; - Tcl_AppendResult(interp, ", string representation \"", - stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ? - "\"..." : "\".", NULL); + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); } else { - Tcl_AppendResult(interp, ", no string representation.", NULL); + Tcl_AppendToObj(descObj, ", no string representation", -1); } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } |