diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 1457 |
1 files changed, 837 insertions, 620 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index a4df3e7..dbe6686 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -15,8 +15,9 @@ */ #include "tclInt.h" -#include "tommath.h" +#include "tclTomMath.h" #include <math.h> +#include <assert.h> /* * Table of all object types. @@ -37,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL; * TclNewObj macro, however, so must be visible. */ -#ifdef TCL_THREADS +#if TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif @@ -49,9 +50,8 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; -char *tclEmptyStringRep = &tclEmptyString; -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) /* * 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, @@ -76,7 +76,7 @@ typedef struct ObjData { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text @@ -88,7 +88,7 @@ typedef struct ThreadSpecificData { * 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) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ @@ -157,7 +157,7 @@ typedef struct PendingObjData { /* * Macro to set up the local reference to the deletion context. */ -#ifndef TCL_THREADS +#if !TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData @@ -169,7 +169,7 @@ static __thread PendingObjData pendingObjData; static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = \ - Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) + (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* @@ -178,30 +178,16 @@ static Tcl_ThreadDataKey pendingObjDataKey; #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + mp_int *temp = (mp_int *) ckalloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else { \ - if ((bignum).alloc > 0x7FFF) { \ - mp_shrink(&(bignum)); \ - } \ + } 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)); \ } -#define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ - (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \ - (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \ - } - /* * Prototypes for functions defined later in this file: */ @@ -211,9 +197,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, 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); @@ -243,6 +228,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ @@ -250,6 +236,7 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ @@ -265,19 +252,23 @@ const Tcl_ObjType tclDoubleType = { SetDoubleFromAny /* setFromAnyProc */ }; 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 */ }; -#ifndef TCL_WIDE_INT_IS_LONG -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ +#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 */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { @@ -345,23 +336,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + unsigned long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + unsigned int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this + unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, * deleted, hidden, or exposed, and so the * pointer is invalid. */ - int refCount; /* Reference count: 1 for each cmdName object + size_t refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount @@ -396,21 +387,21 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); 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); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS @@ -448,7 +439,7 @@ TclInitObjSubsystem(void) void TclFinalizeThreadObjects(void) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -457,7 +448,7 @@ TclFinalizeThreadObjects(void) if (tablePtr != NULL) { for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = Tcl_GetHashValue(hPtr); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { ckfree(objData); @@ -541,7 +532,7 @@ 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); } @@ -576,7 +567,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); if (!newEntry) { /* @@ -733,7 +724,7 @@ TclContinuationsCopy( Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); if (hPtr) { - ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); + ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } @@ -769,7 +760,7 @@ TclContinuationsGet( if (!hPtr) { return NULL; } - return Tcl_GetHashValue(hPtr); + return (ContLineLoc *)Tcl_GetHashValue(hPtr); } /* @@ -792,7 +783,7 @@ TclContinuationsGet( static void TclThreadFinalizeContLines( - ClientData clientData) + TCL_UNUSED(ClientData)) { /* * Release the hashtable tracking invisible continuation lines. @@ -876,7 +867,7 @@ Tcl_AppendAllObjTypes( * name of each registered type is appended as * a list element. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; int numElems; @@ -897,7 +888,7 @@ Tcl_AppendAllObjTypes( for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); + Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; @@ -924,13 +915,13 @@ const Tcl_ObjType * Tcl_GetObjType( const char *typeName) /* Name of Tcl object type to look up. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; const Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = Tcl_GetHashValue(hPtr); + typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -1001,11 +992,11 @@ Tcl_ConvertToType( *-------------------------------------------------------------- */ +#if TCL_THREADS && defined(TCL_MEM_DEBUG) void TclDbDumpActiveObjects( FILE *outFile) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -1017,7 +1008,7 @@ TclDbDumpActiveObjects( 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); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { fprintf(outFile, @@ -1030,8 +1021,14 @@ TclDbDumpActiveObjects( } } } -#endif } +#else +void +TclDbDumpActiveObjects( + TCL_UNUSED(FILE *)) +{ +} +#endif /* *---------------------------------------------------------------------- @@ -1054,18 +1051,17 @@ TclDbDumpActiveObjects( #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - register Tcl_Obj *objPtr, - register const char *file, /* The name of the source file calling this + Tcl_Obj *objPtr, + 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 + int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; objPtr->typePtr = NULL; + TclInitStringRep(objPtr, NULL, 0); -#ifdef TCL_THREADS +#if TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1079,7 +1075,7 @@ 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; @@ -1092,7 +1088,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = ckalloc(sizeof(ObjData)); + objData = (ObjData *)ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1142,7 +1138,7 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_NewObj(void) { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1184,12 +1180,12 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_DbNewObj( - register 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. */ - register int line) /* Line number in the source file; used for + int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1202,10 +1198,8 @@ Tcl_DbNewObj( Tcl_Obj * Tcl_DbNewObj( - 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_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { return Tcl_NewObj(); } @@ -1239,8 +1233,8 @@ TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; + Tcl_Obj *prevPtr, *objPtr; + int i; /* * This has been noted by Purify to be a potential leak. The problem is @@ -1251,7 +1245,7 @@ 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; @@ -1291,9 +1285,9 @@ TclAllocateFreeObjects(void) #ifdef TCL_MEM_DEBUG void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { - register const Tcl_ObjType *typePtr = objPtr->typePtr; + const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -1301,7 +1295,7 @@ TclFreeObj( ObjInitDeletionContext(context); -# ifdef TCL_THREADS +#if 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 @@ -1323,7 +1317,7 @@ TclFreeObj( * As the Tcl_Obj is going to be deleted we remove the entry. */ - ObjData *objData = Tcl_GetHashValue(hPtr); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { ckfree(objData); @@ -1416,7 +1410,7 @@ TclFreeObj( void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { /* * Invalidate the string rep first so we can use the bytes value for our @@ -1625,35 +1619,33 @@ TclSetDuplicateObj( char * Tcl_GetString( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes != NULL) { - 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) { + if (objPtr->bytes == 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. + * 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. */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); + 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 < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } } return objPtr->bytes; } @@ -1683,14 +1675,37 @@ Tcl_GetString( char * Tcl_GetStringFromObj( - register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - register int *lengthPtr) /* If non-NULL, the location where the string + 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) { + /* + * 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 < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -1700,6 +1715,91 @@ Tcl_GetStringFromObj( /* *---------------------------------------------------------------------- * + * Tcl_InitStringRep -- + * + * This function is called in several configurations to provide all + * the tools needed to set an object's string representation. The + * function is determined by the arguments. + * + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * Invalid call -- panic! + * + * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * 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 + * 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 + * numBytes chars from bytes to objPtr->bytes; Set + * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. + * Caller must guarantee there are numBytes chars at bytes to + * be copied. + * + * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * 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 + * this to be valid. Return objPtr->bytes. + * + * Caller is expected to ascertain that the bytes copied into + * the string rep make up complete valid UTF-8 characters. + * + * Results: + * A pointer to the string rep of objPtr. + * + * Side effects: + * As described above. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_InitStringRep( + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + const char *bytes, + unsigned int numBytes) +{ + assert(objPtr->bytes == NULL || bytes == NULL); + + if (numBytes > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* Allocate */ + if (objPtr->bytes == NULL) { + /* Allocate only as empty - extend later if bytes copied */ + objPtr->length = 0; + if (numBytes) { + objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + if (objPtr->bytes == NULL) { + return NULL; + } + if (bytes) { + /* Copy */ + memcpy(objPtr->bytes, bytes, numBytes); + objPtr->length = (int) numBytes; + } + } else { + TclInitStringRep(objPtr, NULL, 0); + } + } else { + /* objPtr->bytes != NULL bytes == NULL - Truncate */ + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes + 1); + objPtr->length = (int)numBytes; + } + + /* Terminate */ + objPtr->bytes[objPtr->length] = '\0'; + + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string @@ -1717,7 +1817,7 @@ Tcl_GetStringFromObj( void Tcl_InvalidateStringRep( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); @@ -1726,6 +1826,117 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_HasStringRep -- + * + * This function reports whether object has a string representation. + * + * Results: + * Boolean. + *---------------------------------------------------------------------- + */ + +int +Tcl_HasStringRep( + Tcl_Obj *objPtr) /* Object to test */ +{ + return TclHasStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StoreIntRep -- + * + * This function is called to set the object's internal + * representation to match a particular type. + * + * It is the caller's responsibility to guarantee that + * the value of the submitted IntRep is in agreement with + * the value of any existing string rep. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StoreIntRep( + Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ + const Tcl_ObjType *typePtr, /* New type for the object */ + const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ +{ + /* Clear out any existing IntRep ( "shimmer" ) */ + TclFreeIntRep(objPtr); + + /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + if (irPtr) { + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; + + /* Set the type to match */ + objPtr->typePtr = typePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FetchIntRep -- + * + * This function is called to retrieve the object's internal + * representation matching a requested type, if any. + * + * Results: + * A read-only pointer to the associated Tcl_ObjIntRep, or + * NULL if no such internal representation exists. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjIntRep * +Tcl_FetchIntRep( + Tcl_Obj *objPtr, /* Object to fetch from. */ + const Tcl_ObjType *typePtr) /* Requested type */ +{ + return TclFetchIntRep(objPtr, typePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeIntRep -- + * + * This function is called to free an object's internal representation. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets typePtr field to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeIntRep( + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ +{ + TclFreeIntRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewBooleanObj -- * * This function is normally called when not debugging: i.e., when @@ -1734,7 +1945,7 @@ Tcl_InvalidateStringRep( * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewBooleanObj. + * of calling the debugging version Tcl_DbNewLongObj. * * Results: * The newly created object is returned. This object will have an invalid @@ -1751,20 +1962,20 @@ Tcl_InvalidateStringRep( Tcl_Obj * Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ + int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); + return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ + int boolValue) /* Boolean used to initialize new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; - TclNewBooleanObj(objPtr, boolValue); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1795,23 +2006,25 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBooleanObj( - register int boolValue, /* Boolean used to initialize new object. */ + int boolValue, /* 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1820,11 +2033,9 @@ 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 - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ + int boolValue, /* Boolean used to initialize new object. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { return Tcl_NewBooleanObj(boolValue); } @@ -1851,15 +2062,16 @@ Tcl_DbNewBooleanObj( #undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int boolValue) /* Boolean used to set object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int boolValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetBooleanObj(objPtr, boolValue); + TclSetIntObj(objPtr, boolValue!=0); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1883,16 +2095,16 @@ Tcl_SetBooleanObj( int Tcl_GetBooleanFromObj( 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. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + int *boolPtr) /* Place to store resulting boolean. */ { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; + *boolPtr = objPtr->internalRep.longValue != 0; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -1916,12 +2128,6 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1942,7 +2148,12 @@ 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. + * 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. * *---------------------------------------------------------------------- */ @@ -1950,7 +2161,7 @@ Tcl_GetBooleanFromObj( int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine @@ -1960,8 +2171,7 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { - case 0L: case 1L: + if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; @@ -1971,12 +2181,6 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2003,11 +2207,12 @@ TclSetBooleanFromAny( static int ParseBoolean( - register Tcl_Obj *objPtr) /* The object to parse/convert. */ + Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); + size_t i, length = objPtr->length; if ((length == 0) || (length > 5)) { /* @@ -2059,25 +2264,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2086,10 +2291,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2112,7 +2317,7 @@ ParseBoolean( numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2144,7 +2349,7 @@ ParseBoolean( Tcl_Obj * Tcl_NewDoubleObj( - register double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } @@ -2153,9 +2358,9 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_NewDoubleObj( - register double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; @@ -2192,15 +2397,16 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - register double dblValue, /* Double used to initialize the object. */ + double dblValue, /* Double used to initialize the 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; @@ -2212,11 +2418,9 @@ 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 - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ + double dblValue, /* Double used to initialize the object. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { return Tcl_NewDoubleObj(dblValue); } @@ -2242,8 +2446,8 @@ Tcl_DbNewDoubleObj( void Tcl_SetDoubleObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register double dblValue) /* Double used to set the object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); @@ -2275,8 +2479,8 @@ Tcl_SetDoubleObj( int Tcl_GetDoubleFromObj( 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. */ + Tcl_Obj *objPtr, /* The object from which to get a double. */ + double *dblPtr) /* Place to store resulting double. */ { do { if (objPtr->typePtr == &tclDoubleType) { @@ -2293,22 +2497,16 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2336,7 +2534,7 @@ Tcl_GetDoubleFromObj( static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); @@ -2365,17 +2563,14 @@ SetDoubleFromAny( static void UpdateStringOfDouble( - register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ + Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { - char buffer[TCL_DOUBLE_SPACE]; - register int len; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); - len = strlen(buffer); + TclOOM(dst, TCL_DOUBLE_SPACE + 1); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } /* @@ -2408,28 +2603,30 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_NewIntObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ + int intValue) /* Int used to initialize the new object. */ { - return Tcl_DbNewLongObj((long)intValue, "unknown", 0); + return Tcl_DbNewWideIntObj((long)intValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ + int intValue) /* Int used to initialize the new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2448,12 +2645,12 @@ Tcl_NewIntObj( * *---------------------------------------------------------------------- */ - +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetIntObj void Tcl_SetIntObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int intValue) /* Integer used to set object's value. */ + 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"); @@ -2461,32 +2658,30 @@ Tcl_SetIntObj( TclSetIntObj(objPtr, intValue); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * - * Retrieve the integer value of 'objPtr'. - * - * Value + * 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_OK - * - * Success. - * - * TCL_ERROR - * - * 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. + * 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. * - * Effect + * 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. * - * 'objPtr' is converted to an integer if necessary if it is not one - * already. The conversion frees any previously-existing internal - * representation. + * Side effects: + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ @@ -2494,8 +2689,8 @@ Tcl_SetIntObj( int Tcl_GetIntFromObj( 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. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + int *intPtr) /* Place to store resulting int. */ { #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); @@ -2505,7 +2700,7 @@ Tcl_GetIntFromObj( if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { if (interp != NULL) { const char *s = "integer value too large to represent as non-long integer"; @@ -2540,9 +2735,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2566,17 +2760,27 @@ SetIntFromAny( static void UpdateStringOfInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char buffer[TCL_INTEGER_SPACE]; - register int len; + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.wideValue)); +} - len = TclFormatInt(buffer, objPtr->internalRep.longValue); +#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); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.longValue)); } +#endif /* *---------------------------------------------------------------------- @@ -2608,30 +2812,32 @@ UpdateStringOfInt( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG +#ifndef TCL_NO_DEPRECATED #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { - return Tcl_DbNewLongObj(longValue, "unknown", 0); + return Tcl_DbNewWideIntObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2665,23 +2871,26 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2690,16 +2899,15 @@ Tcl_DbNewLongObj( Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + 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_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { - return Tcl_NewLongObj(longValue); + return Tcl_NewWideIntObj(longValue); } #endif /* TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2719,18 +2927,21 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SetLongObj void Tcl_SetLongObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register long longValue) /* Long integer used to initialize the + 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"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2756,18 +2967,19 @@ Tcl_SetLongObj( int Tcl_GetLongFromObj( 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. */ + Tcl_Obj *objPtr, /* The object from which to get a long. */ + long *longPtr) /* Place to store resulting long. */ { do { +#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* - * We return any integer in the range -ULONG_MAX to ULONG_MAX + * We return any integer in the range LONG_MIN to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in @@ -2776,9 +2988,9 @@ Tcl_GetLongFromObj( Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) + if (w >= (Tcl_WideInt)(LONG_MIN) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = Tcl_WideAsLong(w); + *longPtr = (long) w; return TCL_OK; } goto tooLarge; @@ -2801,28 +3013,30 @@ Tcl_GetLongFromObj( * values in the unsigned long range will fit in a long. */ + { mp_int big; + unsigned long scratch, value = 0; + unsigned char *bytes = (unsigned char *) &scratch; + size_t numBytes; - UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) - / MP_DIGIT_BIT) { - unsigned long value = 0; - size_t numBytes; - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { + TclUnpackBignum(objPtr, big); + if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { + } + if (big.sign) { + if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = - (long) value; - } else { + return TCL_OK; + } + } else { + if (value <= (unsigned long)ULONG_MAX) { *longPtr = (long) value; + return TCL_OK; } - return TCL_OK; } } + } #ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif @@ -2839,49 +3053,6 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from the - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; - - /* - * Note that sprintf will generate a compiler warning under Mingw claiming - * %I64 is an unknown format specifier. Just ignore this warning. We can't - * use %L as the format specifier since that gets printed as a 32 bit - * value. - */ - - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2913,7 +3084,7 @@ UpdateStringOfWideInt( Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { @@ -2924,14 +3095,14 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2972,7 +3143,7 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this @@ -2980,10 +3151,10 @@ Tcl_DbNewWideIntObj( int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } @@ -2991,13 +3162,11 @@ Tcl_DbNewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + Tcl_WideInt wideValue, /* 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_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { return Tcl_NewWideIntObj(wideValue); } @@ -3023,8 +3192,8 @@ Tcl_DbNewWideIntObj( void Tcl_SetWideIntObj( - register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - register Tcl_WideInt wideValue) + Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + Tcl_WideInt wideValue) /* Wide integer used to initialize the * object's value. */ { @@ -3032,19 +3201,7 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); - } else { -#ifndef TCL_WIDE_INT_IS_LONG - TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclBNInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif - } + TclSetIntObj(objPtr, wideValue); } /* @@ -3071,19 +3228,13 @@ Tcl_SetWideIntObj( int Tcl_GetWideIntFromObj( 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) + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3102,25 +3253,26 @@ Tcl_GetWideIntFromObj( */ mp_int big; - - UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) - + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - Tcl_WideUInt value = 0; - size_t numBytes; - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { + Tcl_WideUInt value = 0; + size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + TclUnpackBignum(objPtr, big); + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (big.sign) { + if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = - (Tcl_WideInt) value; - } else { + return TCL_OK; + } + } else { + if (value <= (Tcl_WideUInt)WIDE_MAX) { *wideIntPtr = (Tcl_WideInt) value; + return TCL_OK; } - return TCL_OK; } } if (interp != NULL) { @@ -3136,33 +3288,76 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * - * SetWideIntFromAny -- + * TclGetWideBitsFromObj -- * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a int, double or bignum, an attempt will be made + * to convert it to one of these. Out-of-range values don't result in an + * error, but only the least significant 64 bits will be returned. * * Results: - * The return value is a standard object Tcl result. If an error occurs + * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * + * Side effects: + * If the object is not already an int, double or bignum object, the + * conversion will free any old internal representation. + * *---------------------------------------------------------------------- */ -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ +int +TclGetWideBitsFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + do { + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + if (objPtr->typePtr == &tclBignumType) { + mp_int big; + mp_err err; + + Tcl_WideUInt value = 0, scratch; + size_t numBytes; + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + if (err == MP_OKAY) { + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + } + if (err != MP_OKAY) { + return TCL_ERROR; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; + mp_clear(&big); + return TCL_OK; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3183,7 +3378,7 @@ FreeBignum( { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM(objPtr, toFree); + TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { ckfree(objPtr->internalRep.twoPtrValue.ptr1); @@ -3216,7 +3411,7 @@ DupBignum( mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); + TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } @@ -3249,12 +3444,10 @@ UpdateStringOfBignum( { mp_int bignumVal; int size; - int status; char *stringVal; - UNPACK_BIGNUM(objPtr, bignumVal); - status = mp_radix_size(&bignumVal, 10, &size); - if (status != MP_OKAY) { + TclUnpackBignum(objPtr, bignumVal); + if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { @@ -3269,13 +3462,14 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); - status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10); - if (status != MP_OKAY) { + + stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + + TclOOM(stringVal, size); + if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing NUL byte. */ + (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* @@ -3299,14 +3493,14 @@ UpdateStringOfBignum( Tcl_Obj * Tcl_NewBignumObj( - mp_int *bignumValue) + void *bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * Tcl_NewBignumObj( - mp_int *bignumValue) + void *bignumValue) { Tcl_Obj *objPtr; @@ -3337,7 +3531,7 @@ Tcl_NewBignumObj( #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBignumObj( - mp_int *bignumValue, + void *bignumValue, const char *file, int line) { @@ -3350,9 +3544,9 @@ Tcl_DbNewBignumObj( #else Tcl_Obj * Tcl_DbNewBignumObj( - mp_int *bignumValue, - const char *file, - int line) + void *bignumValue, + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) { return Tcl_NewBignumObj(bignumValue); } @@ -3391,37 +3585,34 @@ GetBignumFromObj( if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); + TclUnpackBignum(objPtr, temp); if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "insufficient memory to unpack bignum", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } return TCL_ERROR; } } else { - UNPACK_BIGNUM(objPtr, *bignumValue); + TclUnpackBignum(objPtr, *bignumValue); + /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; + /* + * TODO: If objPtr has a string rep, this leaves + * it undisturbed. Not clear that's proper. Pure + * bignum values are converted to empty string. + */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - TclBNInitBignumFromWideInt(bignumValue, - objPtr->internalRep.wideValue); + if (mp_init_i64(bignumValue, + objPtr->internalRep.wideValue) != MP_OKAY) { + return TCL_ERROR; + } return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3465,9 +3656,9 @@ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - mp_int *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 1, bignumValue); + return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); } /* @@ -3500,9 +3691,9 @@ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - mp_int *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 0, bignumValue); + return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); } /* @@ -3525,63 +3716,34 @@ Tcl_TakeBignumFromObj( void Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ - mp_int *bignumValue) /* Value to store */ + void *big) /* Value to store */ { + Tcl_WideUInt value = 0; + size_t numBytes; + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + mp_int *bignumValue = (mp_int *) big; + if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - unsigned long value = 0; - size_t numBytes; - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_ubin(bignumValue, bytes, sizeof(long), &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); - } else { - TclSetLongObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; + if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { + goto tooLargeForWide; } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - Tcl_WideUInt value = 0; - size_t numBytes; - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; - - if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideInt), &numBytes) != MP_OKAY) { - goto tooLargeForWide; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { - goto tooLargeForWide; - } - if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); - } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); - } - mp_clear(bignumValue); - return; + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { + goto tooLargeForWide; } + if (bignumValue->sign) { + TclSetIntObj(objPtr, -(Tcl_WideInt)value); + } else { + TclSetIntObj(objPtr, (Tcl_WideInt)value); + } + mp_clear(bignumValue); + return; tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3608,8 +3770,9 @@ Tcl_SetBignumObj( void TclSetBignumIntRep( Tcl_Obj *objPtr, - mp_int *bignumValue) + void *big) { + mp_int *bignumValue = (mp_int *)big; objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); @@ -3663,23 +3826,16 @@ TclGetNumberFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *typePtr = TCL_NUMBER_WIDE; + *typePtr = TCL_NUMBER_INT; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, - (int) sizeof(mp_int)); + mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, + sizeof(mp_int)); - UNPACK_BIGNUM(objPtr, *bigPtr); + TclUnpackBignum(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; @@ -3692,6 +3848,71 @@ TclGetNumberFromObj( /* *---------------------------------------------------------------------- * + * Tcl_IncrRefCount -- + * + * Increments the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_IncrRefCount +void +Tcl_IncrRefCount( + Tcl_Obj *objPtr) /* The object we are registering a reference to. */ +{ + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DecrRefCount -- + * + * Decrements the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DecrRefCount +void +Tcl_DecrRefCount( + Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ +{ + if (objPtr->refCount-- <= 1) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsShared -- + * + * Tests if the object has a ref count greater than one. + * + * Results: + * Boolean value that is the result of the test. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_IsShared +int +Tcl_IsShared( + Tcl_Obj *objPtr) /* The object to test for being shared. */ +{ + return ((objPtr)->refCount > 1); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This function is normally called when debugging: i.e., when @@ -3710,23 +3931,23 @@ TclGetNumberFromObj( *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( - register Tcl_Obj *objPtr, /* The object we are registering a reference + Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ 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. */ { -#ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if 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 @@ -3748,9 +3969,19 @@ Tcl_DbIncrRefCount( } } # endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ ++(objPtr)->refCount; } +#else /* !TCL_MEM_DEBUG */ +void +Tcl_DbIncrRefCount( + Tcl_Obj *objPtr, /* The object we are registering a reference + * to. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +{ + ++(objPtr)->refCount; +} +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -3773,23 +4004,23 @@ Tcl_DbIncrRefCount( *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( - register Tcl_Obj *objPtr, /* The object we are releasing a reference + Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ 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. */ { -#ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if 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 @@ -3811,12 +4042,24 @@ Tcl_DbDecrRefCount( } } # endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ if (objPtr->refCount-- <= 1) { TclFreeObj(objPtr); } } +#else /* !TCL_MEM_DEBUG */ +void +Tcl_DbDecrRefCount( + Tcl_Obj *objPtr, /* The object we are releasing a reference + * to. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +{ + if (objPtr->refCount-- <= 1) { + TclFreeObj(objPtr); + } +} +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -3841,11 +4084,16 @@ Tcl_DbDecrRefCount( int Tcl_DbIsShared( - register Tcl_Obj *objPtr, /* The object to test for being shared. */ + Tcl_Obj *objPtr, /* The object to test for being shared. */ +#ifdef TCL_MEM_DEBUG 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. */ +#else + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +#endif { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { @@ -3854,7 +4102,7 @@ Tcl_DbIsShared( Tcl_Panic("checking whether previously disposed object is shared"); } -# ifdef TCL_THREADS +#if 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 @@ -3913,7 +4161,7 @@ Tcl_DbIsShared( void Tcl_InitObjHashTable( - register Tcl_HashTable *tablePtr) + Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { @@ -3939,11 +4187,11 @@ Tcl_InitObjHashTable( static Tcl_HashEntry * AllocObjEntry( - Tcl_HashTable *tablePtr, /* Hash table. */ + TCL_UNUSED(Tcl_HashTable *), 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 = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); @@ -3974,10 +4222,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; + const char *p1, *p2; + size_t l1, l2; /* * If the object pointers are the same then they match. @@ -4058,15 +4306,15 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclHashObjKey( - Tcl_HashTable *tablePtr, /* Hash table. */ + TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = keyPtr; + Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; int length; const char *string = TclGetStringFromObj(objPtr, &length); - unsigned int result = 0; + TCL_HASH_TYPE result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -4134,13 +4382,13 @@ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ - register Tcl_Obj *objPtr) /* The object containing the command's name. + Tcl_Obj *objPtr) /* The object containing the command's name. * If the name starts with "::", will be * looked up in global namespace. Else, looked * up first in the current namespace, then in * global namespace. */ { - register ResolvedCmdName *resPtr; + ResolvedCmdName *resPtr; /* * Get the internal representation, converting to a command type if @@ -4161,15 +4409,14 @@ 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; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; + if (objPtr->typePtr == &tclCmdNameType) { + 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 *) + Namespace *refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) @@ -4186,11 +4433,11 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } - resPtr = objPtr->internalRep.twoPtrValue.ptr1; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } @@ -4214,57 +4461,78 @@ Tcl_GetCommandFromObj( *---------------------------------------------------------------------- */ -void -TclSetCmdNameObj( - Tcl_Interp *interp, /* Points to interpreter containing command - * that should be cached in objPtr. */ - register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a - * CmdName object. */ - Command *cmdPtr) /* Points to Command structure that the - * CmdName object should refer to. */ +static void +SetCmdNameObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Command *cmdPtr, + ResolvedCmdName *resPtr) { Interp *iPtr = (Interp *) interp; - register ResolvedCmdName *resPtr; - register Namespace *currNsPtr; - const char *name; + ResolvedCmdName *fillPtr; + const char *name = TclGetString(objPtr); - if (objPtr->typePtr == &tclCmdNameType) { - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { - return; - } + if (resPtr) { + fillPtr = resPtr; + } else { + fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); + fillPtr->refCount = 1; } + fillPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; + fillPtr->cmdEpoch = cmdPtr->cmdEpoch; - name = TclGetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { + /* NOTE: relying on NULL termination here. */ + if ((name[0] == ':') && (name[1] == ':')) { /* - * The name is fully qualified: set the referring namespace to - * NULL. + * Fully qualified names always resolve to same thing. No need + * to record resolution context information. */ - resPtr->refNsPtr = NULL; + fillPtr->refNsPtr = NULL; + fillPtr->refNsId = 0; /* Will not be read */ + fillPtr->refNsCmdEpoch = 0; /* Will not be read */ } else { /* - * Get the current namespace. + * Record current state of current namespace as the resolution + * context of this command name lookup. */ + Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; + + fillPtr->refNsPtr = currNsPtr; + fillPtr->refNsId = currNsPtr->nsId; + fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } - currNsPtr = iPtr->varFramePtr->nsPtr; + if (resPtr == NULL) { + TclFreeIntRep(objPtr); - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } +} - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; +void +TclSetCmdNameObj( + Tcl_Interp *interp, /* Points to interpreter containing command + * that should be cached in objPtr. */ + Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a + * CmdName object. */ + Command *cmdPtr) /* Points to Command structure that the + * CmdName object should refer to. */ +{ + ResolvedCmdName *resPtr; + + if (objPtr->typePtr == &tclCmdNameType) { + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { + return; + } + } + + SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } /* @@ -4290,18 +4558,17 @@ TclSetCmdNameObj( static void FreeCmdNameInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal + Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ - if (resPtr->refCount-- == 1) { + if (resPtr->refCount-- <= 1) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName @@ -4313,7 +4580,6 @@ FreeCmdNameInternalRep( TclCleanupCommandMacro(cmdPtr); ckfree(resPtr); } - } objPtr->typePtr = NULL; } @@ -4340,15 +4606,13 @@ FreeCmdNameInternalRep( static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - if (resPtr != NULL) { resPtr->refCount++; - } copyPtr->typePtr = &tclCmdNameType; } @@ -4376,13 +4640,11 @@ DupCmdNameInternalRep( static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { - Interp *iPtr = (Interp *) interp; const char *name; - register Command *cmdPtr; - Namespace *currNsPtr; - register ResolvedCmdName *resPtr; + Command *cmdPtr; + ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; @@ -4401,59 +4663,31 @@ SetCmdNameFromAny( Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Free the old internalRep before setting the new one. Do this after - * getting the string rep to allow the conversion code (in particular, - * Tcl_GetStringFromObj) to use that old internalRep. + * Stop shimmering and caching nothing when we found nothing. Just + * report the failure to find the command as an error. */ - if (cmdPtr) { - cmdPtr->refCount++; - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) - && resPtr && (resPtr->refCount == 1)) { - /* - * Reuse the old ResolvedCmdName struct instead of freeing it - */ - - Command *oldCmdPtr = resPtr->cmdPtr; - - if (--oldCmdPtr->refCount == 0) { - TclCleanupCommandMacro(oldCmdPtr); - } - } else { - TclFreeIntRep(objPtr); - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - if ((*name++ == ':') && (*name == ':')) { - /* - * The name is fully qualified: set the referring namespace to - * NULL. - */ + if (cmdPtr == NULL) { + return TCL_ERROR; + } - resPtr->refNsPtr = NULL; - } else { - /* - * Get the current namespace. - */ + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { + /* + * Re-use existing ResolvedCmdName struct when possible. + * Cleanup the old fields that need it. + */ - currNsPtr = iPtr->varFramePtr->nsPtr; + Command *oldCmdPtr = resPtr->cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + if (oldCmdPtr->refCount-- <= 1) { + TclCleanupCommandMacro(oldCmdPtr); } } else { - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + resPtr = NULL; } + + SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); return TCL_OK; } @@ -4475,12 +4709,11 @@ SetCmdNameFromAny( int Tcl_RepresentationCmd( - ClientData clientData, + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { @@ -4494,36 +4727,20 @@ Tcl_RepresentationCmd( * "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); + " object pointer at %p", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, objv[1]); - /* - * This is a workaround to silence reports from `make valgrind` - * on 64-bit systems. The problem is that the test suite - * includes calling the [represenation] command on values of - * &tclDoubleType. When these values are created, the "doubleValue" - * is set, but when the "twoPtrValue" is examined, its "ptr2" - * field has never been initialized. Since [representation] - * presents the value of the ptr2 value in its output, valgrind - * alerts about the read of uninitialized memory. - * - * The general problem with [representation], that it can read - * and report uninitialized fields, is still present. This is - * just the minimal workaround to silence one particular test. - */ - - if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) { - objv[1]->internalRep.twoPtrValue.ptr2 = NULL; - } 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]->typePtr == &tclDoubleType) { + Tcl_AppendPrintfToObj(descObj, ", internal representation %g", + objv[1]->internalRep.doubleValue); + } else { + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + } } if (objv[1]->bytes) { |