diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 435 |
1 files changed, 206 insertions, 229 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index dfcaff0..5a8ce3b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -37,7 +37,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 @@ -50,7 +50,7 @@ Tcl_Mutex tclObjMutex; char tclEmptyString = '\0'; -#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, @@ -75,7 +75,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 @@ -87,7 +87,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. */ @@ -156,7 +156,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 @@ -210,9 +210,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); @@ -242,6 +241,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 */ @@ -249,6 +249,7 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ @@ -264,19 +265,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 = { @@ -344,17 +349,17 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - size_t 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). */ - size_t 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. */ - size_t 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, @@ -395,8 +400,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); @@ -406,9 +409,12 @@ TclInitObjSubsystem(void) 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 @@ -446,7 +452,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); @@ -1003,7 +1009,7 @@ void TclDbDumpActiveObjects( FILE *outFile) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -1063,7 +1069,7 @@ TclDbInitNewObj( objPtr->length = 0; objPtr->typePtr = NULL; -#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. @@ -1299,7 +1305,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 @@ -1626,32 +1632,30 @@ Tcl_GetString( register 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; } @@ -1687,8 +1691,31 @@ Tcl_GetStringFromObj( * 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; } @@ -1762,7 +1789,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, boolValue!=0); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1810,7 +1837,7 @@ Tcl_DbNewBooleanObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue != 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1857,7 +1884,7 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetLongObj(objPtr, boolValue!=0); + TclSetIntObj(objPtr, boolValue!=0); } #endif /* TCL_NO_DEPRECATED */ @@ -1888,11 +1915,11 @@ Tcl_GetBooleanFromObj( { 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 +1943,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 +1963,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. * *---------------------------------------------------------------------- */ @@ -1960,8 +1986,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 +1996,6 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2113,7 +2132,7 @@ ParseBoolean( numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2294,7 +2313,7 @@ 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) { @@ -2304,12 +2323,6 @@ Tcl_GetDoubleFromObj( *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; } @@ -2427,7 +2440,7 @@ Tcl_NewIntObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, intValue); + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2460,7 +2473,7 @@ Tcl_SetIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } - TclSetLongObj(objPtr, intValue); + TclSetIntObj(objPtr, intValue); } /* @@ -2503,7 +2516,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"; @@ -2538,9 +2551,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); } /* @@ -2569,12 +2581,28 @@ UpdateStringOfInt( char buffer[TCL_INTEGER_SPACE]; register int len; + len = TclFormatInt(buffer, objPtr->internalRep.wideValue); + + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->length = len; +} + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; + len = TclFormatInt(buffer, objPtr->internalRep.longValue); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } +#endif /* *---------------------------------------------------------------------- @@ -2606,8 +2634,8 @@ UpdateStringOfInt( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( @@ -2626,7 +2654,7 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2663,6 +2691,7 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -2679,7 +2708,7 @@ Tcl_DbNewLongObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2717,6 +2746,7 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2727,7 +2757,7 @@ Tcl_SetLongObj( Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } /* @@ -2758,14 +2788,15 @@ Tcl_GetLongFromObj( register 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 @@ -2774,9 +2805,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; @@ -2802,10 +2833,9 @@ Tcl_GetLongFromObj( mp_int big; UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) + if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; + unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { @@ -2813,11 +2843,16 @@ Tcl_GetLongFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *longPtr = - (long) value; + if (value <= 1 + (unsigned long)LONG_MAX) { + *longPtr = - (long) value; + return TCL_OK; + } } else { - *longPtr = (long) value; + if (value <= (unsigned long)ULONG_MAX) { + *longPtr = (long) value; + return TCL_OK; + } } - return TCL_OK; } } #ifndef TCL_WIDE_INT_IS_LONG @@ -2836,49 +2871,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 */ /* *---------------------------------------------------------------------- @@ -2928,7 +2920,7 @@ Tcl_NewWideIntObj( register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2980,7 +2972,7 @@ Tcl_DbNewWideIntObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } @@ -3029,19 +3021,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); } /* @@ -3073,14 +3053,8 @@ Tcl_GetWideIntFromObj( /* 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) { @@ -3113,11 +3087,16 @@ Tcl_GetWideIntFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *wideIntPtr = - (Tcl_WideInt) value; + if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { + *wideIntPtr = - (Tcl_WideInt) value; + return TCL_OK; + } } else { - *wideIntPtr = (Tcl_WideInt) value; + if (value <= (Tcl_WideUInt)WIDE_MAX) { + *wideIntPtr = (Tcl_WideInt) value; + return TCL_OK; + } } - return TCL_OK; } } if (interp != NULL) { @@ -3133,33 +3112,70 @@ 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; + + Tcl_WideUInt value = 0, scratch; + unsigned long numBytes = sizeof(Tcl_WideInt); + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + mp_to_unsigned_bin_n(&big, bytes, &numBytes); + 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 */ /* *---------------------------------------------------------------------- @@ -3402,16 +3418,10 @@ GetBignumFromObj( 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, + TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3521,36 +3531,11 @@ Tcl_SetBignumObj( Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &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; - } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; @@ -3558,19 +3543,18 @@ Tcl_SetBignumObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { + if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetIntObj(objPtr, -(Tcl_WideInt)value); } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + TclSetIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3652,17 +3636,10 @@ 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, @@ -3715,7 +3692,7 @@ Tcl_DbIncrRefCount( 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 @@ -3778,7 +3755,7 @@ Tcl_DbDecrRefCount( 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 @@ -3843,7 +3820,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 |