diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 747 |
1 files changed, 212 insertions, 535 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index a00588a..8018fbc 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -178,14 +178,14 @@ static Tcl_ThreadDataKey pendingObjDataKey; #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ + mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } /* @@ -197,9 +197,6 @@ 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); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static void UpdateStringOfOldInt(Tcl_Obj *objPtr); -#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -228,55 +225,37 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -static const Tcl_ObjType oldBooleanType = { +const Tcl_ObjType tclBooleanType= { "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; -#endif -const Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ -}; -const Tcl_ObjType tclDoubleType = { +const Tcl_ObjType tclDoubleType= { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ + SetDoubleFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; const Tcl_ObjType tclIntType = { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ -#else - "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ -#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ -}; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static const Tcl_ObjType oldIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfOldInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ + SetIntFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; -#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; /* @@ -320,7 +299,8 @@ Tcl_ObjType tclCmdNameType = { FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ + SetCmdNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -336,7 +316,7 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - unsigned long refNsId; /* refNsPtr's unique namespace id. Used to + size_t refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created @@ -358,6 +338,17 @@ typedef struct ResolvedCmdName { * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; + +#ifdef TCL_MEM_DEBUG +/* + * Filler matches the value used for filling freed memory in tclCkalloc. + * On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit + * implementations, ref counts will never reach this value (unless explicitly + * incremented without actual references!) + */ +#define FREEDREFCOUNTFILLER \ + (Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8) +#endif /* *------------------------------------------------------------------------- @@ -385,14 +376,8 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); -#if !defined(TCL_NO_DEPRECATED) Tcl_RegisterObjType(&tclStringType); - /* Only registered for 8.7, not for 9.0 any more. - * See [https://core.tcl-lang.org/tk/tktview/6b49149b4e] */ - Tcl_RegisterObjType(&tclUniCharStringType); -#endif Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); @@ -400,15 +385,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); - /* For backward compatibility only ... */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - Tcl_RegisterObjType(&tclIntType); -#if !defined(TCL_WIDE_INT_IS_LONG) - Tcl_RegisterObjType(&oldIntType); -#endif - Tcl_RegisterObjType(&oldBooleanType); -#endif - #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -456,12 +432,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + Tcl_Free(objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -537,7 +513,7 @@ TclGetContLineTable(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } @@ -572,7 +548,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); + ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); if (!newEntry) { /* @@ -596,7 +572,7 @@ TclContinuationsEnter( * doing. */ - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; @@ -660,7 +636,7 @@ TclContinuationsEnterDerived( * better way which doesn't shimmer?) */ - TclGetStringFromObj(objPtr, &length); + (void)TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* @@ -801,11 +777,11 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - ckfree(tsdPtr->lineCLPtr); + Tcl_Free(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -1081,7 +1057,7 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; @@ -1094,7 +1070,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *)ckalloc(sizeof(ObjData)); + objData = (ObjData *)Tcl_Alloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1219,7 +1195,7 @@ Tcl_DbNewObj( * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a - * single ckalloc to reduce the overhead for Tcl_Obj allocation. + * single Tcl_Alloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * @@ -1248,12 +1224,12 @@ TclAllocateFreeObjects(void) * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, + * freeing the memory. TclFinalizeObjects() does not Tcl_Free() this memory, * but leaves it to Tcl's memory subsystem finalization to release it. * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *)ckalloc(bytesToAlloc); + basePtr = (char *)Tcl_Alloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; @@ -1319,7 +1295,7 @@ TclFreeObj( if (!tablePtr) { Tcl_Panic("TclFreeObj: object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (hPtr) { /* * As the Tcl_Obj is going to be deleted we remove the entry. @@ -1328,7 +1304,7 @@ TclFreeObj( ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + Tcl_Free(objData); } Tcl_DeleteHashEntry(hPtr); @@ -1372,7 +1348,7 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree(objPtr); + Tcl_Free(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); @@ -1384,7 +1360,7 @@ TclFreeObj( TclFreeInternalRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree(objToFree); + Tcl_Free(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1408,7 +1384,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1499,7 +1475,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1566,7 +1542,7 @@ TclObjBeingDeleted( const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ const char *bytes = (objPtr)->bytes; \ if (bytes) { \ - (void)TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \ + TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ } else { \ (dupPtr)->bytes = NULL; \ } \ @@ -1649,7 +1625,7 @@ Tcl_GetString( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 + if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1662,7 +1638,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj -- + * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1682,11 +1658,58 @@ Tcl_GetString( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) +#undef TclGetStringFromObj +char * +TclGetStringFromObj( + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + * be returned. */ + void *lengthPtr) /* If non-NULL, the location where the string + * rep's byte array length should * be stored. + * If NULL, no length is stored. */ +{ + if (objPtr->bytes == NULL) { + /* + * 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. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } + if (lengthPtr != NULL) { + if (objPtr->length > INT_MAX) { + Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr" + " cannot handle such long strings. Please use 'Tcl_Size'"); + } + *(int *)lengthPtr = (int)objPtr->length; + } + return objPtr->bytes; +} +#endif /* !defined(TCL_NO_DEPRECATED) */ + +#undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + Tcl_Size *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1708,7 +1731,7 @@ Tcl_GetStringFromObj( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 + if (objPtr->bytes == NULL || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1730,15 +1753,15 @@ Tcl_GetStringFromObj( * the tools needed to set an object's string representation. The * function is determined by the arguments. * - * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes == -1) * Invalid call -- panic! * - * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * objPtr->bytes == NULL && bytes == NULL && numBytes != -1 * Allocation only - allocate space for (numBytes+1) chars. * store in objPtr->bytes and return. Also sets * objPtr->length to 0 and objPtr->bytes[0] to NUL. * - * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * objPtr->bytes == NULL && bytes != NULL && numBytes != -1 * Allocate and copy. bytes is assumed to point to chars to * copy into the string rep. objPtr->length = numBytes. Allocate * array of (numBytes + 1) chars. store in objPtr->bytes. Copy @@ -1747,7 +1770,7 @@ Tcl_GetStringFromObj( * Caller must guarantee there are numBytes chars at bytes to * be copied. * - * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * objPtr->bytes != NULL && bytes == NULL && numBytes != -1 * Truncate. Set objPtr->length to numBytes and * objPr->bytes[numBytes] to NUL. Caller has to guarantee * that a prior allocating call allocated enough bytes for @@ -1769,23 +1792,19 @@ char * Tcl_InitStringRep( Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, - unsigned int numBytes) + size_t numBytes) { assert(objPtr->bytes == NULL || bytes == NULL); - if (numBytes > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - if (objPtr->bytes == NULL) { /* Start with no string rep */ if (numBytes == 0) { TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; if (bytes) { memcpy(objPtr->bytes, bytes, numBytes); } @@ -1797,23 +1816,23 @@ Tcl_InitStringRep( if (numBytes == 0) { return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; objPtr->bytes[objPtr->length] = '\0'; } } } else { /* Start with non-empty string rep (allocated) */ if (numBytes == 0) { - ckfree(objPtr->bytes); + Tcl_Free(objPtr->bytes); TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes, + objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; objPtr->bytes[objPtr->length] = '\0'; } } @@ -1962,145 +1981,6 @@ Tcl_FreeInternalRep( /* *---------------------------------------------------------------------- * - * Tcl_NewBooleanObj -- - * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "intValue" - * is coerced to 1. - * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewLongObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_NewBooleanObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ -{ - return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, intValue!=0); - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewBooleanObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the - * same as the Tcl_NewBooleanObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewBooleanObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - 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. */ -{ - Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = (intValue != 0); - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) -{ - return Tcl_NewBooleanObj(intValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetBooleanObj -- - * - * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "intValue" is coerced to 1. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_SetBooleanObj -void -Tcl_SetBooleanObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Boolean used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); - } - - TclSetIntObj(objPtr, intValue!=0); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This @@ -2140,14 +2020,10 @@ Tcl_GetBoolFromObj( return TCL_ERROR; } do { - if (TclHasInternalRep(objPtr, &tclIntType)) { + if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } - if (TclHasInternalRep(objPtr, &tclBooleanType)) { - result = objPtr->internalRep.longValue != 0; - goto boolEnd; - } if (TclHasInternalRep(objPtr, &tclDoubleType)) { /* * Caution: Don't be tempted to check directly for the "double" @@ -2216,12 +2092,7 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean or int/wideInt. - * - * Warning: If the returned type is "wideInt" (32-bit platforms) and your - * platform is bigendian, you cannot use internalRep.longValue to distinguish - * between false and true. On Windows and most other platforms this still will - * work fine, but basically it is non-portable. + * representation and the type of "objPtr" is set to boolean or int. * *---------------------------------------------------------------------- */ @@ -2261,7 +2132,7 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { Tcl_Size length; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = Tcl_GetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); @@ -2280,7 +2151,7 @@ ParseBoolean( int newBool; char lowerCase[6]; Tcl_Size i, length; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = Tcl_GetStringFromObj(objPtr, &length); if ((length < 1) || (length > 5)) { /* @@ -2379,7 +2250,7 @@ ParseBoolean( goodBoolean: TclFreeInternalRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; @@ -2614,8 +2485,7 @@ SetDoubleFromAny( * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point - * object. This must obey the current tcl_precision value for - * double-to-string conversions. Note: This function does not free an + * object. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * @@ -2644,112 +2514,28 @@ UpdateStringOfDouble( /* *---------------------------------------------------------------------- * - * Tcl_NewIntObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj to create a new integer object end up calling the - * debugging function Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations so - * that the Tcl core can be compiled to do memory debugging of the core - * even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewIntObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ -{ - return Tcl_DbNewWideIntObj(intValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, intValue); - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- + * Tcl_GetIntFromObj -- * - * Tcl_SetIntObj -- + * Retrieve the integer value of 'objPtr'. * - * Modify an object to be an integer and to have the specified integer - * value. + * Value * - * Results: - * None. + * TCL_OK * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. + * Success. * - *---------------------------------------------------------------------- - */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetIntObj -void -Tcl_SetIntObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Integer used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); - } - - TclSetIntObj(objPtr, intValue); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIntFromObj -- - * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. + * TCL_ERROR * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. + * An error occurred during conversion or the integral value can not + * be represented as an integer (it might be too large). An error + * message is left in the interpreter's result if 'interp' is not + * NULL. * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object can not be - * represented by an int, an error message is left in the interpreter's - * result unless "interp" is NULL. + * Effect * - * Side effects: - * If the object is not already an int, the conversion will free any old - * internal representation. + * 'objPtr' is converted to an integer if necessary if it is not one + * already. The conversion frees any previously-existing internal + * representation. * *---------------------------------------------------------------------- */ @@ -2781,7 +2567,6 @@ Tcl_GetIntFromObj( return TCL_OK; #endif } - /* *---------------------------------------------------------------------- @@ -2805,7 +2590,7 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + return TclGetWideIntFromObj(interp, objPtr, &w); } /* @@ -2837,180 +2622,6 @@ UpdateStringOfInt( (void) Tcl_InitStringRep(objPtr, NULL, TclFormatInt(dst, objPtr->internalRep.wideValue)); } - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static void -UpdateStringOfOldInt( - Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); - - TclOOM(dst, TCL_INTEGER_SPACE + 1); - (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(dst, objPtr->internalRep.longValue)); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling the - * debugging function Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewLongObj result in a call to one of the two - * Tcl_NewLongObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewLongObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the - * new object. */ -{ - return Tcl_DbNewWideIntObj(longValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the - * new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, longValue); - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer - * objects end up calling the debugging function Tcl_DbNewLongObj - * instead. We provide two implementations of Tcl_DbNewLongObj so that - * whether the Tcl core is compiled to do memory debugging of the core is - * independent of whether a client requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj - * calls Tcl_DbCkalloc directly with the file name and line number from - * its caller. This simplifies debugging since then the [memory active] - * command will report the caller's file name and line number when - * reporting objects that haven't been freed. - * - * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, - * this function just returns the result of calling Tcl_NewLongObj. - * - * Results: - * The newly created long integer object is returned. This object will - * have an invalid string representation. The returned object has ref - * count 0. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewLongObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new - * object. */ - 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. */ -{ - Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep */ - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = longValue; - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new - * object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) -{ - return Tcl_NewWideIntObj(longValue); -} -#endif /* TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetLongObj -- - * - * Modify an object to be an integer object and to have the specified - * long integer value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetLongObj -void -Tcl_SetLongObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - long longValue) /* Long integer used to initialize the - * object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); - } - - TclSetIntObj(objPtr, longValue); -} -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3582,6 +3193,40 @@ TclGetWideBitsFromObj( /* *---------------------------------------------------------------------- * + * Tcl_GetSizeIntFromObj -- + * + * Attempt to return a Tcl_Size from the Tcl object "objPtr". + * + * Results: + * TCL_OK - the converted Tcl_Size value is stored in *sizePtr + * TCL_ERROR - the error message is stored in interp + * + * Side effects: + * The function may free up any existing internal representation. + * + *---------------------------------------------------------------------- + */ +int +Tcl_GetSizeIntFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + Tcl_Size *sizePtr) /* Place to store resulting int. */ +{ + if (sizeof(Tcl_Size) == sizeof(int)) { + return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); + } else { + Tcl_WideInt wide; + if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) { + return TCL_ERROR; + } + *sizePtr = (Tcl_Size)wide; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * * FreeBignum -- * * This function frees the internal rep of a bignum. @@ -3601,7 +3246,7 @@ FreeBignum( TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; } @@ -4083,7 +3728,15 @@ Tcl_GetNumber( numBytes = 0; } if (numBytes < 0) { - numBytes = (int)strlen(bytes); + numBytes = strlen(bytes); + } + if (numBytes > INT_MAX) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); + } + return TCL_ERROR; } objPtr->bytes = (char *) bytes; @@ -4139,6 +3792,28 @@ Tcl_DecrRefCount( /* *---------------------------------------------------------------------- * + * TclUndoRefCount -- + * + * Decrement the refCount of objPtr without causing it to be freed if it + * drops from 1 to 0. This allows a function increment a refCount but + * then decrement it and still be able to pass return it to a caller, + * possibly with a refCount of 0. The caller must have previously + * incremented the refCount. + * + *---------------------------------------------------------------------- + */ +void +TclUndoRefCount( + Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ +{ + if (objPtr->refCount > 0) { + --objPtr->refCount; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_IsShared -- * * Tests if the object has a ref count greater than one. @@ -4188,7 +3863,7 @@ Tcl_DbIncrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); @@ -4261,7 +3936,7 @@ Tcl_DbDecrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); @@ -4343,7 +4018,7 @@ Tcl_DbIsShared( #endif { #ifdef TCL_MEM_DEBUG - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("checking whether previously disposed object is shared"); @@ -4438,7 +4113,7 @@ AllocObjEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); @@ -4478,7 +4153,9 @@ TclCompareObjKeys( * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - if (objPtr1 == objPtr2) return 1; + if (objPtr1 == objPtr2) { + return 1; + } */ /* @@ -4532,7 +4209,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree(hPtr); + Tcl_Free(hPtr); } /* @@ -4553,15 +4230,15 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +size_t TclHashObjKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_Size length; - const char *string = TclGetStringFromObj(objPtr, &length); - TCL_HASH_TYPE result = 0; + const char *string = Tcl_GetStringFromObj(objPtr, &length); + size_t result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -4667,7 +4344,7 @@ Tcl_GetCommandFromObj( TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) - || ((refNsPtr == resPtr->refNsPtr) + || ((refNsPtr == resPtr->refNsPtr) && (resPtr->refNsId == refNsPtr->nsId) && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { return (Tcl_Command) cmdPtr; @@ -4722,7 +4399,7 @@ SetCmdNameObj( if (resPtr) { fillPtr = resPtr; } else { - fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); + fillPtr = (ResolvedCmdName *)Tcl_Alloc(sizeof(ResolvedCmdName)); fillPtr->refCount = 1; } @@ -4825,7 +4502,7 @@ FreeCmdNameInternalRep( Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - ckfree(resPtr); + Tcl_Free(resPtr); } objPtr->typePtr = NULL; } |