diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 2482 |
1 files changed, 959 insertions, 1523 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index f321399..230842a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4,20 +4,20 @@ * This file contains Tcl object-related functions that are used by many * Tcl commands. * - * Copyright © 1995-1997 Sun Microsystems, Inc. - * Copyright © 1999 Scriptics Corporation. - * Copyright © 2001 ActiveState Corporation. - * Copyright © 2005 Kevin B. Kenny. All rights reserved. - * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1999 by Scriptics Corporation. + * Copyright (c) 2001 by ActiveState Corporation. + * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclTomMath.h" +#include "tommath.h" +#include <float.h> #include <math.h> -#include <assert.h> /* * Table of all object types. @@ -38,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL; * TclNewObj macro, however, so must be visible. */ -#if TCL_THREADS +#ifdef TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif @@ -50,17 +50,18 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; - -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +char *tclEmptyStringRep = &tclEmptyString; + +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * Structure for tracking the source file and line number where a given - * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, - * for sanity checking purposes. + * Structure for tracking the source file and line number where a given Tcl_Obj + * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity + * checking purposes. */ -typedef struct { +typedef struct ObjData { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ - const char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ @@ -76,29 +77,34 @@ typedef struct { * The structure defined below is used in this file only. */ -typedef struct { - Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj - * generated by a call to the function - * TclSubstTokens() from a literal text - * where bs+nl sequences occurred in it, if - * any. I.e. this table keeps track of - * invisible and stripped continuation lines. - * Its keys are Tcl_Obj pointers, the values - * are ContLineLoc pointers. See the file - * tclCompile.h for the definition of this - * structure, and for references to all - * related places in the core. */ -#if 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. */ +typedef struct ThreadSpecificData { + Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj + * generated by a call to the function + * TclSubstTokens() from a literal text + * where bs+nl sequences occured in it, if + * any. I.e. this table keeps track of + * invisible/stripped continuation lines. Its + * keys are Tcl_Obj pointers, the values are + * ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all related + * places in the core. + */ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + /* + * Thread local table that is used to check that a Tcl_Obj was not + * allocated by some other thread. + */ + + Tcl_HashTable *objThreadMap; #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -static void TclThreadFinalizeContLines(void *clientData); -static ThreadSpecificData *TclGetContLineTable(void); +static void ContLineLocFree (char* clientData); +static void TclThreadFinalizeContLines (ClientData clientData); +static ThreadSpecificData* TclGetContLineTable (void); /* * Nested Tcl_Obj deletion management support @@ -111,14 +117,14 @@ static ThreadSpecificData *TclGetContLineTable(void); */ typedef struct PendingObjData { - int deletionCount; /* Count of the number of invocations of + int deletionCount; /* Count of the number of invokations of * TclFreeObj() are on the stack (at least * conceptually; many are actually expanded * macros). */ Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() * invoked upon them but which can't be * deleted yet because they are in a nested - * invocation of TclFreeObj(). By postponing + * invokation of TclFreeObj(). By postponing * this way, we limit the maximum overall C * stack depth when deleting a complex object. * The down-side is that we alter the overall @@ -145,31 +151,27 @@ typedef struct PendingObjData { #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ - * for our pointer chain: push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + * for our pointer chain: push onto the head of the stack. */ \ + (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ - (objPtrVar) = (contextPtr)->deletionStack; \ +#define PopObjToDelete(contextPtr,objPtrVar) \ + (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. */ -#if !TCL_THREADS +#ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = &pendingObjData -#elif defined(HAVE_FAST_TSD) -static __thread PendingObjData pendingObjData; -#define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = &pendingObjData + PendingObjData *CONST contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ - (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) + PendingObjData *CONST contextPtr = (PendingObjData *) \ + Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* @@ -177,15 +179,29 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7FFF) { \ - 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))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + if ((bignum).used > 0x7fff) { \ + mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \ + (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \ + } else { \ + if ((bignum).alloc > 0x7fff) { \ + mp_shrink(&(bignum)); \ + } \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ + (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ + } + +#define UNPACK_BIGNUM(objPtr, bignum) \ + if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ + } else { \ + (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \ + (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ + (bignum).alloc = \ + ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ + (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ } /* @@ -193,12 +209,14 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ static int ParseBoolean(Tcl_Obj *objPtr); +static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static void UpdateStringOfOldInt(Tcl_Obj *objPtr); +#ifndef NO_WIDE_TYPE +static void UpdateStringOfWideInt(Tcl_Obj *objPtr); +static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -228,62 +246,56 @@ 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 */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ +static Tcl_ObjType oldBooleanType = { + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ }; -#endif -const Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ +Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclDoubleType = { - "double", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ +Tcl_ObjType tclDoubleType = { + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclIntType = { -#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 */ +Tcl_ObjType tclIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static const Tcl_ObjType oldIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfOldInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ +#ifndef NO_WIDE_TYPE +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ }; #endif -const Tcl_ObjType tclBignumType = { - "bignum", /* name */ - FreeBignum, /* freeIntRepProc */ - DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ +Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ -const Tcl_HashKeyType tclObjHashKeyType = { +Tcl_HashKeyType tclObjHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ TclHashObjKey, /* hashKeyProc */ @@ -305,22 +317,14 @@ const Tcl_HashKeyType tclObjHashKeyType = { * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions * use the second internal pointer field of the twoPtrValue field for their * own purposes. - * - * TRICKY POINT! Some extensions update this structure! (Notably, these - * include TclBlend and TCom). This is highly ill-advised on their part, but - * does allow them to delete a command when references to it are gone, which - * is fragile but useful given their somewhat-OO style. Because of this, this - * structure MUST NOT be const so that the C compiler puts the data in - * writable memory. [Bug 2558422] [Bug 07d13d99b0a9] - * TODO: Provide a better API for those extensions so that they can coexist... */ -Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ +static Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; /* @@ -336,23 +340,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - unsigned long refNsId; /* refNsPtr's unique namespace id. Used to + 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). */ - Tcl_Size refNsCmdEpoch; /* Value of the referencing namespace's + 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. */ - Tcl_Size cmdEpoch; /* Value of the command's cmdEpoch when this + 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. */ - size_t refCount; /* Reference count: 1 for each cmdName object + int 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 @@ -387,26 +391,21 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); -#if !defined(TCL_NO_DEPRECATED) + Tcl_RegisterObjType(&tclEndOffsetType); + Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); - /* Only registered for 8.7, not for 9.0 any more. - * See [https://core.tcl-lang.org/tk/tktview/6b49149b4e] */ - Tcl_RegisterObjType(&tclUniCharStringType); -#endif Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); + 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 NO_WIDE_TYPE + Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS @@ -415,7 +414,6 @@ TclInitObjSubsystem(void) tclObjsFreed = 0; { int i; - for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } @@ -444,7 +442,7 @@ TclInitObjSubsystem(void) void TclFinalizeThreadObjects(void) { -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -453,15 +451,15 @@ TclFinalizeThreadObjects(void) if (tablePtr != NULL) { for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); + ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + ckfree((char *) objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + ckfree((char *) tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -523,8 +521,8 @@ TclFinalizeObjects(void) *---------------------------------------------------------------------- */ -static ThreadSpecificData * -TclGetContLineTable(void) +static ThreadSpecificData* +TclGetContLineTable() { /* * Initialize the hashtable tracking invisible continuation lines. For @@ -535,11 +533,10 @@ TclGetContLineTable(void) */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); - Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); + Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); } return tsdPtr; } @@ -562,17 +559,18 @@ TclGetContLineTable(void) *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsEnter( - Tcl_Obj *objPtr, - Tcl_Size num, - Tcl_Size *loc) +ContLineLoc* +TclContinuationsEnter(Tcl_Obj* objPtr, + int num, + int* loc) { int newEntry; ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); + + ContLineLoc* clLocPtr = + (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); if (!newEntry) { /* @@ -584,25 +582,25 @@ TclContinuationsEnter( * the switch command is identical, mapping them all to the same * literal. An interesting result of this is that the number and * locations (offset) of invisible continuation lines in the literal - * are the same for all occurrences. + * are the same for all occurences. * * Note that while reusing the existing entry is possible it requires * the same actions as for a new entry because we have to copy the * incoming num/loc data even so. Because we are called from * TclContinuationsEnterDerived for this case, which modified the * stored locations (Rebased to the proper relative offset). Just - * returning the stored entry would rebase them a second time, or - * more, hosing the data. It is easier to simply replace, as we are - * doing. + * returning the stored entry and data would rebase them a second + * time, or more, hosing the data. It is easier to simply replace, as + * we are doing. */ - ckfree(Tcl_GetHashValue(hPtr)); + ckfree((char *) Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; - memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size)); - clLocPtr->loc[num] = CLL_END; /* Sentinel */ - Tcl_SetHashValue(hPtr, clLocPtr); + memcpy (&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue (hPtr, clLocPtr); return clLocPtr; } @@ -627,15 +625,8 @@ TclContinuationsEnter( */ void -TclContinuationsEnterDerived( - Tcl_Obj *objPtr, - Tcl_Size start, - Tcl_Size *clNext) +TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) { - Tcl_Size length; - Tcl_Size end, num; - Tcl_Size *wordCLLast = clNext; - /* * We have to handle invisible continuations lines here as well, despite * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If @@ -656,15 +647,20 @@ TclContinuationsEnterDerived( */ /* - * First compute the range of the word within the script. (Is there a - * better way which doesn't shimmer?) + * First compute the range of the word within the script. */ - TclGetStringFromObj(objPtr, &length); - end = start + length; /* First char after the word */ + int length, end, num; + int* wordCLLast = clNext; + + Tcl_GetStringFromObj(objPtr, &length); + /* Is there a better way which doesn't shimmer ? */ + + end = start + length; /* first char after the word */ /* - * Then compute the table slice covering the range of the word. + * Then compute the table slice covering the range of + * the word. */ while (*wordCLLast >= 0 && *wordCLLast < end) { @@ -672,19 +668,21 @@ TclContinuationsEnterDerived( } /* - * And generate the table from the slice, if it was not empty. + * And generate the table from the slice, if it was + * not empty. */ num = wordCLLast - clNext; if (num) { - Tcl_Size i; - ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); + int i; + ContLineLoc* clLocPtr = + TclContinuationsEnter(objPtr, num, clNext); /* * Re-base the locations. */ - for (i=0 ; i<num ; i++) { + for (i=0;i<num;i++) { clLocPtr->loc[i] -= start; /* @@ -706,9 +704,9 @@ TclContinuationsEnterDerived( * TclContinuationsCopy -- * * This procedure is a helper which copies the continuation line - * information associated with a Tcl_Obj* to another Tcl_Obj*. It is - * assumed that both contain the same string/script. Use this when a - * script is duplicated because it was shared. + * information associated with a Tcl_Obj* to another Tcl_Obj*. + * It is assumed that both contain the same string/script. Use + * this when a script is duplicated because it was shared. * * Results: * None. @@ -721,16 +719,13 @@ TclContinuationsEnterDerived( */ void -TclContinuationsCopy( - Tcl_Obj *objPtr, - Tcl_Obj *originObjPtr) +TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); if (hPtr) { - ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr); + ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } @@ -745,8 +740,8 @@ TclContinuationsCopy( * information associated with a Tcl_Obj*, if it has any. * * Results: - * A reference to the continuation line location table, or NULL if the - * Tcl_Obj* has no such information associated with it. + * A reference to the continuation line location table, or NULL + * if the Tcl_Obj* has no such information associated with it. * * Side effects: * None. @@ -755,18 +750,17 @@ TclContinuationsCopy( *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsGet( - Tcl_Obj *objPtr) +ContLineLoc* +TclContinuationsGet(Tcl_Obj* objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); - if (!hPtr) { - return NULL; + if (hPtr) { + return (ContLineLoc*) Tcl_GetHashValue (hPtr); + } else { + return NULL; } - return (ContLineLoc *)Tcl_GetHashValue(hPtr); } /* @@ -788,8 +782,7 @@ TclContinuationsGet( */ static void -TclThreadFinalizeContLines( - TCL_UNUSED(void *)) +TclThreadFinalizeContLines (ClientData clientData) { /* * Release the hashtable tracking invisible continuation lines. @@ -800,16 +793,46 @@ TclThreadFinalizeContLines( Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ckfree(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + /* + * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because + * here we can be sure that the compiler will not hold references to + * the data in the hashtable, and using TEF might bork the + * finalization sequence. + */ + ContLineLocFree (Tcl_GetHashValue (hPtr)); + Tcl_DeleteHashEntry (hPtr); } - Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - ckfree(tsdPtr->lineCLPtr); + Tcl_DeleteHashTable (tsdPtr->lineCLPtr); + ckfree((char *) tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } /* + *---------------------------------------------------------------------- + * + * ContLineLocFree -- + * + * The freProc for continuation line location tables. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +ContLineLocFree (char* clientData) +{ + ckfree (clientData); +} + +/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -830,7 +853,7 @@ TclThreadFinalizeContLines( void Tcl_RegisterObjType( - const Tcl_ObjType *typePtr) /* Information about object type; storage must + Tcl_ObjType *typePtr) /* Information about object type; storage must * be statically allocated (must live * forever). */ { @@ -873,9 +896,9 @@ Tcl_AppendAllObjTypes( * name of each registered type is appended as * a list element. */ { - Tcl_HashEntry *hPtr; + register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Tcl_Size numElems; + int numElems; /* * Get the test for a valid list out of the way first. @@ -894,7 +917,7 @@ Tcl_AppendAllObjTypes( for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1)); + Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; @@ -917,17 +940,17 @@ Tcl_AppendAllObjTypes( *---------------------------------------------------------------------- */ -const Tcl_ObjType * +Tcl_ObjType * Tcl_GetObjType( - const char *typeName) /* Name of Tcl object type to look up. */ + CONST char *typeName) /* Name of Tcl object type to look up. */ { - Tcl_HashEntry *hPtr; - const Tcl_ObjType *typePtr = NULL; + register Tcl_HashEntry *hPtr; + Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr); + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -957,7 +980,7 @@ int Tcl_ConvertToType( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object to convert. */ - const Tcl_ObjType *typePtr) /* The target type. */ + Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; @@ -973,7 +996,7 @@ Tcl_ConvertToType( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't convert value to type %s", typePtr->name)); - Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); } return TCL_ERROR; } @@ -998,11 +1021,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; @@ -1011,10 +1034,10 @@ TclDbDumpActiveObjects( tablePtr = tsdPtr->objThreadMap; if (tablePtr != NULL) { - fprintf(outFile, "total objects: %" TCL_SIZE_MODIFIER "d\n", tablePtr->numEntries); + fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); + ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { fprintf(outFile, @@ -1027,14 +1050,8 @@ TclDbDumpActiveObjects( } } } -} -#else -void -TclDbDumpActiveObjects( - TCL_UNUSED(FILE *)) -{ -} #endif +} /* *---------------------------------------------------------------------- @@ -1043,7 +1060,7 @@ TclDbDumpActiveObjects( * * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is * enabled. This function will initialize the members of a Tcl_Obj - * struct. Initialization would be done inline via the TclNewObj macro + * struct. Initilization would be done inline via the TclNewObj macro * when compiling without TCL_MEM_DEBUG. * * Results: @@ -1057,17 +1074,18 @@ TclDbDumpActiveObjects( #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - Tcl_Obj *objPtr, - const char *file, /* The name of the source file calling this + register Tcl_Obj *objPtr, + register 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 + register int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; objPtr->typePtr = NULL; - TclInitEmptyStringRep(objPtr); -#if TCL_THREADS +#ifdef TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1081,11 +1099,12 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; - hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } @@ -1094,7 +1113,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *)ckalloc(sizeof(ObjData)); + objData = (ObjData *) ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1144,7 +1163,7 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_NewObj(void) { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1186,12 +1205,12 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_DbNewObj( - const char *file, /* The name of the source file calling this + register CONST char *file, /* The name of the source file calling this * function; used for debugging. */ - int line) /* Line number in the source file; used for + register int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1204,12 +1223,12 @@ Tcl_DbNewObj( Tcl_Obj * Tcl_DbNewObj( - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { - Tcl_Obj *objPtr; - TclNewObj(objPtr); - return objPtr; + return Tcl_NewObj(); } #endif /* TCL_MEM_DEBUG */ @@ -1241,8 +1260,8 @@ TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; - Tcl_Obj *prevPtr, *objPtr; - int i; + register Tcl_Obj *prevPtr, *objPtr; + register int i; /* * This has been noted by Purify to be a potential leak. The problem is @@ -1253,12 +1272,12 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *)ckalloc(bytesToAlloc); + basePtr = (char *) ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) prevPtr; prevPtr = objPtr; objPtr++; } @@ -1293,9 +1312,9 @@ TclAllocateFreeObjects(void) #ifdef TCL_MEM_DEBUG void TclFreeObj( - Tcl_Obj *objPtr) /* The object to be freed. */ + register Tcl_Obj *objPtr) /* The object to be freed. */ { - const Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -1303,7 +1322,7 @@ TclFreeObj( ObjInitDeletionContext(context); -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -1325,10 +1344,10 @@ TclFreeObj( * As the Tcl_Obj is going to be deleted we remove the entry. */ - ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); + ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + ckfree((char *) objData); } Tcl_DeleteHashEntry(hPtr); @@ -1343,23 +1362,21 @@ TclFreeObj( * and so on, is always a sign of a botch in the caller. */ if (objPtr->refCount < -1) { - Tcl_Panic("Reference count for %p was negative", objPtr); + Tcl_Panic("Reference count for %lx was negative", objPtr); } /* * Now, in case we just approved drop from 1 to 0 as acceptable, make * sure we do not accept a second free when falling from 0 to -1. * Skip that possibility so any double free will trigger the panic. */ - objPtr->refCount = TCL_INDEX_NONE; + objPtr->refCount = -1; - /* - * Invalidate the string rep first so we can use the bytes value for our - * pointer chain, and signal an obj deletion (as opposed to shimmering) - * with 'length == TCL_INDEX_NONE'. - */ + /* Invalidate the string rep first so we can use the bytes value + * for our pointer chain, and signal an obj deletion (as opposed + * to shimmering) with 'length == -1' */ TclInvalidateStringRep(objPtr); - objPtr->length = TCL_INDEX_NONE; + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); @@ -1372,19 +1389,19 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree(objPtr); + ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context, objToFree); + PopObjToDelete(context,objToFree); TCL_DTRACE_OBJ_FREE(objToFree); - TclFreeInternalRep(objToFree); + TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree(objToFree); + ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1393,23 +1410,22 @@ TclFreeObj( /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the finalization. - * We have to access it using the low-level call and then check for - * validity. This function can be called after TclFinalizeThreadData() has - * already killed the thread-global data structures. Performing - * TCL_TSD_INIT will leave us with an uninitialized memory block upon - * which we crash (if we where to access the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } @@ -1418,16 +1434,14 @@ TclFreeObj( void TclFreeObj( - Tcl_Obj *objPtr) /* The object to be freed. */ + register Tcl_Obj *objPtr) /* The object to be freed. */ { - /* - * Invalidate the string rep first so we can use the bytes value for our - * pointer chain, and signal an obj deletion (as opposed to shimmering) - * with 'length == -1'. - */ + /* Invalidate the string rep first so we can use the bytes value + * for our pointer chain, and signal an obj deletion (as opposed + * to shimmering) with 'length == -1' */ TclInvalidateStringRep(objPtr); - objPtr->length = TCL_INDEX_NONE; + objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* @@ -1468,8 +1482,7 @@ TclFreeObj( ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - - PopObjToDelete(context, objToFree); + PopObjToDelete(context,objToFree); TCL_DTRACE_OBJ_FREE(objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { @@ -1484,28 +1497,27 @@ TclFreeObj( /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the finalization. - * We have to access it using the low-level call and then check for - * validity. This function can be called after TclFinalizeThreadData() has - * already killed the thread-global data structures. Performing - * TCL_TSD_INIT will leave us with an uninitialized memory block upon - * which we crash (if we where to access the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } } -#endif /* TCL_MEM_DEBUG */ +#endif /* *---------------------------------------------------------------------- @@ -1529,8 +1541,9 @@ int TclObjBeingDeleted( Tcl_Obj *objPtr) { - return (objPtr->length == TCL_INDEX_NONE); + return (objPtr->length == -1); } + /* *---------------------------------------------------------------------- @@ -1561,47 +1574,30 @@ TclObjBeingDeleted( *---------------------------------------------------------------------- */ -#define SetDuplicateObj(dupPtr, objPtr) \ - { \ - const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ - const char *bytes = (objPtr)->bytes; \ - if (bytes) { \ - (void)TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \ - } else { \ - (dupPtr)->bytes = NULL; \ - } \ - if (typePtr) { \ - if (typePtr->dupIntRepProc) { \ - typePtr->dupIntRepProc((objPtr), (dupPtr)); \ - } else { \ - (dupPtr)->internalRep = (objPtr)->internalRep; \ - (dupPtr)->typePtr = typePtr; \ - } \ - } \ - } - Tcl_Obj * Tcl_DuplicateObj( - Tcl_Obj *objPtr) /* The object to duplicate. */ + register Tcl_Obj *objPtr) /* The object to duplicate. */ { - Tcl_Obj *dupPtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_Obj *dupPtr; TclNewObj(dupPtr); - SetDuplicateObj(dupPtr, objPtr); - return dupPtr; -} -void -TclSetDuplicateObj( - Tcl_Obj *dupPtr, - Tcl_Obj *objPtr) -{ - if (Tcl_IsShared(dupPtr)) { - Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); + if (objPtr->bytes == NULL) { + dupPtr->bytes = NULL; + } else if (objPtr->bytes != tclEmptyStringRep) { + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); + } + + if (typePtr != NULL) { + if (typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(objPtr, dupPtr); + } } - TclInvalidateStringRep(dupPtr); - TclFreeInternalRep(dupPtr); - SetDuplicateObj(dupPtr, objPtr); + return dupPtr; } /* @@ -1625,37 +1621,20 @@ TclSetDuplicateObj( *---------------------------------------------------------------------- */ -#undef Tcl_GetString char * Tcl_GetString( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - 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->bytes != NULL) { + return objPtr->bytes; + } - 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 (objPtr->typePtr->updateStringProc == NULL) { + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); } + (*objPtr->typePtr->updateStringProc)(objPtr); return objPtr->bytes; } @@ -1684,37 +1663,20 @@ Tcl_GetString( char * Tcl_GetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + register int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { 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); - } + (*objPtr->typePtr->updateStringProc)(objPtr); } + if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -1724,107 +1686,6 @@ 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); - } - - if (objPtr->bytes == NULL) { - /* Start with no string rep */ - if (numBytes == 0) { - TclInitEmptyStringRep(objPtr); - return objPtr->bytes; - } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); - if (objPtr->bytes) { - objPtr->length = (int) numBytes; - if (bytes) { - memcpy(objPtr->bytes, bytes, numBytes); - } - objPtr->bytes[objPtr->length] = '\0'; - } - } - } else if (objPtr->bytes == &tclEmptyString) { - /* Start with empty string rep (not allocated) */ - if (numBytes == 0) { - return objPtr->bytes; - } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); - if (objPtr->bytes) { - objPtr->length = (int) numBytes; - objPtr->bytes[objPtr->length] = '\0'; - } - } - } else { - /* Start with non-empty string rep (allocated) */ - if (numBytes == 0) { - ckfree(objPtr->bytes); - TclInitEmptyStringRep(objPtr); - return objPtr->bytes; - } else { - objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes, - numBytes + 1); - if (objPtr->bytes) { - objPtr->length = (int) numBytes; - objPtr->bytes[objPtr->length] = '\0'; - } - } - } - - return objPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string @@ -1842,122 +1703,12 @@ Tcl_InitStringRep( void Tcl_InvalidateStringRep( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } - -/* - *---------------------------------------------------------------------- - * - * 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_StoreInternalRep -- - * - * 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 internalrep 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_StoreInternalRep( - Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ - const Tcl_ObjType *typePtr, /* New type for the object */ - const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */ -{ - /* Clear out any existing internalrep ( "shimmer" ) */ - TclFreeInternalRep(objPtr); - - /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */ - if (irPtr) { - /* Copy the new internalrep into place */ - objPtr->internalRep = *irPtr; - - /* Set the type to match */ - objPtr->typePtr = typePtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FetchInternalRep -- - * - * 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_ObjInternalRep, 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_ObjInternalRep * -Tcl_FetchInternalRep( - Tcl_Obj *objPtr, /* Object to fetch from. */ - const Tcl_ObjType *typePtr) /* Requested type */ -{ - return TclFetchInternalRep(objPtr, typePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeInternalRep -- - * - * 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_FreeInternalRep( - Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ -{ - TclFreeInternalRep(objPtr); -} /* *---------------------------------------------------------------------- @@ -1966,11 +1717,11 @@ Tcl_FreeInternalRep( * * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "intValue" + * initializes it from the argument boolean value. A nonzero "boolValue" * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewLongObj. + * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: * The newly created object is returned. This object will have an invalid @@ -1987,20 +1738,20 @@ Tcl_FreeInternalRep( Tcl_Obj * Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ + register int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); + return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ + register int boolValue) /* Boolean used to initialize new object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; - TclNewIntObj(objPtr, intValue!=0); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -2031,25 +1782,23 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - const char *file, /* The name of the source file calling this + 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. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.wideValue = (intValue != 0); + objPtr->internalRep.longValue = (boolValue? 1 : 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -2058,11 +1807,13 @@ Tcl_DbNewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { - return Tcl_NewBooleanObj(intValue); + return Tcl_NewBooleanObj(boolValue); } #endif /* TCL_MEM_DEBUG */ @@ -2072,7 +1823,7 @@ Tcl_DbNewBooleanObj( * Tcl_SetBooleanObj -- * * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "intValue" is coerced to 1. + * boolean value. A nonzero "boolValue" is coerced to 1. * * Results: * None. @@ -2087,21 +1838,20 @@ Tcl_DbNewBooleanObj( #undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Boolean used to set object's value. */ + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register int boolValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetIntObj(objPtr, intValue!=0); + TclSetIntObj(objPtr, boolValue!=0); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * - * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- + * Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This * includes conversion from any of Tcl's numeric types. @@ -2112,99 +1862,62 @@ Tcl_SetBooleanObj( * result unless "interp" is NULL. * * Side effects: - * The internalrep of *objPtr may be changed. + * The intrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ -#undef Tcl_GetBoolFromObj int -Tcl_GetBoolFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int flags, - char *charPtr) /* Place to store resulting boolean. */ +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. */ { - int result; - - if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { - result = -1; - goto boolEnd; - } else if (objPtr == NULL) { - if (interp) { - TclNewObj(objPtr); - TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) - ? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0); - Tcl_DecrRefCount(objPtr); - } - return TCL_ERROR; - } do { if (objPtr->typePtr == &tclIntType) { - result = (objPtr->internalRep.wideValue != 0); - goto boolEnd; + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - result = objPtr->internalRep.longValue != 0; - goto boolEnd; + *boolPtr = (int) objPtr->internalRep.longValue; + return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" - * Tcl_ObjType and then compare the internalrep to 0.0. This isn't + * Tcl_ObjType and then compare the intrep to 0.0. This isn't * reliable because a "double" Tcl_ObjType can hold the NaN value. * Use the API Tcl_GetDoubleFromObj, which does the checking and * sets the proper error message for us. */ - double d; + double d; if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } - result = (d != 0.0); - goto boolEnd; + *boolPtr = (d != 0.0); + return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { - result = 1; - boolEnd: - if (charPtr != NULL) { - flags &= (TCL_NULL_OK-2); - if (flags) { - if (flags == (int)sizeof(int)) { - *(int *)charPtr = result; - return TCL_OK; - } else if (flags == (int)sizeof(short)) { - *(short *)charPtr = result; - return TCL_OK; - } else { - Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj"); - } - } - *charPtr = result; - } + *boolPtr = 1; + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } +#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == - TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) - ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); + TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } -#undef Tcl_GetBooleanFromObj -int -Tcl_GetBooleanFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int *intPtr) /* Place to store resulting boolean. */ -{ - return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr); -} - /* *---------------------------------------------------------------------- * - * TclSetBooleanFromAny -- + * SetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -2216,20 +1929,15 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean or int/wideInt. - * - * Warning: If the returned type is "wideInt" (32-bit platforms) and your - * platform is bigendian, you cannot use internalRep.longValue to distinguish - * between false and true. On Windows and most other platforms this still will - * work fine, but basically it is non-portable. + * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ -int -TclSetBooleanFromAny( +static int +SetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine @@ -2239,7 +1947,8 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { + switch (objPtr->internalRep.longValue) { + case 0L: case 1L: return TCL_OK; } goto badBoolean; @@ -2249,6 +1958,12 @@ TclSetBooleanFromAny( goto badBoolean; } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + goto badBoolean; + } +#endif + if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2260,33 +1975,27 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { - Tcl_Size length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + int length; + char *str = Tcl_GetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); Tcl_AppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (void *)NULL); } return TCL_ERROR; } static int ParseBoolean( - Tcl_Obj *objPtr) /* The object to parse/convert. */ + register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int newBool; - char lowerCase[6]; - Tcl_Size i, length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); - - if ((length < 1) || (length > 5)) { - /* - * Longest valid boolean string rep. is "false". - */ + int i, length, newBool; + char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length); + if ((length == 0) || (length > 5)) { + /* longest valid boolean string rep. is "false" */ return TCL_ERROR; } @@ -2312,7 +2021,6 @@ ParseBoolean( for (i=0; i < length; i++) { char c = str[i]; - switch (c) { case 'A': case 'E': case 'F': case 'L': case 'N': case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': @@ -2332,25 +2040,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", length) == 0) { + if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", length) == 0) { + if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", length) == 0) { + if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", length) == 0) { + if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } @@ -2359,10 +2067,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", length) == 0) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", length) == 0) { + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } @@ -2378,14 +2086,14 @@ ParseBoolean( */ goodBoolean: - TclFreeInternalRep(objPtr); + TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: - TclFreeInternalRep(objPtr); - objPtr->internalRep.wideValue = newBool; + TclFreeIntRep(objPtr); + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2417,7 +2125,7 @@ ParseBoolean( Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + register double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } @@ -2426,9 +2134,9 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + register double dblValue) /* Double used to initialize the object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; @@ -2465,16 +2173,15 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - double dblValue, /* Double used to initialize the object. */ - const char *file, /* The name of the source file calling this + 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. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; @@ -2486,9 +2193,11 @@ Tcl_DbNewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - double dblValue, /* Double used to initialize the object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { return Tcl_NewDoubleObj(dblValue); } @@ -2514,8 +2223,8 @@ Tcl_DbNewDoubleObj( void Tcl_SetDoubleObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - double dblValue) /* Double used to set the object's value. */ + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); @@ -2546,18 +2255,16 @@ Tcl_SetDoubleObj( int Tcl_GetDoubleFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a double. */ - double *dblPtr) /* Place to store resulting double. */ + 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. */ { do { if (objPtr->typePtr == &tclDoubleType) { - if (isnan(objPtr->internalRep.doubleValue)) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - (void *)NULL); } return TCL_ERROR; } @@ -2565,16 +2272,21 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; + *dblPtr = objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - - TclUnpackBignum(objPtr, big); - *dblPtr = TclBignumToDouble(&big); + UNPACK_BIGNUM( objPtr, big ); + *dblPtr = TclBignumToDouble( &big ); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } +#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2602,7 +2314,7 @@ Tcl_GetDoubleFromObj( static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); @@ -2631,14 +2343,17 @@ SetDoubleFromAny( static void UpdateStringOfDouble( - Tcl_Obj *objPtr) /* Double obj with string rep to update. */ + register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { - char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); + char buffer[TCL_DOUBLE_SPACE]; + register int len; - TclOOM(dst, TCL_DOUBLE_SPACE + 1); + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); + len = strlen(buffer); - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); - (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; } /* @@ -2671,30 +2386,28 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewIntObj #ifdef TCL_MEM_DEBUG +#undef Tcl_NewIntObj Tcl_Obj * Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ + register int intValue) /* Int used to initialize the new object. */ { - return Tcl_DbNewWideIntObj(intValue, "unknown", 0); + return Tcl_DbNewLongObj((long)intValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ + register int intValue) /* Int used to initialize the new object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2713,12 +2426,11 @@ Tcl_NewIntObj( * *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetIntObj + void Tcl_SetIntObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Integer used to set object's value. */ + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register int intValue) /* Integer used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); @@ -2726,7 +2438,6 @@ Tcl_SetIntObj( TclSetIntObj(objPtr, intValue); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2756,9 +2467,9 @@ Tcl_SetIntObj( int Tcl_GetIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a int. */ - int *intPtr) /* Place to store resulting int. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a int. */ + register int *intPtr) /* Place to store resulting int. */ { #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); @@ -2768,12 +2479,12 @@ Tcl_GetIntFromObj( if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - const char *s = - "integer value too large to represent"; + CONST char *s = + "integer value too large to represent as non-long integer"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } @@ -2781,7 +2492,6 @@ Tcl_GetIntFromObj( return TCL_OK; #endif } - /* *---------------------------------------------------------------------- @@ -2804,8 +2514,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + long l; + return TclGetLongFromObj(interp, objPtr, &l); } /* @@ -2829,27 +2539,17 @@ SetIntFromAny( static void UpdateStringOfInt( - Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + char buffer[TCL_INTEGER_SPACE]; + register int len; - 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); - - TclOOM(dst, TCL_INTEGER_SPACE + 1); - (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(dst, objPtr->internalRep.longValue)); + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; } -#endif /* *---------------------------------------------------------------------- @@ -2881,32 +2581,30 @@ UpdateStringOfOldInt( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewLongObj #ifdef TCL_MEM_DEBUG +#undef Tcl_NewLongObj Tcl_Obj * Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the + register long longValue) /* Long integer used to initialize the * new object. */ { - return Tcl_DbNewWideIntObj(longValue, "unknown", 0); + return Tcl_DbNewLongObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the + register long longValue) /* Long integer used to initialize the * new object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; - TclNewIntObj(objPtr, longValue); + TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2940,26 +2638,23 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new + register long longValue, /* Long integer used to initialize the new * object. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; - objPtr->internalRep.wideValue = longValue; + objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2968,15 +2663,16 @@ Tcl_DbNewLongObj( Tcl_Obj * Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new + register long longValue, /* Long integer used to initialize the new * object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { - return Tcl_NewWideIntObj(longValue); + return Tcl_NewLongObj(longValue); } #endif /* TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2996,21 +2692,18 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetLongObj void Tcl_SetLongObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - long longValue) /* Long integer used to initialize the + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register long longValue) /* Long integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetIntObj(objPtr, longValue); + TclSetLongObj(objPtr, longValue); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3035,20 +2728,19 @@ Tcl_SetLongObj( int Tcl_GetLongFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a long. */ - long *longPtr) /* Place to store resulting long. */ + 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. */ { do { -#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.wideValue; + *longPtr = objPtr->internalRep.longValue; return TCL_OK; } -#else - if (objPtr->typePtr == &tclIntType) { +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { /* - * We return any integer in the range LONG_MIN to ULONG_MAX + * We return any integer in the range -ULONG_MAX 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 @@ -3056,25 +2748,26 @@ Tcl_GetLongFromObj( */ Tcl_WideInt w = objPtr->internalRep.wideValue; - - if (w >= (Tcl_WideInt)(LONG_MIN) + if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = (long)w; + *longPtr = Tcl_WideAsLong(w); return TCL_OK; } goto tooLarge; } #endif - 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", (void *)NULL); + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed @@ -3082,31 +2775,27 @@ 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; - TclUnpackBignum(objPtr, big); - if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { + UNPACK_BIGNUM(objPtr, big); + if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) + / DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { - if (value <= 1 + (unsigned long)LONG_MAX) { - *longPtr = (long)(-value); - return TCL_OK; } - } else { - if (value <= (unsigned long)ULONG_MAX) { - *longPtr = (long)value; - return TCL_OK; + if (big.sign) { + *longPtr = - (long) value; + } else { + *longPtr = (long) value; } + return TCL_OK; } } - } -#ifndef TCL_WIDE_INT_IS_LONG +#ifndef NO_WIDE_TYPE tooLarge: #endif if (interp != NULL) { @@ -3114,7 +2803,7 @@ Tcl_GetLongFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } @@ -3122,6 +2811,49 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef NO_WIDE_TYPE + +/* + *---------------------------------------------------------------------- + * + * 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((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- @@ -3153,7 +2885,7 @@ Tcl_GetLongFromObj( Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) + register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { @@ -3164,14 +2896,14 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) + register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclNewObj(objPtr); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -3212,18 +2944,18 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, + register Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } @@ -3231,11 +2963,13 @@ Tcl_DbNewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, + register Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { return Tcl_NewWideIntObj(wideValue); } @@ -3261,8 +2995,8 @@ Tcl_DbNewWideIntObj( void Tcl_SetWideIntObj( - Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - Tcl_WideInt wideValue) + register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue) /* Wide integer used to initialize the * object's value. */ { @@ -3270,7 +3004,19 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - TclSetIntObj(objPtr, wideValue); + if ((wideValue >= (Tcl_WideInt) LONG_MIN) + && (wideValue <= (Tcl_WideInt) LONG_MAX)) { + TclSetLongObj(objPtr, (long) wideValue); + } else { +#ifndef NO_WIDE_TYPE + TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif + } } /* @@ -3296,60 +3042,67 @@ Tcl_SetWideIntObj( int Tcl_GetWideIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideInt *wideIntPtr) + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType) { +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { *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", (void *)NULL); +#endif + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. */ mp_int big; - 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); - return TCL_OK; + + UNPACK_BIGNUM(objPtr, big); + if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt) + + DIGIT_BIT - 1) / DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; } - } else { - if (value <= (Tcl_WideUInt)WIDE_MAX) { - *wideIntPtr = (Tcl_WideInt)value; - return TCL_OK; + if (big.sign) { + *wideIntPtr = - (Tcl_WideInt) value; + } else { + *wideIntPtr = (Tcl_WideInt) value; } + return TCL_OK; } } if (interp != NULL) { const char *s = "integer value too large to represent"; - Tcl_Obj *msg = Tcl_NewStringObj(s, -1); + Tcl_Obj* msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } @@ -3357,160 +3110,33 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef NO_WIDE_TYPE /* *---------------------------------------------------------------------- * - * Tcl_GetWideUIntFromObj -- + * SetWideIntFromAny -- * - * Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the - * object is not already a wide int object or a bignum object, an attempt will - * be made to convert it to one. - * - * Results: - * 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 object, the conversion will free - * any old internal representation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetWideUIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideUInt *wideUIntPtr) - /* Place to store resulting long. */ -{ - do { - if (objPtr->typePtr == &tclIntType) { - if (objPtr->internalRep.wideValue < 0) { - wideUIntOutOfRange: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected unsigned integer but got \"%s\"", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); - } - return TCL_ERROR; - } - *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclDoubleType) { - goto wideUIntOutOfRange; - } - if (objPtr->typePtr == &tclBignumType) { - /* - * Must check for those bignum values that can fit in a - * Tcl_WideUInt, even when auto-narrowing is enabled. - */ - - mp_int big; - Tcl_WideUInt value = 0; - size_t numBytes; - Tcl_WideUInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - TclUnpackBignum(objPtr, big); - if (big.sign == MP_NEG) { - goto wideUIntOutOfRange; - } - if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - *wideUIntPtr = (Tcl_WideUInt)value; - return TCL_OK; - } - - if (interp != NULL) { - const char *s = "integer value too large to represent"; - Tcl_Obj *msg = Tcl_NewStringObj(s, -1); - - Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); - } - return TCL_ERROR; - } - } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, - TCL_PARSE_INTEGER_ONLY)==TCL_OK); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetWideBitsFromObj -- - * - * 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. + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. * * Results: - * The return value is a standard Tcl object result. If an error occurs + * The return value is a standard object Tcl result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * - * Side effects: - * If the object is not already an int, double or bignum object, the - * conversion will free any old internal representation. - * *---------------------------------------------------------------------- */ -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. */ +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - 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", (void *)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; + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- @@ -3531,12 +3157,11 @@ FreeBignum( { mp_int toFree; /* Bignum to free */ - TclUnpackBignum(objPtr, toFree); + UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); - if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); } - objPtr->typePtr = NULL; } /* @@ -3550,7 +3175,7 @@ FreeBignum( * None. * * Side effects: - * The destination object receives a copy of the source object + * The destination object receies a copy of the source object * *---------------------------------------------------------------------- */ @@ -3564,7 +3189,7 @@ DupBignum( mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - TclUnpackBignum(srcPtr, bignumVal); + UNPACK_BIGNUM(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } @@ -3597,17 +3222,21 @@ UpdateStringOfBignum( { mp_int bignumVal; int size; - char *stringVal; + int status; + char* stringVal; - TclUnpackBignum(objPtr, bignumVal); - if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } - if (size < 2) { + if (size == 3) { /* - * mp_radix_size() returns < 2 when more than INT_MAX bytes would be + * mp_radix_size() returns 3 when more than INT_MAX bytes would be * needed to hold the string rep (because mp_radix_size ignores - * integer overflow issues). + * integer overflow issues). When we know the string rep will be more + * than 3, we can conclude the string rep would overflow our string + * length limits. * * Note that so long as we enforce our bignums to the size that fits * in a packed bignum, this branch will never be taken. @@ -3615,13 +3244,13 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - - stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); - - TclOOM(stringVal, size); - if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) { + stringVal = ckalloc((size_t) size); + status = mp_toradix_n(&bignumVal, stringVal, 10, size); + if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } + objPtr->bytes = stringVal; + objPtr->length = size - 1; /* size includes a trailing null byte */ } /* @@ -3629,7 +3258,7 @@ UpdateStringOfBignum( * * Tcl_NewBignumObj -- * - * Creates and initializes a bignum object. + * Creates an initializes a bignum object. * * Results: * Returns the newly created object. @@ -3645,16 +3274,16 @@ UpdateStringOfBignum( Tcl_Obj * Tcl_NewBignumObj( - void *bignumValue) + mp_int *bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * Tcl_NewBignumObj( - void *bignumValue) + mp_int *bignumValue) { - Tcl_Obj *objPtr; + Tcl_Obj* objPtr; TclNewObj(objPtr); Tcl_SetBignumObj(objPtr, bignumValue); @@ -3683,8 +3312,8 @@ Tcl_NewBignumObj( #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBignumObj( - void *bignumValue, - const char *file, + mp_int *bignumValue, + CONST char *file, int line) { Tcl_Obj *objPtr; @@ -3696,9 +3325,9 @@ Tcl_DbNewBignumObj( #else Tcl_Obj * Tcl_DbNewBignumObj( - void *bignumValue, - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + mp_int *bignumValue, + CONST char *file, + int line) { return Tcl_NewBignumObj(bignumValue); } @@ -3736,41 +3365,38 @@ GetBignumFromObj( if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - - TclUnpackBignum(objPtr, temp); - if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { - return TCL_ERROR; - } + UNPACK_BIGNUM(objPtr, temp); + mp_init_copy(bignumValue, &temp); } else { - TclUnpackBignum(objPtr, *bignumValue); - /* Optimized TclFreeInternalRep */ - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; + UNPACK_BIGNUM(objPtr, *bignumValue); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = 0; 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) { - TclInitEmptyStringRep(objPtr); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - if (mp_init_i64(bignumValue, - objPtr->internalRep.wideValue) != MP_OKAY) { - return TCL_ERROR; - } + TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); return TCL_OK; } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + TclBNInitBignumFromWideInt(bignumValue, + objPtr->internalRep.wideValue); + return TCL_OK; + } +#endif 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", (void *)NULL); + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } @@ -3808,9 +3434,9 @@ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + mp_int *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); + return GetBignumFromObj(interp, objPtr, 1, bignumValue); } /* @@ -3826,7 +3452,7 @@ Tcl_GetBignumFromObj( * * Side effects: * A copy of bignum is stored in *bignumValue, which is expected to be - * uninitialized or cleared. If conversion fails and the 'interp' + * uninitialized or cleared. If conversion fails, an the 'interp' * argument is not NULL, an error message is stored in the interpreter * result. * @@ -3843,9 +3469,9 @@ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + mp_int *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); + return GetBignumFromObj(interp, objPtr, 0, bignumValue); } /* @@ -3868,71 +3494,77 @@ Tcl_TakeBignumFromObj( void Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ - void *big) /* Value to store */ + mp_int *bignumValue) /* 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 (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { - goto tooLargeForWide; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { - goto tooLargeForWide; + 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; } - if (bignumValue->sign) { - TclSetIntObj(objPtr, (Tcl_WideInt)(-value)); - } else { - TclSetIntObj(objPtr, (Tcl_WideInt)value); + tooLargeForLong: +#ifndef NO_WIDE_TYPE + if ((size_t)(bignumValue->used) + <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForWide; + } + 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; } - mp_clear(bignumValue); - return; tooLargeForWide: +#endif TclInvalidateStringRep(objPtr); - TclFreeInternalRep(objPtr); - TclSetBignumInternalRep(objPtr, bignumValue); + TclFreeIntRep(objPtr); + TclSetBignumIntRep(objPtr, bignumValue); } -/* - *---------------------------------------------------------------------- - * - * TclSetBignumInternalRep -- - * - * Install a bignum into the internal representation of an object. - * - * Results: - * None. - * - * Side effects: - * Object internal representation is updated and object type is set. The - * bignum value is cleared, since ownership has transferred to the - * object. - * - *---------------------------------------------------------------------- - */ - void -TclSetBignumInternalRep( +TclSetBignumIntRep( Tcl_Obj *objPtr, - void *big) + mp_int *bignumValue) { - mp_int *bignumValue = (mp_int *)big; objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); /* * Clear the mp_int value. - * - * Don't call mp_clear() because it would free the digit array we just - * packed into the Tcl_Obj. + * Don't call mp_clear() because it would free the digit array + * we just packed into the Tcl_Obj. */ bignumValue->dp = NULL; @@ -3943,51 +3575,48 @@ TclSetBignumInternalRep( /* *---------------------------------------------------------------------- * - * Tcl_GetNumberFromObj -- - * - * Extracts a number (of any possible numeric type) from an object. + * TclGetNumberFromObj -- * * Results: - * Whether the extraction worked. The type is stored in the variable - * referred to by the typePtr argument, and a pointer to the - * representation is stored in the variable referred to by the - * clientDataPtr. * * Side effects: - * Can allocate thread-specific data for handling the copy-out space for - * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ -int -Tcl_GetNumberFromObj( +int TclGetNumberFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, - void **clientDataPtr, + ClientData *clientDataPtr, int *typePtr) { do { if (objPtr->typePtr == &tclDoubleType) { - if (isnan(objPtr->internalRep.doubleValue)) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { *typePtr = TCL_NUMBER_DOUBLE; } - *clientDataPtr = &objPtr->internalRep.doubleValue; + *clientDataPtr = &(objPtr->internalRep.doubleValue); return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_INT; - *clientDataPtr = &objPtr->internalRep.wideValue; + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &(objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; + *clientDataPtr = &(objPtr->internalRep.wideValue); return TCL_OK; } +#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, - sizeof(mp_int)); - - TclUnpackBignum(objPtr, *bigPtr); + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, + (int) sizeof(mp_int)); + UNPACK_BIGNUM( objPtr, *bigPtr ); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; @@ -3996,99 +3625,6 @@ Tcl_GetNumberFromObj( TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } - -int -Tcl_GetNumber( - Tcl_Interp *interp, - const char *bytes, - Tcl_Size numBytes, - void **clientDataPtr, - int *typePtr) -{ - static Tcl_ThreadDataKey numberCacheKey; - Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey, - sizeof(Tcl_Obj)); - - Tcl_FreeInternalRep(objPtr); - - if (bytes == NULL) { - bytes = &tclEmptyString; - numBytes = 0; - } - if (numBytes < 0) { - numBytes = (int)strlen(bytes); - } - - objPtr->bytes = (char *) bytes; - objPtr->length = numBytes; - - return Tcl_GetNumberFromObj(interp, objPtr, clientDataPtr, typePtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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: - * The storage for objPtr may be freed. - * - *---------------------------------------------------------------------- - */ - -#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); -} /* *---------------------------------------------------------------------- @@ -4111,23 +3647,23 @@ Tcl_IsShared( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( - Tcl_Obj *objPtr, /* The object we are registering a reference + register Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { +#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"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -4135,33 +3671,25 @@ Tcl_DbIncrRefCount( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "incr ref count"); + Tcl_Panic("%s%s", + "Trying to incr ref count of " + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ - ++(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*/) -{ +# endif +#endif ++(objPtr)->refCount; } -#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -4184,23 +3712,23 @@ Tcl_DbIncrRefCount( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( - Tcl_Obj *objPtr, /* The object we are releasing a reference + register Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { +#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"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -4208,38 +3736,27 @@ Tcl_DbDecrRefCount( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "decr ref count"); + Tcl_Panic("%s%s", + "Trying to decr ref count of " + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ - - 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) { +# endif +#endif + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } } -#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -4264,16 +3781,11 @@ Tcl_DbDecrRefCount( int Tcl_DbIsShared( - 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 + register Tcl_Obj *objPtr, /* The object to test for being shared. */ + 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) { @@ -4282,7 +3794,7 @@ Tcl_DbIsShared( Tcl_Panic("checking whether previously disposed object is shared"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -4290,21 +3802,22 @@ Tcl_DbIsShared( */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "check shared status"); + Tcl_Panic("%s%s", + "Trying to check shared status of" + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ +# endif +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -4316,7 +3829,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ +#endif return ((objPtr)->refCount > 1); } @@ -4341,7 +3854,7 @@ Tcl_DbIsShared( void Tcl_InitObjHashTable( - Tcl_HashTable *tablePtr) + register Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { @@ -4367,13 +3880,14 @@ Tcl_InitObjHashTable( static Tcl_HashEntry * AllocObjEntry( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; - hPtr->key.objPtr = objPtr; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); + hPtr->key.oneWordValue = (char *) objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; @@ -4402,17 +3916,18 @@ TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; - Tcl_Obj *objPtr2 = (Tcl_Obj *)hPtr->key.oneWordValue; - const char *p1, *p2; - size_t l1, l2; + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; + register CONST char *p1, *p2; + register int l1, l2; /* * If the object pointers are the same then they match. - * OPT: this comparison was moved to the caller + */ - if (objPtr1 == objPtr2) return 1; - */ + if (objPtr1 == objPtr2) { + return 1; + } /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being @@ -4465,7 +3980,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree(hPtr); + ckfree((char *) hPtr); } /* @@ -4486,15 +4001,16 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +unsigned int TclHashObjKey( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_Size length; - const char *string = Tcl_GetStringFromObj(objPtr, &length); - TCL_HASH_TYPE result = 0; + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + CONST char *string = TclGetString(objPtr); + int length = objPtr->length; + unsigned int result = 0; + int i; /* * I tried a zillion different hash functions and asked many other people @@ -4504,37 +4020,16 @@ TclHashObjKey( * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and non-decimal strings. - * - * Note that this function is very weak against malicious strings; it's - * very easy to generate multiple keys that have the same hashcode. On the - * other hand, that hardly ever actually occurs and this function *is* - * very cheap, even by comparison with industry-standard hashes like FNV. - * If real strength of hash is required though, use a custom hash based on - * Bob Jenkins's lookup3(), but be aware that it's significantly slower. - * Tcl does not use that level of strength because it typically does not - * need it (and some of the aspects of that strength are genuinely - * unnecessary given the rest of Tcl's hash machinery, and the fact that - * we do not either transfer hashes to another machine, use them as a true - * substitute for equality, or attempt to minimize work in rebuilding the - * hash table). - * - * See also HashStringKey in tclHash.c. - * See also HashString in tclLiteral.c. - * - * See [tcl-Feature Request #2958832] + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and *non-decimal strings. */ - if (length > 0) { - result = UCHAR(*string); - while (--length) { - result += (result << 3) + UCHAR(*++string); - } + for (i=0 ; i<length ; i++) { + result += (result << 3) + string[i]; } return result; } @@ -4562,13 +4057,16 @@ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ - Tcl_Obj *objPtr) /* The object containing the command's name. + register 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. */ { - ResolvedCmdName *resPtr; + register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *refNsPtr; + int result; /* * Get the internal representation, converting to a command type if @@ -4589,36 +4087,31 @@ Tcl_GetCommandFromObj( * to discard the old rep and create a new one. */ - resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->typePtr == &tclCmdNameType) { - Command *cmdPtr = resPtr->cmdPtr; - - if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) - && (interp == cmdPtr->nsPtr->interp) - && !(cmdPtr->nsPtr->flags & NS_DYING)) { - Namespace *refNsPtr = (Namespace *) - TclGetCurrentNamespace(interp); - - if ((resPtr->refNsPtr == NULL) - || ((refNsPtr == resPtr->refNsPtr) - && (resPtr->refNsId == refNsPtr->nsId) - && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { - return (Tcl_Command) cmdPtr; - } - } + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr != &tclCmdNameType) + || (resPtr == NULL) + || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) + || (cmdPtr->flags & CMD_IS_DELETED) + || (interp != cmdPtr->nsPtr->interp) + || (cmdPtr->nsPtr->flags & NS_DYING) + || ((resPtr->refNsPtr != NULL) && + (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp)) + != resPtr->refNsPtr) + || (resPtr->refNsId != refNsPtr->nsId) + || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch))) + ) { + + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((result == TCL_OK) && resPtr) { + cmdPtr = resPtr->cmdPtr; + } else { + cmdPtr = NULL; + } } - /* - * OK, must create a new internal representation (or fail) as any cache we - * had is invalid one way or another. - */ - - /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ - if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { - return NULL; - } - resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); + return (Tcl_Command) cmdPtr; } /* @@ -4633,86 +4126,62 @@ Tcl_GetCommandFromObj( * None. * * Side effects: - * The object's old internal rep is freed. Its string rep is not + * The object's old internal rep is freed. It's string rep is not * changed. The refcount in the Command structure is incremented to keep * it from being freed if the command is later deleted until - * TclNRExecuteByteCode has a chance to recognize that it was deleted. + * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ -static void -SetCmdNameObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Command *cmdPtr, - ResolvedCmdName *resPtr) +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. */ { Interp *iPtr = (Interp *) interp; - ResolvedCmdName *fillPtr; - const char *name = TclGetString(objPtr); + register ResolvedCmdName *resPtr; + register Namespace *currNsPtr; + char *name; - if (resPtr) { - fillPtr = resPtr; - } else { - fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); - fillPtr->refCount = 1; + if (objPtr->typePtr == &tclCmdNameType) { + return; } - fillPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; - fillPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; - /* NOTE: relying on NULL termination here. */ - if ((name[0] == ':') && (name[1] == ':')) { + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { /* - * Fully qualified names always resolve to same thing. No need - * to record resolution context information. + * The name is fully qualified: set the referring namespace to + * NULL. */ - fillPtr->refNsPtr = NULL; - fillPtr->refNsId = 0; /* Will not be read */ - fillPtr->refNsCmdEpoch = 0; /* Will not be read */ + resPtr->refNsPtr = NULL; } else { /* - * Record current state of current namespace as the resolution - * context of this command name lookup. + * Get the current namespace. */ - Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; - - fillPtr->refNsPtr = currNsPtr; - fillPtr->refNsId = currNsPtr->nsId; - fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - } - - if (resPtr == NULL) { - TclFreeInternalRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; - 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; + currNsPtr = iPtr->varFramePtr->nsPtr; - if (objPtr->typePtr == &tclCmdNameType) { - resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { - return; - } + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; } - SetCmdNameObj(interp, objPtr, cmdPtr, NULL); + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* @@ -4738,17 +4207,20 @@ TclSetCmdNameObj( static void FreeCmdNameInternalRep( - Tcl_Obj *objPtr) /* CmdName object with internal + register Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; + register 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) { + resPtr->refCount--; + if (resPtr->refCount == 0) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName @@ -4756,10 +4228,10 @@ FreeCmdNameInternalRep( */ Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommandMacro(cmdPtr); - ckfree(resPtr); + ckfree((char *) resPtr); } + } objPtr->typePtr = NULL; } @@ -4786,13 +4258,16 @@ FreeCmdNameInternalRep( static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { resPtr->refCount++; + } copyPtr->typePtr = &tclCmdNameType; } @@ -4820,11 +4295,13 @@ DupCmdNameInternalRep( static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - const char *name; - Command *cmdPtr; - ResolvedCmdName *resPtr; + Interp *iPtr = (Interp *) interp; + char *name; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; @@ -4839,100 +4316,61 @@ SetCmdNameFromAny( */ name = TclGetString(objPtr); - cmdPtr = (Command *) - Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); + cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Stop shimmering and caching nothing when we found nothing. Just - * report the failure to find the command as an error. + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. */ - if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) { - return TCL_ERROR; - } - - 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. - */ - - Command *oldCmdPtr = resPtr->cmdPtr; + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ - if (oldCmdPtr->refCount-- <= 1) { - TclCleanupCommandMacro(oldCmdPtr); + Command *oldCmdPtr = resPtr->cmdPtr; + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } + } else { + TclFreeIntRep(objPtr); + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } - } else { - resPtr = NULL; - } - - SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RepresentationCmd -- - * - * Implementation of the "tcl::unsupported::representation" command. - * - * Results: - * Reports the current representation (Tcl_Obj type) of its argument. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RepresentationCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *descObj; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value"); - return TCL_ERROR; - } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - /* - * Value is a bignum with a refcount of 14, object pointer at 0x12345678, - * internal representation 0x45671234:0x98765432, string representation - * "1872361827361287" - */ + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ - descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d," - " object pointer at %p", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - objv[1]->refCount, objv[1]); + currNsPtr = iPtr->varFramePtr->nsPtr; - if (objv[1]->typePtr) { - 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); + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; } - } - - if (objv[1]->bytes) { - Tcl_AppendToObj(descObj, ", string representation \"", -1); - Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, - 16, "..."); - Tcl_AppendToObj(descObj, "\"", -1); } else { - Tcl_AppendToObj(descObj, ", no string representation", -1); + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } - - Tcl_SetObjResult(interp, descObj); return TCL_OK; } @@ -4941,7 +4379,5 @@ Tcl_RepresentationCmd( * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ |