diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 1618 |
1 files changed, 1153 insertions, 465 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index eb77e35..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -8,17 +8,15 @@ * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * 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.113 2006/09/30 19:00:13 msofer Exp $ */ #include "tclInt.h" -#include "tclCompile.h" #include "tommath.h" -#include <float.h> +#include <math.h> /* * Table of all object types. @@ -55,15 +53,52 @@ char *tclEmptyStringRep = &tclEmptyString; #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. + * 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 { + Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ + const char *file; /* The name of the source file calling this + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ +} ObjData; +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + +/* + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ + typedef struct ThreadSpecificData { - Tcl_HashTable *objThreadMap; + 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) + 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; -#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + +static void TclThreadFinalizeContLines(ClientData clientData); +static ThreadSpecificData *TclGetContLineTable(void); /* * Nested Tcl_Obj deletion management support @@ -112,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 /* @@ -125,11 +160,15 @@ typedef struct PendingObjData { #ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *CONST contextPtr = &pendingObjData + 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 @@ -138,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 = (void*) 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)); \ - } \ - (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ + } 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 = (mp_digit*) (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; \ } @@ -168,13 +207,13 @@ 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 static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -187,9 +226,6 @@ static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); -static int CompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static void FreeObjEntry(Tcl_HashEntry *hPtr); -static unsigned int HashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the CommandName object type. @@ -207,62 +243,62 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -static Tcl_ObjType oldBooleanType = { - "boolean", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ +static const Tcl_ObjType oldBooleanType = { + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; -Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ +const Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; -Tcl_ObjType tclDoubleType = { - "double", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ +const Tcl_ObjType tclDoubleType = { + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ }; -Tcl_ObjType tclIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ +const Tcl_ObjType tclIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; -#ifndef NO_WIDE_TYPE -Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - NULL /* setFromAnyProc */ +#ifndef TCL_WIDE_INT_IS_LONG +const Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ }; #endif -Tcl_ObjType tclBignumType = { - "bignum", /* name */ - FreeBignum, /* freeIntRepProc */ - DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ +const Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ -Tcl_HashKeyType tclObjHashKeyType = { - TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ - HashObjKey, /* hashKeyProc */ - CompareObjKeys, /* compareKeysProc */ - AllocObjEntry, /* allocEntryProc */ - FreeObjEntry /* freeEntryProc */ +const Tcl_HashKeyType tclObjHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + TclHashObjKey, /* hashKeyProc */ + TclCompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + TclFreeObjEntry /* freeEntryProc */ }; /* @@ -278,14 +314,22 @@ Tcl_HashKeyType tclObjHashKeyType = { * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions * use the second internal pointer field of the twoPtrValue field for their * own purposes. + * + * TRICKY POINT! Some extensions update this structure! (Notably, these + * include TclBlend and TCom). This is highly ill-advised on their part, but + * does allow them to delete a command when references to it are gone, which + * is fragile but useful given their somewhat-OO style. Because of this, this + * structure MUST NOT be const so that the C compiler puts the data in + * writable memory. [Bug 2558422] + * TODO: Provide a better API for those extensions so that they can coexist... */ -static Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ +Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; /* @@ -299,7 +343,8 @@ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains - * the referenced command). */ + * the referenced command). NULL if the name + * is fully qualified.*/ long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing @@ -358,13 +403,15 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclNsNameType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -372,6 +419,7 @@ TclInitObjSubsystem(void) tclObjsFreed = 0; { int i; + for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } @@ -383,6 +431,49 @@ TclInitObjSubsystem(void) /* *---------------------------------------------------------------------- * + * TclFinalizeThreadObjects -- + * + * This function is called by Tcl_FinalizeThread to clean up thread + * specific Tcl_Obj information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadObjects(void) +{ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + + if (tablePtr != NULL) { + for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree(objData); + } + } + + Tcl_DeleteHashTable(tablePtr); + ckfree(tablePtr); + tsdPtr->objThreadMap = NULL; + } +#endif +} + +/* + *---------------------------------------------------------------------- + * * TclFinalizeObjects -- * * This function is called by Tcl_Finalize to clean up all registered @@ -418,6 +509,310 @@ TclFinalizeObjects(void) } /* + *---------------------------------------------------------------------- + * + * TclGetContLineTable -- + * + * This procedure is a helper which returns the thread-specific + * hash-table used to track continuation line information associated with + * Tcl_Obj*, and the objThreadMap, etc. + * + * Results: + * A reference to the thread-data. + * + * Side effects: + * May allocate memory for the thread-data. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static ThreadSpecificData * +TclGetContLineTable(void) +{ + /* + * Initialize the hashtable tracking invisible continuation lines. For + * the release we use a thread exit handler to ensure that this is done + * before TSD blocks are made invalid. The TclFinalizeObjects() which + * would be the natural place for this is invoked afterwards, meaning that + * we try to operate on a data structure already gone. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!tsdPtr->lineCLPtr) { + tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); + Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); + } + return tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnter -- + * + * This procedure is a helper which saves the continuation line + * information associated with a Tcl_Obj*. + * + * Results: + * A reference to the newly created continuation line location table. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc * +TclContinuationsEnter( + Tcl_Obj *objPtr, + int num, + int *loc) +{ + int newEntry; + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); + ContLineLoc *clLocPtr = 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); + + return clLocPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnterDerived -- + * + * This procedure is a helper which computes the continuation line + * information associated with a Tcl_Obj* cut from the middle of a + * script. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +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 + * our script is the sole argument to an 'eval' command, for example, the + * scriptCLLocPtr we are using was generated by a previous call to TST, + * and while the words we have here may contain continuation lines they + * are invisible already, and the inner call to TST had no bs+nl sequences + * to trigger its code. + * + * Luckily for us, the table we have to create here for the current word + * has to be a slice of the table currently in use, with the locations + * suitably modified to be relative to the start of the word instead of + * relative to the script. + * + * That is what we are doing now. Determine the slice we need, and if not + * empty, wrap it into a new table, and save the result into our + * thread-global hashtable, as usual. + */ + + /* + * First compute the range of the word within the script. (Is there a + * better way which doesn't shimmer?) + */ + + Tcl_GetStringFromObj(objPtr, &length); + end = start + length; /* First char after the word */ + + /* + * Then compute the table slice covering the range of the word. + */ + + while (*wordCLLast >= 0 && *wordCLLast < end) { + wordCLLast++; + } + + /* + * 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); + + /* + * Re-base the locations. + */ + + for (i=0 ; i<num ; i++) { + clLocPtr->loc[i] -= start; + + /* + * Continuation lines coming before the string and affecting us + * should not happen, due to the proper maintenance of clNext + * during compilation. + */ + + if (clLocPtr->loc[i] < 0) { + Tcl_Panic("Derived ICL data for object using offsets from before the script"); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclContinuationsCopy( + Tcl_Obj *objPtr, + Tcl_Obj *originObjPtr) +{ + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); + + if (hPtr) { + ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); + + TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsGet -- + * + * This procedure is a helper which retrieves the continuation line + * 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. + * + * Side effects: + * None. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc * +TclContinuationsGet( + Tcl_Obj *objPtr) +{ + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + + if (!hPtr) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclThreadFinalizeContLines -- + * + * This procedure is a helper which releases all continuation line + * information currently known. It is run as a thread exit handler. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +TclThreadFinalizeContLines( + ClientData clientData) +{ + /* + * Release the hashtable tracking invisible continuation lines. + */ + + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); + tsdPtr->lineCLPtr = NULL; +} + +/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -438,14 +833,15 @@ TclFinalizeObjects(void) void Tcl_RegisterObjType( - Tcl_ObjType *typePtr) /* Information about object type; storage must + const Tcl_ObjType *typePtr) /* Information about object type; storage must * be statically allocated (must live * forever). */ { - int new; + int isNew; + Tcl_MutexLock(&tableMutex); Tcl_SetHashValue( - Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr); + Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr); Tcl_MutexUnlock(&tableMutex); } @@ -482,14 +878,13 @@ Tcl_AppendAllObjTypes( { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int objc; - Tcl_Obj **objv; + int numElems; /* * Get the test for a valid list out of the way first. */ - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { return TCL_ERROR; } @@ -525,17 +920,17 @@ Tcl_AppendAllObjTypes( *---------------------------------------------------------------------- */ -Tcl_ObjType * +const Tcl_ObjType * Tcl_GetObjType( - CONST char *typeName) /* Name of Tcl object type to look up. */ + const char *typeName) /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; - Tcl_ObjType *typePtr = NULL; + const Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + typePtr = Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -565,7 +960,7 @@ int Tcl_ConvertToType( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object to convert. */ - Tcl_ObjType *typePtr) /* The target type. */ + const Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; @@ -578,13 +973,67 @@ 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); } /* + *-------------------------------------------------------------- + * + * TclDbDumpActiveObjects -- + * + * This function is called to dump all of the active Tcl_Obj structs this + * allocator knows about. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclDbDumpActiveObjects( + FILE *outFile) +{ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + + if (tablePtr != NULL) { + fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); + for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + fprintf(outFile, + "key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n", + Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr, + objData->file, objData->line); + } else { + fprintf(outFile, "key = 0x%p\n", + Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } +#endif +} + +/* *---------------------------------------------------------------------- * * TclDbInitNewObj -- @@ -605,7 +1054,11 @@ Tcl_ConvertToType( #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - register Tcl_Obj *objPtr) + register Tcl_Obj *objPtr, + register const char *file, /* The name of the source file calling this + * function; used for debugging. */ + register int line) /* Line number in the source file; used for + * debugging. */ { objPtr->refCount = 0; objPtr->bytes = tclEmptyStringRep; @@ -621,20 +1074,29 @@ TclDbInitNewObj( if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; - int new; + int isNew; + ObjData *objData; 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, &new); - if (!new) { + hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); + if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } - Tcl_SetHashValue(hPtr, NULL); + + /* + * Record the debugging information. + */ + + objData = ckalloc(sizeof(ObjData)); + objData->objPtr = objPtr; + objData->file = file; + objData->line = line; + Tcl_SetHashValue(hPtr, objData); } #endif /* TCL_THREADS */ } @@ -722,7 +1184,7 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_DbNewObj( - register CONST char *file, /* The name of the source file calling this + register const char *file, /* The name of the source file calling this * function; used for debugging. */ register int line) /* Line number in the source file; used for * debugging. */ @@ -740,7 +1202,7 @@ Tcl_DbNewObj( Tcl_Obj * Tcl_DbNewObj( - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -765,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. * *---------------------------------------------------------------------- */ @@ -789,13 +1251,12 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *) ckalloc(bytesToAlloc); - memset(basePtr, 0, bytesToAlloc); + basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = (void *) prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } @@ -832,7 +1293,7 @@ void TclFreeObj( register Tcl_Obj *objPtr) /* The object to be freed. */ { - register Tcl_ObjType *typePtr = objPtr->typePtr; + register const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -840,20 +1301,35 @@ 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; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { + TCL_DTRACE_OBJ_FREE(objPtr); if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); @@ -861,27 +1337,47 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + 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); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); } ObjDeletionUnlock(context); } + + /* + * 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). + */ + + { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + + if (tsdPtr->lineCLPtr) { + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + if (hPtr) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + } + } } #else /* TCL_MEM_DEBUG */ @@ -889,19 +1385,22 @@ 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; - + if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* * objPtr can be freed safely, as it will not attempt to free any * other objects: it will not cause recursive calls to this function. */ + TCL_DTRACE_OBJ_FREE(objPtr); TclFreeObjStorage(objPtr); TclIncrObjsFreed(); } else { @@ -924,6 +1423,7 @@ TclFreeObj( * satisfy this. */ + TCL_DTRACE_OBJ_FREE(objPtr); ObjDeletionLock(context); objPtr->typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); @@ -933,7 +1433,9 @@ 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)) { objToFree->typePtr->freeIntRepProc(objToFree); @@ -944,8 +1446,31 @@ TclFreeObj( ObjDeletionUnlock(context); } } + + /* + * 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). + */ + + { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + + if (tsdPtr->lineCLPtr) { + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + if (hPtr) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + } + } } -#endif +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -954,7 +1479,7 @@ TclFreeObj( * * This function returns 1 when the Tcl_Obj is being deleted. It is * provided for the rare cases where the reason for the loss of an - * internal rep might be relevant [FR 1512138] + * internal rep might be relevant. [FR 1512138] * * Results: * 1 if being deleted, 0 otherwise. @@ -966,11 +1491,11 @@ TclFreeObj( */ int -TclObjBeingDeleted(Tcl_Obj *objPtr) +TclObjBeingDeleted( + Tcl_Obj *objPtr) { return (objPtr->length == -1); } - /* *---------------------------------------------------------------------- @@ -1001,30 +1526,47 @@ TclObjBeingDeleted(Tcl_Obj *objPtr) *---------------------------------------------------------------------- */ +#define SetDuplicateObj(dupPtr, objPtr) \ + { \ + const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ + const char *bytes = (objPtr)->bytes; \ + if (bytes) { \ + TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ + } else { \ + (dupPtr)->bytes = NULL; \ + } \ + if (typePtr) { \ + if (typePtr->dupIntRepProc) { \ + typePtr->dupIntRepProc((objPtr), (dupPtr)); \ + } else { \ + (dupPtr)->internalRep = (objPtr)->internalRep; \ + (dupPtr)->typePtr = typePtr; \ + } \ + } \ + } + Tcl_Obj * Tcl_DuplicateObj( - register Tcl_Obj *objPtr) /* The object to duplicate. */ + Tcl_Obj *objPtr) /* The object to duplicate. */ { - register Tcl_ObjType *typePtr = objPtr->typePtr; - register Tcl_Obj *dupPtr; + Tcl_Obj *dupPtr; TclNewObj(dupPtr); + SetDuplicateObj(dupPtr, objPtr); + return dupPtr; +} - if (objPtr->bytes == NULL) { - dupPtr->bytes = NULL; - } else if (objPtr->bytes != tclEmptyStringRep) { - TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); - } - - if (typePtr != NULL) { - if (typePtr->dupIntRepProc == NULL) { - dupPtr->internalRep = objPtr->internalRep; - dupPtr->typePtr = typePtr; - } else { - (*typePtr->dupIntRepProc)(objPtr, dupPtr); - } +void +TclSetDuplicateObj( + Tcl_Obj *dupPtr, + Tcl_Obj *objPtr) +{ + if (Tcl_IsShared(dupPtr)) { + Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); } - return dupPtr; + TclInvalidateStringRep(dupPtr); + TclFreeIntRep(dupPtr); + SetDuplicateObj(dupPtr, objPtr); } /* @@ -1057,11 +1599,29 @@ Tcl_GetString( return objPtr->bytes; } + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant of + * a properly maintained Tcl_Obj is that at least one of objPtr->bytes + * and objPtr->typePtr must not be NULL. If broken extensions fail to + * maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an updateStringProc + * 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); } - (*objPtr->typePtr->updateStringProc)(objPtr); + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", objPtr->typePtr->name); + } return objPtr->bytes; } @@ -1096,13 +1656,7 @@ Tcl_GetStringFromObj( * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - if (objPtr->bytes == NULL) { - if (objPtr->typePtr->updateStringProc == NULL) { - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); - } + (void) TclGetString(objPtr); if (lengthPtr != NULL) { *lengthPtr = objPtr->length; @@ -1135,7 +1689,6 @@ Tcl_InvalidateStringRep( { TclInvalidateStringRep(objPtr); } - /* *---------------------------------------------------------------------- @@ -1160,8 +1713,8 @@ Tcl_InvalidateStringRep( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewBooleanObj( @@ -1209,12 +1762,13 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBooleanObj( register int boolValue, /* Boolean used to initialize new object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -1234,7 +1788,7 @@ Tcl_DbNewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( register int boolValue, /* Boolean used to initialize new object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -1261,6 +1815,7 @@ Tcl_DbNewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -1294,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. */ { @@ -1316,7 +1871,7 @@ Tcl_GetBooleanFromObj( * sets the proper error message for us. */ - double d; + double d; if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; @@ -1328,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; @@ -1342,7 +1897,7 @@ Tcl_GetBooleanFromObj( /* *---------------------------------------------------------------------- * - * SetBooleanFromAny -- + * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -1359,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. */ { @@ -1383,7 +1938,7 @@ SetBooleanFromAny( goto badBoolean; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { goto badBoolean; } @@ -1401,12 +1956,14 @@ SetBooleanFromAny( badBoolean: if (interp != NULL) { int length; - char *str = Tcl_GetStringFromObj(objPtr, &length); - Tcl_Obj *msg = - Tcl_NewStringObj("expected boolean value but got \"", -1); - TclAppendLimitedToObj(msg, str, length, 50, ""); + const char *str = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected boolean value but got \""); + Tcl_AppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); } return TCL_ERROR; } @@ -1416,10 +1973,14 @@ ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { int i, length, newBool; - char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length); + char lowerCase[6]; + 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; } @@ -1445,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': @@ -1598,7 +2160,7 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( register double dblValue, /* Double used to initialize the object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -1618,7 +2180,7 @@ Tcl_DbNewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( register double dblValue, /* Double used to initialize the object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -1679,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. */ { @@ -1689,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; } @@ -1701,11 +2265,12 @@ Tcl_GetDoubleFromObj( } if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM( objPtr, big ); - *dblPtr = TclBignumToDouble( &big ); + + UNPACK_BIGNUM(objPtr, big); + *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; @@ -1775,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; } @@ -1810,8 +2375,8 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewIntObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewIntObj( @@ -1851,6 +2416,7 @@ Tcl_NewIntObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetIntObj void Tcl_SetIntObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -1891,18 +2457,21 @@ 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. */ { +#if (LONG_MAX == INT_MAX) + return TclGetLongFromObj(interp, objPtr, (long *) intPtr); +#else long l; - if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) { + if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - CONST char *s = + const char *s = "integer value too large to represent as non-long integer"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); @@ -1911,6 +2480,7 @@ Tcl_GetIntFromObj( } *intPtr = (int) l; return TCL_OK; +#endif } /* @@ -1935,7 +2505,8 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { long l; - return Tcl_GetLongFromObj(interp, objPtr, &l); + + return TclGetLongFromObj(interp, objPtr, &l); } /* @@ -1966,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; } @@ -2064,7 +2635,7 @@ Tcl_Obj * Tcl_DbNewLongObj( register long longValue, /* Long integer used to initialize the new * object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -2085,7 +2656,7 @@ Tcl_Obj * Tcl_DbNewLongObj( register long longValue, /* Long integer used to initialize the new * object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -2148,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. */ { @@ -2157,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 @@ -2168,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); @@ -2176,18 +2748,16 @@ Tcl_GetLongFromObj( goto tooLarge; } #endif - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed @@ -2198,11 +2768,12 @@ Tcl_GetLongFromObj( mp_int big; UNPACK_BIGNUM(objPtr, big); - if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) + if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / 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++; @@ -2215,11 +2786,11 @@ Tcl_GetLongFromObj( return TCL_OK; } } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif if (interp != NULL) { - char *s = "integer value too large to represent"; + const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); @@ -2231,7 +2802,7 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -2269,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 */ /* *---------------------------------------------------------------------- @@ -2367,7 +2938,7 @@ Tcl_DbNewWideIntObj( register Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -2386,7 +2957,7 @@ Tcl_DbNewWideIntObj( register Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -2428,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; @@ -2462,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; @@ -2478,17 +3049,16 @@ Tcl_GetWideIntFromObj( *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. @@ -2497,7 +3067,7 @@ Tcl_GetWideIntFromObj( mp_int big; UNPACK_BIGNUM(objPtr, big); - if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt) + if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; unsigned long numBytes = sizeof(Tcl_WideInt); @@ -2517,8 +3087,8 @@ Tcl_GetWideIntFromObj( } } if (interp != NULL) { - char *s = "integer value too large to represent"; - Tcl_Obj* msg = Tcl_NewStringObj(s, -1); + const char *s = "integer value too large to represent"; + Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); @@ -2529,6 +3099,33 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG + +/* + *---------------------------------------------------------------------- + * + * SetWideIntFromAny -- + * + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + *---------------------------------------------------------------------- + */ + +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ +{ + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); +} +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2551,9 +3148,10 @@ FreeBignum( UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); - if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { - ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); + if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { + ckfree(objPtr->internalRep.ptrAndLongRep.ptr); } + objPtr->typePtr = NULL; } /* @@ -2604,6 +3202,8 @@ DupBignum( * * The object's existing string representation is NOT freed; memory will leak * if the string rep is still valid at the time this function is called. + * + *---------------------------------------------------------------------- */ static void @@ -2613,7 +3213,7 @@ UpdateStringOfBignum( mp_int bignumVal; int size; int status; - char* stringVal; + char *stringVal; UNPACK_BIGNUM(objPtr, bignumVal); status = mp_radix_size(&bignumVal, 10, &size); @@ -2634,13 +3234,13 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = Tcl_Alloc((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. */ } /* @@ -2673,7 +3273,7 @@ Tcl_Obj * Tcl_NewBignumObj( mp_int *bignumValue) { - Tcl_Obj* objPtr; + Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetBignumObj(objPtr, bignumValue); @@ -2703,7 +3303,7 @@ Tcl_NewBignumObj( Tcl_Obj * Tcl_DbNewBignumObj( mp_int *bignumValue, - CONST char *file, + const char *file, int line) { Tcl_Obj *objPtr; @@ -2716,7 +3316,7 @@ Tcl_DbNewBignumObj( Tcl_Obj * Tcl_DbNewBignumObj( mp_int *bignumValue, - CONST char *file, + const char *file, int line) { return Tcl_NewBignumObj(bignumValue); @@ -2744,12 +3344,6 @@ Tcl_DbNewBignumObj( *---------------------------------------------------------------------- */ -/* - * TODO: Consider a smarter Tcl_GetBignumAndClearObj() that doesn't - * require caller to check for a shared Tcl_Obj, but falls back to - * Tcl_GetBignumFromObj() when sharing is an issue. - */ - static int GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ @@ -2759,14 +3353,12 @@ GetBignumFromObj( { do { if (objPtr->typePtr == &tclBignumType) { - if (copy) { + if (copy || Tcl_IsShared(objPtr)) { mp_int temp; + UNPACK_BIGNUM(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj"); - } UNPACK_BIGNUM(objPtr, *bignumValue); objPtr->internalRep.ptrAndLongRep.ptr = NULL; objPtr->internalRep.ptrAndLongRep.value = 0; @@ -2781,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); @@ -2790,12 +3382,10 @@ GetBignumFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - - 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; } @@ -2841,7 +3431,7 @@ Tcl_GetBignumFromObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBignumAndClearObj -- + * Tcl_TakeBignumFromObj -- * * This function retrieves a 'bignum' value from a Tcl object, converting * the object if necessary. @@ -2865,7 +3455,7 @@ Tcl_GetBignumFromObj( */ int -Tcl_GetBignumAndClearObj( +Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ mp_int *bignumValue) /* Returned bignum value. */ @@ -2898,11 +3488,12 @@ Tcl_SetBignumObj( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if ((size_t)(bignumValue->used) + if ((size_t) bignumValue->used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / 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(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForLong; } @@ -2921,13 +3512,14 @@ Tcl_SetBignumObj( return; } tooLargeForLong: -#ifndef NO_WIDE_TYPE - if ((size_t)(bignumValue->used) +#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; unsigned long numBytes = sizeof(Tcl_WideInt); Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; } @@ -2952,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, @@ -2962,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; @@ -2976,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, @@ -2996,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 @@ -3015,7 +3635,8 @@ int TclGetNumberFromObj( static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); - UNPACK_BIGNUM( objPtr, *bigPtr ); + + UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; @@ -3050,7 +3671,7 @@ void Tcl_DbIncrRefCount( register Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -3070,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; } @@ -3115,7 +3734,7 @@ void Tcl_DbDecrRefCount( register Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -3135,28 +3754,36 @@ 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"); } - /* If the Tcl_Obj is going to be deleted, remove the entry */ - if ((((objPtr)->refCount) - 1) <= 0) { + /* + * If the Tcl_Obj is going to be deleted, remove the entry. + */ + + if ((objPtr->refCount - 1) <= 0) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree(objData); + } + Tcl_DeleteHashEntry(hPtr); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3186,7 +3813,7 @@ Tcl_DbDecrRefCount( int Tcl_DbIsShared( register Tcl_Obj *objPtr, /* The object to test for being shared. */ - CONST char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ @@ -3206,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); @@ -3233,7 +3859,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif +#endif /* TCL_COMPILE_STATS */ return ((objPtr)->refCount > 1); } @@ -3287,12 +3913,12 @@ 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; return hPtr; } @@ -3300,7 +3926,7 @@ AllocObjEntry( /* *---------------------------------------------------------------------- * - * CompareObjKeys -- + * TclCompareObjKeys -- * * Compares two Tcl_Obj * keys. * @@ -3314,14 +3940,14 @@ AllocObjEntry( *---------------------------------------------------------------------- */ -static int -CompareObjKeys( +int +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 const char *p1, *p2; register int l1, l2; /* @@ -3363,7 +3989,7 @@ CompareObjKeys( /* *---------------------------------------------------------------------- * - * FreeObjEntry -- + * TclFreeObjEntry -- * * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. * @@ -3376,20 +4002,20 @@ CompareObjKeys( *---------------------------------------------------------------------- */ -static void -FreeObjEntry( +void +TclFreeObjEntry( Tcl_HashEntry *hPtr) /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree((char *) hPtr); + ckfree(hPtr); } /* *---------------------------------------------------------------------- * - * HashObjKey -- + * TclHashObjKey -- * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. @@ -3404,16 +4030,15 @@ FreeObjEntry( *---------------------------------------------------------------------- */ -static unsigned int -HashObjKey( +unsigned int +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 @@ -3423,16 +4048,37 @@ HashObjKey( * 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; } @@ -3466,87 +4112,57 @@ Tcl_GetCommandFromObj( * up first in the current namespace, then in * global namespace. */ { - Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; - register Command *cmdPtr; - Namespace *currNsPtr; - int result; - CallFrame *savedFramePtr; - char *name; - - /* - * If the variable name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. It costs close to nothing, and may be very helpful for - * OO applications which pass along a command name ("this"), [Patch - * 456668] - */ - - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; - } /* * Get the internal representation, converting to a command type if * needed. The internal representation is a ResolvedCmdName that points to * the actual command. + * + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. Note that we verify that the + * namespace id of the context namespace is the same as the one we cached; + * this insures that the namespace wasn't deleted and a new one created at + * the same address with the same command epoch. Note that fully qualified + * names have a NULL refNsPtr, these checks needn't be made. + * + * Check also that the command's epoch is up to date, and that the command + * is not deleted. + * + * If any check fails, then force another conversion to the command type, + * to discard the old rep and create a new one. */ - if (objPtr->typePtr != &tclCmdNameType) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + 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; + } + } } /* - * Check the context namespace and the namespace epoch of the resolved - * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a new - * one. Note that we verify that the namespace id of the context namespace - * is the same as the one we cached; this insures that the namespace - * wasn't deleted and a new one created at the same address with the same - * command epoch. + * OK, must create a new internal representation (or fail) as any cache we + * had is invalid one way or another. */ - cmdPtr = NULL; - if ((resPtr != NULL) - && (resPtr->refNsPtr == currNsPtr) - && (resPtr->refNsId == currNsPtr->nsId) - && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { - cmdPtr = resPtr->cmdPtr; - if ((cmdPtr->cmdEpoch != resPtr->cmdEpoch) || (cmdPtr->flags & CMD_IS_DELETED)) { - cmdPtr = NULL; - } - } - - if (cmdPtr == NULL) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { - cmdPtr = resPtr->cmdPtr; - } + if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { + return NULL; } - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) cmdPtr; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } /* @@ -3564,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. * *---------------------------------------------------------------------- */ @@ -3581,52 +4197,42 @@ TclSetCmdNameObj( Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; - CallFrame *savedFramePtr; - char *name; + const char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } - /* - * If the variable name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. It costs close to nothing, and may be very helpful for - * OO applications which pass along a command name ("this"), [Patch - * 456668] (Copied over from Tcl_GetCommandFromObj) - */ + cmdPtr->refCount++; + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); + name = TclGetString(objPtr); if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; - } + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - /* - * Get the current namespace. - */ + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ - if (iPtr->varFramePtr != NULL) { currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; - - iPtr->varFramePtr = savedFramePtr; } /* @@ -3655,8 +4261,7 @@ FreeCmdNameInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* @@ -3673,10 +4278,12 @@ FreeCmdNameInternalRep( */ Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommand(cmdPtr); - ckfree((char *) resPtr); + + TclCleanupCommandMacro(cmdPtr); + ckfree(resPtr); } } + objPtr->typePtr = NULL; } /* @@ -3704,10 +4311,9 @@ DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = (ResolvedCmdName *) - srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; @@ -3742,19 +4348,13 @@ SetCmdNameFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; - char *name; - Tcl_Command cmd; + const char *name; register Command *cmdPtr; Namespace *currNsPtr; register ResolvedCmdName *resPtr; - /* - * Get "objPtr"s string representation. Make it up-to-date if necessary. - */ - - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); + if (interp == NULL) { + return TCL_ERROR; } /* @@ -3765,42 +4365,128 @@ SetCmdNameFromAny( * referenced from a CmdName object. */ - cmd = Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); - cmdPtr = (Command *) cmd; - if (cmdPtr != NULL) { - /* - * Get the current namespace. - */ + name = TclGetString(objPtr); + cmdPtr = (Command *) + Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; + /* + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. + */ + + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ + + Command *oldCmdPtr = resPtr->cmdPtr; + + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } } else { - currNsPtr = iPtr->globalNsPtr; + TclFreeIntRep(objPtr); + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } } else { - resPtr = NULL; /* no command named "name" was found */ + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RepresentationCmd -- + * + * Implementation of the "tcl::unsupported::representation" command. + * + * Results: + * Reports the current representation (Tcl_Obj type) of its argument. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RepresentationCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; } /* - * Free the old internalRep before setting the new one. We do this as late - * as possible to allow the conversion code, in particular - * GetStringFromObj, to use that old internalRep. If no Command structure - * was found, leave NULL as the cached value. + * Value is a bignum with a refcount of 14, object pointer at 0x12345678, + * internal representation 0x45671234:0x98765432, string representation + * "1872361827361287" */ - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + 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(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) { + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); + } else { + Tcl_AppendToObj(descObj, ", no string representation", -1); + } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } @@ -3809,5 +4495,7 @@ SetCmdNameFromAny( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |