diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 1091 |
1 files changed, 476 insertions, 615 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index c6ebf50..230842a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -16,6 +16,7 @@ #include "tclInt.h" #include "tommath.h" +#include <float.h> #include <math.h> /* @@ -50,17 +51,17 @@ Tcl_Mutex tclObjMutex; char tclEmptyString = '\0'; 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 { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ - 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. */ @@ -77,29 +78,33 @@ typedef struct ObjData { */ typedef struct ThreadSpecificData { - 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. */ + 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/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. */ + /* + * Thread local table that is used to check that a Tcl_Obj was not + * allocated by some other thread. + */ + + Tcl_HashTable *objThreadMap; #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 ContLineLocFree (char* clientData); +static void TclThreadFinalizeContLines (ClientData clientData); +static ThreadSpecificData* TclGetContLineTable (void); /* * Nested Tcl_Obj deletion management support @@ -147,18 +152,13 @@ typedef struct PendingObjData { #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ - do { \ - /* 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); \ - (contextPtr)->deletionStack = (objPtr); \ - } while (0) + /* 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); \ + (contextPtr)->deletionStack = (objPtr) #define PopObjToDelete(contextPtr,objPtrVar) \ - do { \ - (objPtrVar) = (contextPtr)->deletionStack; \ - (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes; \ - } while (0) + (objPtrVar) = (contextPtr)->deletionStack; \ + (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. @@ -166,15 +166,11 @@ typedef struct PendingObjData { #ifndef TCL_THREADS 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 + PendingObjData *CONST contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ + PendingObjData *CONST contextPtr = (PendingObjData *) \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif @@ -183,27 +179,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 = (void*) 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 = (objPtr)->internalRep.ptrAndLongRep.ptr; \ + } else { \ + (bignum).dp = (mp_digit*) (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; \ } @@ -250,56 +246,56 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -static const Tcl_ObjType oldBooleanType = { - "boolean", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ +static Tcl_ObjType oldBooleanType = { + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ +Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclDoubleType = { - "double", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ +Tcl_ObjType tclDoubleType = { + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ +Tcl_ObjType tclIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #ifndef NO_WIDE_TYPE -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ +Tcl_ObjType tclWideIntType = { + "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 */ +Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ -const Tcl_HashKeyType tclObjHashKeyType = { +Tcl_HashKeyType tclObjHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ TclHashObjKey, /* hashKeyProc */ @@ -321,22 +317,14 @@ const 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... */ -Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ +static Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; /* @@ -426,7 +414,6 @@ TclInitObjSubsystem(void) tclObjsFreed = 0; { int i; - for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } @@ -467,12 +454,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + ckfree((char *) objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + ckfree((char *) tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -534,8 +521,8 @@ TclFinalizeObjects(void) *---------------------------------------------------------------------- */ -static ThreadSpecificData * -TclGetContLineTable(void) +static ThreadSpecificData* +TclGetContLineTable() { /* * Initialize the hashtable tracking invisible continuation lines. For @@ -546,11 +533,10 @@ TclGetContLineTable(void) */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); - Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); + Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); } return tsdPtr; } @@ -573,17 +559,18 @@ TclGetContLineTable(void) *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsEnter( - Tcl_Obj *objPtr, - int num, - ssize_t *loc) +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(size_t)); + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); + + ContLineLoc* clLocPtr = + (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); if (!newEntry) { /* @@ -602,18 +589,18 @@ TclContinuationsEnter( * 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. + * returning the stored entry and data 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)); + ckfree((char *) Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; - memcpy(&clLocPtr->loc, loc, num*sizeof(size_t)); - 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; } @@ -638,14 +625,8 @@ TclContinuationsEnter( */ void -TclContinuationsEnterDerived( - Tcl_Obj *objPtr, - size_t start, - ssize_t *clNext) +TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) { - size_t length, end, num; - ssize_t *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 @@ -666,15 +647,20 @@ TclContinuationsEnterDerived( */ /* - * First compute the range of the word within the script. (Is there a - * better way which doesn't shimmer?) + * First compute the range of the word within the script. */ + int length, end, num; + int* wordCLLast = clNext; + Tcl_GetStringFromObj(objPtr, &length); - end = start + length; /* First char after the word */ + /* Is there a better way which doesn't shimmer ? */ + + 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) { @@ -682,19 +668,21 @@ TclContinuationsEnterDerived( } /* - * 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) { - size_t i; - ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); + int i; + 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; /* @@ -716,9 +704,9 @@ TclContinuationsEnterDerived( * 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. @@ -731,16 +719,13 @@ TclContinuationsEnterDerived( */ 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, originObjPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); if (hPtr) { - ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); + ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } @@ -755,8 +740,8 @@ TclContinuationsCopy( * 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. @@ -765,18 +750,17 @@ TclContinuationsCopy( *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsGet( - Tcl_Obj *objPtr) +ContLineLoc* +TclContinuationsGet(Tcl_Obj* objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); - if (!hPtr) { - return NULL; + if (hPtr) { + return (ContLineLoc*) Tcl_GetHashValue (hPtr); + } else { + return NULL; } - return Tcl_GetHashValue(hPtr); } /* @@ -798,8 +782,7 @@ TclContinuationsGet( */ static void -TclThreadFinalizeContLines( - ClientData clientData) +TclThreadFinalizeContLines (ClientData clientData) { /* * Release the hashtable tracking invisible continuation lines. @@ -810,19 +793,19 @@ TclThreadFinalizeContLines( Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&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); + ContLineLocFree (Tcl_GetHashValue (hPtr)); + Tcl_DeleteHashEntry (hPtr); } - Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - ckfree(tsdPtr->lineCLPtr); + Tcl_DeleteHashTable (tsdPtr->lineCLPtr); + ckfree((char *) tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -844,10 +827,9 @@ TclThreadFinalizeContLines( */ static void -ContLineLocFree( - char *clientData) +ContLineLocFree (char* clientData) { - ckfree(clientData); + ckfree (clientData); } /* @@ -871,7 +853,7 @@ ContLineLocFree( void Tcl_RegisterObjType( - const Tcl_ObjType *typePtr) /* Information about object type; storage must + Tcl_ObjType *typePtr) /* Information about object type; storage must * be statically allocated (must live * forever). */ { @@ -916,7 +898,7 @@ Tcl_AppendAllObjTypes( { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - size_t numElems; + int numElems; /* * Get the test for a valid list out of the way first. @@ -934,8 +916,8 @@ Tcl_AppendAllObjTypes( Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj( - Tcl_GetHashKey(&typeTable, hPtr), TCL_STRLEN)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; @@ -958,17 +940,17 @@ Tcl_AppendAllObjTypes( *---------------------------------------------------------------------- */ -const Tcl_ObjType * +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; - const Tcl_ObjType *typePtr = NULL; + Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = Tcl_GetHashValue(hPtr); + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -998,7 +980,7 @@ int Tcl_ConvertToType( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object to convert. */ - const Tcl_ObjType *typePtr) /* The target type. */ + Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; @@ -1011,7 +993,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); @@ -1047,7 +1034,7 @@ TclDbDumpActiveObjects( tablePtr = tsdPtr->objThreadMap; if (tablePtr != NULL) { - fprintf(outFile, "total objects: %lu\n", tablePtr->numEntries); + 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); @@ -1088,7 +1075,7 @@ TclDbDumpActiveObjects( void TclDbInitNewObj( register Tcl_Obj *objPtr, - 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. */ @@ -1112,11 +1099,12 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; - hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } @@ -1125,7 +1113,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = ckalloc(sizeof(ObjData)); + objData = (ObjData *) ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1217,7 +1205,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. */ @@ -1235,7 +1223,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. */ @@ -1260,7 +1248,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. * *---------------------------------------------------------------------- */ @@ -1284,12 +1272,12 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = ckalloc(bytesToAlloc); + basePtr = (char *) 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 = (void *) prevPtr; prevPtr = objPtr; objPtr++; } @@ -1326,7 +1314,7 @@ void TclFreeObj( register Tcl_Obj *objPtr) /* The object to be freed. */ { - register const Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -1334,18 +1322,61 @@ TclFreeObj( ObjInitDeletionContext(context); - if (objPtr->refCount < -1) { - Tcl_Panic("Reference count for %p was negative", objPtr); +# ifdef TCL_THREADS + /* + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. + */ + + if (!TclInExit()) { + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("TclFreeObj: object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (hPtr) { + /* + * As the Tcl_Obj is going to be deleted we remove the entry. + */ + + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree((char *) objData); + } + + Tcl_DeleteHashEntry(hPtr); + } } +# endif /* - * 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 == TCL_STRLEN'. + * 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); + } + /* + * 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' */ TclInvalidateStringRep(objPtr); - objPtr->length = TCL_STRLEN; + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); @@ -1358,19 +1389,19 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree(objPtr); + ckfree((char *) 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(objToFree); + ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1379,23 +1410,22 @@ 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); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } @@ -1406,14 +1436,12 @@ 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 == TCL_STRLEN'. - */ + /* 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 = TCL_STRLEN; + objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* @@ -1454,8 +1482,7 @@ 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)) { @@ -1470,28 +1497,27 @@ 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); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } } -#endif /* TCL_MEM_DEBUG */ +#endif /* *---------------------------------------------------------------------- @@ -1515,8 +1541,9 @@ int TclObjBeingDeleted( Tcl_Obj *objPtr) { - return (objPtr->length == TCL_STRLEN); + return (objPtr->length == -1); } + /* *---------------------------------------------------------------------- @@ -1547,47 +1574,30 @@ TclObjBeingDeleted( *---------------------------------------------------------------------- */ -#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( - Tcl_Obj *objPtr) /* The object to duplicate. */ + register Tcl_Obj *objPtr) /* The object to duplicate. */ { - Tcl_Obj *dupPtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_Obj *dupPtr; TclNewObj(dupPtr); - SetDuplicateObj(dupPtr, objPtr); - return dupPtr; -} -void -TclSetDuplicateObj( - Tcl_Obj *dupPtr, - Tcl_Obj *objPtr) -{ - if (Tcl_IsShared(dupPtr)) { - Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); + if (objPtr->bytes == NULL) { + dupPtr->bytes = NULL; + } else if (objPtr->bytes != tclEmptyStringRep) { + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); } - TclInvalidateStringRep(dupPtr); - TclFreeIntRep(dupPtr); - SetDuplicateObj(dupPtr, objPtr); + + if (typePtr != NULL) { + if (typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(objPtr, dupPtr); + } + } + return dupPtr; } /* @@ -1620,29 +1630,11 @@ 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); - if (objPtr->bytes == NULL || objPtr->length == TCL_STRLEN - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); - } + (*objPtr->typePtr->updateStringProc)(objPtr); return objPtr->bytes; } @@ -1673,11 +1665,17 @@ char * Tcl_GetStringFromObj( register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - register size_t *lengthPtr) /* If non-NULL, the location where the string + register int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - (void) TclGetString(objPtr); + 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); + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; @@ -1710,6 +1708,7 @@ Tcl_InvalidateStringRep( { TclInvalidateStringRep(objPtr); } + /* *---------------------------------------------------------------------- @@ -1734,14 +1733,14 @@ Tcl_InvalidateStringRep( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); + return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -1752,7 +1751,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewBooleanObj(objPtr, boolValue); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1783,12 +1782,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. */ @@ -1808,7 +1808,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. */ @@ -1835,6 +1835,7 @@ Tcl_DbNewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -1844,7 +1845,7 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetBooleanObj(objPtr, boolValue); + TclSetIntObj(objPtr, boolValue!=0); } /* @@ -1868,7 +1869,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. */ { @@ -1890,7 +1891,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; @@ -1909,8 +1910,7 @@ Tcl_GetBooleanFromObj( } #endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == - TclParseNumber(interp, objPtr, "boolean value", NULL, TCL_STRLEN, - NULL, 0))); + TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } @@ -1975,15 +1975,14 @@ SetBooleanFromAny( badBoolean: if (interp != NULL) { - size_t length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + int length; + 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, "\"", TCL_STRLEN); + Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); } return TCL_ERROR; } @@ -1992,16 +1991,11 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, newBool; - size_t length; - char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + int i, length, newBool; + char lowerCase[6], *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; } @@ -2027,7 +2021,6 @@ 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': @@ -2181,7 +2174,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. */ @@ -2201,7 +2194,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. */ @@ -2262,7 +2255,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. */ { @@ -2271,10 +2264,7 @@ Tcl_GetDoubleFromObj( if (TclIsNaN(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "floating point value is Not a Number", - TCL_STRLEN)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - NULL); + "floating point value is Not a Number", -1)); } return TCL_ERROR; } @@ -2287,9 +2277,8 @@ 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 @@ -2327,8 +2316,8 @@ SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - return TclParseNumber(interp, objPtr, "floating-point number", NULL, - TCL_STRLEN, NULL, 0); + return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, + NULL, 0); } /* @@ -2357,13 +2346,13 @@ UpdateStringOfDouble( register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { char buffer[TCL_DOUBLE_SPACE]; - register size_t len; + register int len; Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); objPtr->length = len; } @@ -2478,7 +2467,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. */ { @@ -2492,9 +2481,9 @@ Tcl_GetIntFromObj( } if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - static const char *s = + CONST char *s = "integer value too large to represent as non-long integer"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_STRLEN)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; @@ -2526,7 +2515,6 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { long l; - return TclGetLongFromObj(interp, objPtr, &l); } @@ -2554,12 +2542,12 @@ UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE]; - register size_t len; + register int len; len = TclFormatInt(buffer, objPtr->internalRep.longValue); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); objPtr->length = len; } @@ -2656,7 +2644,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. */ @@ -2677,7 +2665,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. */ @@ -2740,7 +2728,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. */ { @@ -2760,7 +2748,6 @@ Tcl_GetLongFromObj( */ Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { *longPtr = Tcl_WideAsLong(w); @@ -2769,16 +2756,18 @@ Tcl_GetLongFromObj( goto tooLarge; } #endif - 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); + 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); } 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 @@ -2789,12 +2778,11 @@ 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++; @@ -2811,15 +2799,15 @@ Tcl_GetLongFromObj( tooLarge: #endif if (interp != NULL) { - static const char *s = "integer value too large to represent"; - Tcl_Obj *msg = Tcl_NewStringObj(s, TCL_STRLEN); + 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); } return TCL_ERROR; } - } while (TclParseNumber(interp, objPtr, "integer", NULL, TCL_STRLEN, NULL, + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } @@ -2849,7 +2837,7 @@ UpdateStringOfWideInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE+2]; - register size_t len; + register unsigned len; register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* @@ -2861,7 +2849,7 @@ UpdateStringOfWideInt( sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); + objPtr->bytes = ckalloc((unsigned) len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } @@ -2959,7 +2947,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. */ @@ -2978,7 +2966,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. */ @@ -3054,7 +3042,7 @@ 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. */ @@ -3070,16 +3058,18 @@ Tcl_GetWideIntFromObj( *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; return TCL_OK; } - 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); + 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); } 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. @@ -3088,7 +3078,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); @@ -3108,15 +3098,15 @@ Tcl_GetWideIntFromObj( } } if (interp != NULL) { - static const char *s = "integer value too large to represent"; - Tcl_Obj *msg = Tcl_NewStringObj(s, TCL_STRLEN); + 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); } return TCL_ERROR; } - } while (TclParseNumber(interp, objPtr, "integer", NULL, TCL_STRLEN, NULL, + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } @@ -3169,10 +3159,9 @@ FreeBignum( UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); - if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { - ckfree(objPtr->internalRep.ptrAndLongRep.ptr); + if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); } - objPtr->typePtr = NULL; } /* @@ -3234,7 +3223,7 @@ UpdateStringOfBignum( mp_int bignumVal; int size; int status; - char *stringVal; + char* stringVal; UNPACK_BIGNUM(objPtr, bignumVal); status = mp_radix_size(&bignumVal, 10, &size); @@ -3255,13 +3244,13 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); + stringVal = ckalloc((size_t) 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 NUL byte. */ + objPtr->length = size - 1; /* size includes a trailing null byte */ } /* @@ -3294,7 +3283,7 @@ Tcl_Obj * Tcl_NewBignumObj( mp_int *bignumValue) { - Tcl_Obj *objPtr; + Tcl_Obj* objPtr; TclNewObj(objPtr); Tcl_SetBignumObj(objPtr, bignumValue); @@ -3324,7 +3313,7 @@ Tcl_NewBignumObj( Tcl_Obj * Tcl_DbNewBignumObj( mp_int *bignumValue, - const char *file, + CONST char *file, int line) { Tcl_Obj *objPtr; @@ -3337,7 +3326,7 @@ Tcl_DbNewBignumObj( Tcl_Obj * Tcl_DbNewBignumObj( mp_int *bignumValue, - const char *file, + CONST char *file, int line) { return Tcl_NewBignumObj(bignumValue); @@ -3376,7 +3365,6 @@ GetBignumFromObj( if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { @@ -3403,14 +3391,16 @@ GetBignumFromObj( #endif 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); + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } - } while (TclParseNumber(interp, objPtr, "integer", NULL, TCL_STRLEN, NULL, + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } @@ -3509,12 +3499,11 @@ 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; } @@ -3534,13 +3523,12 @@ Tcl_SetBignumObj( } tooLargeForLong: #ifndef NO_WIDE_TYPE - if ((size_t) bignumValue->used + 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; } @@ -3565,24 +3553,6 @@ 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, @@ -3593,9 +3563,8 @@ 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; @@ -3608,23 +3577,14 @@ 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, @@ -3637,18 +3597,18 @@ 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 if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; - *clientDataPtr = &objPtr->internalRep.wideValue; + *clientDataPtr = &(objPtr->internalRep.wideValue); return TCL_OK; } #endif @@ -3656,14 +3616,13 @@ 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; } - } while (TCL_OK == TclParseNumber(interp, objPtr, "number", NULL, - TCL_STRLEN, NULL, 0)); + } while (TCL_OK == + TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } @@ -3692,7 +3651,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. */ @@ -3712,21 +3671,23 @@ Tcl_DbIncrRefCount( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "incr ref count"); + Tcl_Panic("%s%s", + "Trying to incr ref count of " + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ +# endif +#endif ++(objPtr)->refCount; } @@ -3755,7 +3716,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. */ @@ -3775,36 +3736,23 @@ Tcl_DbDecrRefCount( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - 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) { - ObjData *objData = Tcl_GetHashValue(hPtr); - - if (objData != NULL) { - ckfree(objData); - } - - Tcl_DeleteHashEntry(hPtr); + Tcl_Panic("%s%s", + "Trying to decr ref count of " + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ - +# endif +#endif if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3834,7 +3782,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. */ @@ -3854,21 +3802,22 @@ Tcl_DbIsShared( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "check shared status"); + Tcl_Panic("%s%s", + "Trying to check shared status of" + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ +# endif +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -3880,7 +3829,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ +#endif return ((objPtr)->refCount > 1); } @@ -3934,10 +3883,11 @@ AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = keyPtr; - Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; - hPtr->key.objPtr = objPtr; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); + hPtr->key.oneWordValue = (char *) objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; @@ -3966,10 +3916,10 @@ TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = keyPtr; + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; - register const char *p1, *p2; - register size_t l1, l2; + register CONST char *p1, *p2; + register int l1, l2; /* * If the object pointers are the same then they match. @@ -4030,7 +3980,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree(hPtr); + ckfree((char *) hPtr); } /* @@ -4056,10 +4006,11 @@ TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = keyPtr; - size_t length; - const char *string = TclGetStringFromObj(objPtr, &length); + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + CONST char *string = TclGetString(objPtr); + int length = objPtr->length; unsigned int result = 0; + int i; /* * I tried a zillion different hash functions and asked many other people @@ -4069,37 +4020,16 @@ 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. - * - * 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] + * 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. */ - if (length > 0) { - result = UCHAR(*string); - while (--length) { - result += (result << 3) + UCHAR(*++string); - } + for (i=0 ; i<length ; i++) { + result += (result << 3) + string[i]; } return result; } @@ -4134,6 +4064,9 @@ Tcl_GetCommandFromObj( * global namespace. */ { register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *refNsPtr; + int result; /* * Get the internal representation, converting to a command type if @@ -4154,36 +4087,31 @@ Tcl_GetCommandFromObj( * to discard the old rep and create a new one. */ - 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; - } - } + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr != &tclCmdNameType) + || (resPtr == NULL) + || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) + || (cmdPtr->flags & CMD_IS_DELETED) + || (interp != cmdPtr->nsPtr->interp) + || (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 = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((result == TCL_OK) && resPtr) { + cmdPtr = resPtr->cmdPtr; + } else { + cmdPtr = NULL; + } } - /* - * OK, must create a new internal representation (or fail) as any cache we - * had is invalid one way or another. - */ - - if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { - return NULL; - } - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); + return (Tcl_Command) cmdPtr; } /* @@ -4201,7 +4129,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 - * TclNRExecuteByteCode has a chance to recognize that it was deleted. + * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ @@ -4218,14 +4146,14 @@ TclSetCmdNameObj( Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; - const char *name; + char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } cmdPtr->refCount++; - resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; @@ -4251,7 +4179,7 @@ TclSetCmdNameObj( } TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; } @@ -4282,7 +4210,8 @@ FreeCmdNameInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* @@ -4299,9 +4228,8 @@ FreeCmdNameInternalRep( */ Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommandMacro(cmdPtr); - ckfree(resPtr); + ckfree((char *) resPtr); } } objPtr->typePtr = NULL; @@ -4332,9 +4260,10 @@ DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; @@ -4369,7 +4298,7 @@ SetCmdNameFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; - const char *name; + char *name; register Command *cmdPtr; Namespace *currNsPtr; register ResolvedCmdName *resPtr; @@ -4387,8 +4316,7 @@ SetCmdNameFromAny( */ name = TclGetString(objPtr); - cmdPtr = (Command *) - Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); + cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* * Free the old internalRep before setting the new one. Do this after @@ -4398,7 +4326,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = objPtr->internalRep.otherValuePtr; + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* @@ -4406,15 +4334,14 @@ SetCmdNameFromAny( */ Command *oldCmdPtr = resPtr->cmdPtr; - if (--oldCmdPtr->refCount == 0) { TclCleanupCommandMacro(oldCmdPtr); } } else { TclFreeIntRep(objPtr); - resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; } @@ -4448,75 +4375,9 @@ SetCmdNameFromAny( } /* - *---------------------------------------------------------------------- - * - * 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, - size_t 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; - } - - /* - * Value is a bignum with a refcount of 14, object pointer at 0x12345678, - * internal representation 0x45671234:0x98765432, string representation - * "1872361827361287" - */ - - 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 \"", TCL_STRLEN); - Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, - 16, "..."); - Tcl_AppendToObj(descObj, "\"", TCL_STRLEN); - } else { - Tcl_AppendToObj(descObj, ", no string representation", TCL_STRLEN); - } - - Tcl_SetObjResult(interp, descObj); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ |