diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 3928 |
1 files changed, 2309 insertions, 1619 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index 7b9bb61..96a4082 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1,28 +1,30 @@ -/* +/* * tclObj.c -- * - * This file contains Tcl object-related procedures that are used by - * many Tcl commands. + * This file contains Tcl object-related functions that are used by many + * Tcl commands. * * 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. + * 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 "tclCompile.h" -#include "tclPort.h" +#include "tommath.h" +#include <float.h> +#include <math.h> /* * Table of all object types. */ static Tcl_HashTable typeTable; -static int typeTableInitialized = 0; /* 0 means not yet initialized. */ +static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* @@ -32,259 +34,379 @@ TCL_DECLARE_MUTEX(tableMutex) Tcl_Obj *tclFreeObjList = NULL; /* - * The object allocator is single threaded. This mutex is referenced - * by the TclNewObj macro, however, so must be visible. + * The object allocator is single threaded. This mutex is referenced by the + * TclNewObj macro, however, so must be visible. */ #ifdef TCL_THREADS +MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif /* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. + * Pointer to a heap-allocated string of length zero that the Tcl core uses as + * the value of an empty string representation for an object. This value is + * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; + +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +/* + * Structure for tracking the source file and line number where a given Tcl_Obj + * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity + * checking purposes. + */ +typedef struct ObjData { + Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ + 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. */ +} ObjData; +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ -#ifdef TCL_TIP280 /* - * All static variables used in this file are collected into a single - * instance of the following structure. For multi-threaded implementations, - * there is one instance of this structure for each thread. + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. * - * Notice that different structures with the same name appear in other - * files. The structure defined below is used in this file only. + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { - Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj generated - * by a call to the function EvalTokensStandard() - * 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. - */ + 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 ContLineLocFree _ANSI_ARGS_((char* clientData)); -static void TclThreadFinalizeObjects _ANSI_ARGS_((ClientData clientData)); -static ThreadSpecificData* TclGetContinuationTable _ANSI_ARGS_(()); +static void ContLineLocFree (char* clientData); +static void TclThreadFinalizeContLines (ClientData clientData); +static ThreadSpecificData* TclGetContLineTable (void); + +/* + * Nested Tcl_Obj deletion management support + * + * All context references used in the object freeing code are pointers to this + * structure; every thread will have its own structure instance. The purpose + * of this structure is to allow deeply nested collections of Tcl_Objs to be + * freed without taking a vast depth of C stack (which could cause all sorts + * of breakage.) + */ + +typedef struct PendingObjData { + 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 + * 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 + * behaviour by altering the order in which + * objects are deleted, and we change the + * order in which the string rep and the + * internal rep of an object are deleted. Note + * that code which assumes the previous + * behaviour in either of these respects is + * unsafe anyway; it was never documented as + * to exactly what would happen in these + * cases, and the overall contract of a + * user-level Tcl_DecrRefCount() is still + * preserved (assuming that a particular T_DRC + * would delete an object is not very + * safe). */ +} PendingObjData; + +/* + * These are separated out so that some semantic content is attached + * to them. + */ +#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) +#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) +#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) +#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) +#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); \ + (contextPtr)->deletionStack = (objPtr) +#define PopObjToDelete(contextPtr,objPtrVar) \ + (objPtrVar) = (contextPtr)->deletionStack; \ + (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes + +/* + * Macro to set up the local reference to the deletion context. + */ +#ifndef TCL_THREADS +static PendingObjData pendingObjData; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *CONST contextPtr = &pendingObjData +#else +static Tcl_ThreadDataKey pendingObjDataKey; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *CONST contextPtr = (PendingObjData *) \ + Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* - * Prototypes for procedures defined later in this file: + * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ -static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); +#define PACK_BIGNUM(bignum, objPtr) \ + 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; \ + } -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +/* + * Prototypes for functions defined later in this file: + */ + +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); +#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); +static void UpdateStringOfBignum(Tcl_Obj *objPtr); +static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int copy, mp_int *bignumValue); /* * Prototypes for the array hash key methods. */ -static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, VOID *keyPtr)); -static int CompareObjKeys _ANSI_ARGS_(( - VOID *keyPtr, Tcl_HashEntry *hPtr)); -static void FreeObjEntry _ANSI_ARGS_(( - Tcl_HashEntry *hPtr)); -static unsigned int HashObjKey _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, - VOID *keyPtr)); +static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the CommandName object type. */ -static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static void FreeCmdNameInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); -static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); - +static void DupCmdNameInternalRep(Tcl_Obj *objPtr, + Tcl_Obj *copyPtr); +static void FreeCmdNameInternalRep(Tcl_Obj *objPtr); +static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * The structures below defines the Tcl object types defined in this file by - * means of procedures that can be invoked by generic object code. See also + * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ -Tcl_ObjType tclBooleanType = { +static Tcl_ObjType oldBooleanType = { "boolean", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfBoolean, /* updateStringProc */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; +Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ SetBooleanFromAny /* setFromAnyProc */ }; - Tcl_ObjType tclDoubleType = { "double", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; - Tcl_ObjType tclIntType = { "int", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; - +#ifndef NO_WIDE_TYPE Tcl_ObjType tclWideIntType = { "wideInt", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ -#ifdef TCL_WIDE_INT_IS_LONG - UpdateStringOfInt, /* updateStringProc */ -#else /* !TCL_WIDE_INT_IS_LONG */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ UpdateStringOfWideInt, /* updateStringProc */ -#endif SetWideIntFromAny /* setFromAnyProc */ }; +#endif +Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* * The structure below defines the Tcl obj hash key type. */ + Tcl_HashKeyType tclObjHashKeyType = { - TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ - HashObjKey, /* hashKeyProc */ - CompareObjKeys, /* compareKeysProc */ - AllocObjEntry, /* allocEntryProc */ - FreeObjEntry /* freeEntryProc */ + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + TclHashObjKey, /* hashKeyProc */ + TclCompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + TclFreeObjEntry /* freeEntryProc */ }; /* * The structure below defines the command name Tcl object type by means of - * procedures that can be invoked by generic object code. Objects of this - * type cache the Command pointer that results from looking up command names - * in the command hashtable. Such objects appear as the zeroth ("command - * name") argument in a Tcl command. + * functions that can be invoked by generic object code. Objects of this type + * cache the Command pointer that results from looking up command names in the + * command hashtable. Such objects appear as the zeroth ("command name") + * argument in a Tcl command. * * NOTE: the ResolvedCmdName that gets cached is stored in the - * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. - * You might think you could use the simpler otherValuePtr field to - * store the single 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. + * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might + * think you could use the simpler otherValuePtr field to store the single + * 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. */ static Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + NULL, /* updateStringProc */ SetCmdNameFromAny /* setFromAnyProc */ }; - /* - * Structure containing a cached pointer to a command that is the result - * of resolving the command's name in some namespace. It is the internal - * representation for a cmdName object. It contains the pointer along - * with some information that is used to check the pointer's validity. + * Structure containing a cached pointer to a command that is the result of + * resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along with + * some information that is used to check the pointer's validity. */ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced command). */ + * reference (not the namespace that contains + * the referenced command). NULL if the name + * is fully qualified.*/ long refNsId; /* refNsPtr's unique namespace id. Used to - * 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). */ + * verify that refNsPtr is still valid (e.g., + * it's possible that the cmd's containing + * namespace was deleted and a new one created + * at the same address). */ int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ int cmdEpoch; /* Value of the command's cmdEpoch when this - * pointer was cached. Before using the - * cached pointer, we check if the cmd's - * epoch was incremented; if so, the cmd was - * renamed, deleted, hidden, or exposed, and - * so the pointer is invalid. */ - int refCount; /* Reference count: 1 for each cmdName - * object that has a pointer to this - * ResolvedCmdName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ + * pointer was cached. Before using the cached + * pointer, we check if the cmd's epoch was + * incremented; if so, the cmd was renamed, + * deleted, hidden, or exposed, and so the + * pointer is invalid. */ + int refCount; /* Reference count: 1 for each cmdName object + * that has a pointer to this ResolvedCmdName + * structure as its internal rep. This + * structure can be freed when refCount + * becomes zero. */ } ResolvedCmdName; - /* *------------------------------------------------------------------------- * * TclInitObjectSubsystem -- * - * This procedure is invoked to perform once-only initialization of - * the type table. It also registers the object types defined in - * this file. + * This function is invoked to perform once-only initialization of the + * type table. It also registers the object types defined in this file. * * Results: * None. * * Side effects: - * Initializes the table of defined object types "typeTable" with - * builtin object types defined in this file. + * Initializes the table of defined object types "typeTable" with builtin + * object types defined in this file. * *------------------------------------------------------------------------- */ void -TclInitObjSubsystem() +TclInitObjSubsystem(void) { Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclBooleanType); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclWideIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); + Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclProcBodyType); Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclIndexType); - Tcl_RegisterObjType(&tclNsNameType); Tcl_RegisterObjType(&tclCmdNameType); + Tcl_RegisterObjType(&tclRegexpType); + Tcl_RegisterObjType(&tclProcBodyType); + + /* For backward compatibility only ... */ + Tcl_RegisterObjType(&oldBooleanType); +#ifndef NO_WIDE_TYPE + Tcl_RegisterObjType(&tclWideIntType); +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -292,7 +414,7 @@ TclInitObjSubsystem() tclObjsFreed = 0; { int i; - for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) { + for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } } @@ -303,10 +425,53 @@ TclInitObjSubsystem() /* *---------------------------------------------------------------------- * + * TclFinalizeThreadObjects -- + * + * This function is called by Tcl_FinalizeThread to clean up thread + * specific Tcl_Obj information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadObjects(void) +{ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + + if (tablePtr != NULL) { + for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree((char *) objData); + } + } + + Tcl_DeleteHashTable(tablePtr); + ckfree((char *) tablePtr); + tsdPtr->objThreadMap = NULL; + } +#endif +} + +/* + *---------------------------------------------------------------------- + * * TclFinalizeObjects -- * - * This procedure is called by Tcl_Finalize to clean up all - * registered Tcl_ObjType's and to reset the tclFreeObjList. + * This function is called by Tcl_Finalize to clean up all registered + * Tcl_ObjType's and to reset the tclFreeObjList. * * Results: * None. @@ -318,37 +483,36 @@ TclInitObjSubsystem() */ void -TclFinalizeObjects() +TclFinalizeObjects(void) { Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { - Tcl_DeleteHashTable(&typeTable); - typeTableInitialized = 0; + Tcl_DeleteHashTable(&typeTable); + typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); - /* - * All we do here is reset the head pointer of the linked list of - * free Tcl_Obj's to NULL; the memory finalization will take care - * of releasing memory for us. + /* + * All we do here is reset the head pointer of the linked list of free + * Tcl_Obj's to NULL; the memory finalization will take care of releasing + * memory for us. */ Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; Tcl_MutexUnlock(&tclObjMutex); } -#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * - * TclGetContinuationTable -- + * TclGetContLineTable -- * * This procedure is a helper which returns the thread-specific * hash-table used to track continuation line information associated with - * Tcl_Obj*. + * Tcl_Obj*, and the objThreadMap, etc. * * Results: - * A reference to the continuation line thread-data. + * A reference to the thread-data. * * Side effects: * May allocate memory for the thread-data. @@ -358,7 +522,7 @@ TclFinalizeObjects() */ static ThreadSpecificData* -TclGetContinuationTable() +TclGetContLineTable() { /* * Initialize the hashtable tracking invisible continuation lines. For @@ -372,7 +536,7 @@ TclGetContinuationTable() if (!tsdPtr->lineCLPtr) { tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); - Tcl_CreateThreadExitHandler (TclThreadFinalizeObjects,NULL); + Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); } return tsdPtr; } @@ -396,36 +560,49 @@ TclGetContinuationTable() */ ContLineLoc* -TclContinuationsEnter(objPtr,num,loc) - Tcl_Obj* objPtr; - int num; - int* loc; +TclContinuationsEnter(Tcl_Obj* objPtr, + int num, + int* loc) { - int newEntry; - ThreadSpecificData *tsdPtr = TclGetContinuationTable(); - Tcl_HashEntry* hPtr = - Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); + int newEntry; + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); - ContLineLoc* clLocPtr = - (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc* clLocPtr = + (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); if (!newEntry) { /* - * Somehow we're entering ContLineLoc data for the same value (objPtr) - * more than one time. Not sure whether that's expected, or a sign of - * trouble, but at a minimum, we should take care not to leak the old - * entry. + * We're entering ContLineLoc data for the same value more than one + * time. Taking care not to leak the old entry. + * + * This can happen when literals in a proc body are shared. See for + * example test info-30.19 where the action (code) for all branches of + * 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 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 and data would rebase them a second + * time, or more, hosing the data. It is easier to simply replace, as + * we are doing. */ ckfree((char *) Tcl_GetHashValue(hPtr)); } - clLocPtr->num = num; - memcpy (&clLocPtr->loc, loc, num*sizeof(int)); - clLocPtr->loc[num] = CLL_END; /* Sentinel */ - Tcl_SetHashValue (hPtr, clLocPtr); + clLocPtr->num = num; + memcpy (&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue (hPtr, clLocPtr); - return clLocPtr; + return clLocPtr; } /* @@ -448,19 +625,16 @@ TclContinuationsEnter(objPtr,num,loc) */ void -TclContinuationsEnterDerived(objPtr, start, clNext) - Tcl_Obj* objPtr; - int start; - int* clNext; +TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) { /* * We have to handle invisible continuations lines here as well, despite - * the code we have in EvalTokensStandard (ETS) for that. Why ? - * Nesting. If our script is the sole argument to an 'eval' command, for - * example, the scriptCLLocPtr we are using here was generated by a - * previous call to ETS, and while the words we have here may contain - * continuation lines they are invisible already, and the call to ETS - * above had no bs+nl sequences to trigger its code. + * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If + * our script is the sole argument to an 'eval' command, for example, the + * scriptCLLocPtr we are using was generated by a previous call to TST, + * and while the words we have here may contain continuation lines they + * are invisible already, and the inner call to TST had no bs+nl sequences + * to trigger its code. * * Luckily for us, the table we have to create here for the current word * has to be a slice of the table currently in use, with the locations @@ -501,7 +675,7 @@ TclContinuationsEnterDerived(objPtr, start, clNext) num = wordCLLast - clNext; if (num) { int i; - ContLineLoc* clLocPtr = + ContLineLoc* clLocPtr = TclContinuationsEnter(objPtr, num, clNext); /* @@ -547,7 +721,7 @@ TclContinuationsEnterDerived(objPtr, start, clNext) void TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) { - ThreadSpecificData *tsdPtr = TclGetContinuationTable(); + ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); if (hPtr) { @@ -577,10 +751,9 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) */ ContLineLoc* -TclContinuationsGet(objPtr) - Tcl_Obj* objPtr; +TclContinuationsGet(Tcl_Obj* objPtr) { - ThreadSpecificData *tsdPtr = TclGetContinuationTable(); + ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); if (hPtr) { @@ -593,7 +766,7 @@ TclContinuationsGet(objPtr) /* *---------------------------------------------------------------------- * - * TclThreadFinalizeObjects -- + * TclThreadFinalizeContLines -- * * This procedure is a helper which releases all continuation line * information currently known. It is run as a thread exit handler. @@ -609,31 +782,30 @@ TclContinuationsGet(objPtr) */ static void -TclThreadFinalizeObjects (clientData) - ClientData clientData; +TclThreadFinalizeContLines (ClientData clientData) { /* * Release the hashtable tracking invisible continuation lines. */ + ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; - ThreadSpecificData *tsdPtr = TclGetContinuationTable(); for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { /* - * We are not using Tcl_EventuallyFree (as in - * TclFreeObj()) because here we can be sure that the - * compiler will not hold references to the data in the - * hashtable, and using TEF might bork the finalization - * sequence. + * 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((char *) tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -655,41 +827,41 @@ TclThreadFinalizeObjects (clientData) */ static void -ContLineLocFree (clientData) - char* clientData; +ContLineLocFree (char* clientData) { - ckfree (clientData); + ckfree (clientData); } -#endif + /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * - * This procedure is called to register a new Tcl object type - * in the table of all object types supported by Tcl. + * This function is called to register a new Tcl object type in the table + * of all object types supported by Tcl. * * Results: * None. * * Side effects: - * The type is registered in the Tcl type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. + * The type is registered in the Tcl type table. If there was already a + * type with the same name as in typePtr, it is replaced with the new + * type. * *-------------------------------------------------------------- */ void -Tcl_RegisterObjType(typePtr) - Tcl_ObjType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ +Tcl_RegisterObjType( + Tcl_ObjType *typePtr) /* Information about object type; storage must + * be statically allocated (must live + * forever). */ { - int new; + int isNew; + Tcl_MutexLock(&tableMutex); Tcl_SetHashValue( - Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr); + Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr); Tcl_MutexUnlock(&tableMutex); } @@ -698,56 +870,54 @@ Tcl_RegisterObjType(typePtr) * * Tcl_AppendAllObjTypes -- * - * This procedure appends onto the argument object the name of each - * object type as a list element. This includes the builtin object - * types (e.g. int, list) as well as those added using - * Tcl_NewObj. These names can be used, for example, with - * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType - * structures. + * This function appends onto the argument object the name of each object + * type as a list element. This includes the builtin object types (e.g. + * int, list) as well as those added using Tcl_NewObj. These names can be + * used, for example, with Tcl_GetObjType to get pointers to the + * corresponding Tcl_ObjType structures. * * Results: * The return value is normally TCL_OK; in this case the object - * referenced by objPtr has each type name appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. + * referenced by objPtr has each type name appended to it. If an error + * occurs, TCL_ERROR is returned and the interpreter's result holds an + * error message. * * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. + * If necessary, the object referenced by objPtr is converted into a list + * object. * *---------------------------------------------------------------------- */ int -Tcl_AppendAllObjTypes(interp, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * name of each registered type is appended - * as a list element. */ +Tcl_AppendAllObjTypes( + Tcl_Interp *interp, /* Interpreter used for error reporting. */ + Tcl_Obj *objPtr) /* Points to the Tcl object onto which the + * name of each registered type is appended as + * a list element. */ { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int objc; - Tcl_Obj **objv; + int numElems; /* * Get the test for a valid list out of the way first. */ - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { return TCL_ERROR; } /* - * Type names are NUL-terminated, not counted strings. - * This code relies on that. + * Type names are NUL-terminated, not counted strings. This code relies on + * that. */ Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); + Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; @@ -758,12 +928,11 @@ Tcl_AppendAllObjTypes(interp, objPtr) * * Tcl_GetObjType -- * - * This procedure looks up an object type by name. + * This function looks up an object type by name. * * Results: - * If an object type with name matching "typeName" is found, a pointer - * to its Tcl_ObjType structure is returned; otherwise, NULL is - * returned. + * If an object type with name matching "typeName" is found, a pointer to + * its Tcl_ObjType structure is returned; otherwise, NULL is returned. * * Side effects: * None. @@ -772,16 +941,16 @@ Tcl_AppendAllObjTypes(interp, objPtr) */ Tcl_ObjType * -Tcl_GetObjType(typeName) - CONST char *typeName; /* Name of Tcl object type to look up. */ +Tcl_GetObjType( + CONST char *typeName) /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); - if (hPtr != (Tcl_HashEntry *) NULL) { - typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + if (hPtr != NULL) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -796,10 +965,10 @@ Tcl_GetObjType(typeName) * * Results: * The return value is TCL_OK on success and TCL_ERROR on failure. If - * TCL_ERROR is returned, then the interpreter's result contains an - * error message unless "interp" is NULL. Passing a NULL "interp" - * allows this procedure to be used as a test whether the conversion - * could be done (and in fact was done). + * TCL_ERROR is returned, then the interpreter's result contains an error + * message unless "interp" is NULL. Passing a NULL "interp" allows this + * function to be used as a test whether the conversion could be done + * (and in fact was done). * * Side effects: * Any internal representation for the old type is freed. @@ -808,46 +977,174 @@ Tcl_GetObjType(typeName) */ int -Tcl_ConvertToType(interp, objPtr, typePtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ - Tcl_ObjType *typePtr; /* The target type. */ +Tcl_ConvertToType( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object to convert. */ + Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; } /* - * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal - * form as appropriate for the target type. This frees the old internal + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form + * as appropriate for the target type. This frees the old internal * representation. */ + if (typePtr->setFromAnyProc == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't convert value to type %s", typePtr->name)); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + } + return TCL_ERROR; + } + return typePtr->setFromAnyProc(interp, objPtr); } /* + *-------------------------------------------------------------- + * + * TclDbDumpActiveObjects -- + * + * This function is called to dump all of the active Tcl_Obj structs this + * allocator knows about. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclDbDumpActiveObjects( + FILE *outFile) +{ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + + if (tablePtr != NULL) { + fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); + for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + fprintf(outFile, + "key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n", + Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr, + objData->file, objData->line); + } else { + fprintf(outFile, "key = 0x%p\n", + Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclDbInitNewObj -- + * + * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is + * enabled. This function will initialize the members of a Tcl_Obj + * struct. Initilization would be done inline via the TclNewObj macro + * when compiling without TCL_MEM_DEBUG. + * + * Results: + * The Tcl_Obj struct members are initialized. + * + * Side effects: + * None. + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +void +TclDbInitNewObj( + register Tcl_Obj *objPtr, + register CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + register int line) /* Line number in the source file; used for + * debugging. */ +{ + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; + +#ifdef TCL_THREADS + /* + * Add entry to a thread local map used to check if a Tcl_Obj was + * allocated by the currently executing thread. + */ + + if (!TclInExit()) { + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; + int isNew; + ObjData *objData; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->objThreadMap == NULL) { + tsdPtr->objThreadMap = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); + } + tablePtr = tsdPtr->objThreadMap; + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); + if (!isNew) { + Tcl_Panic("expected to create new entry for object map"); + } + + /* + * Record the debugging information. + */ + + objData = (ObjData *) ckalloc(sizeof(ObjData)); + objData->objPtr = objPtr; + objData->file = file; + objData->line = line; + Tcl_SetHashValue(hPtr, objData); + } +#endif /* TCL_THREADS */ +} +#endif /* TCL_MEM_DEBUG */ + +/* *---------------------------------------------------------------------- * * Tcl_NewObj -- * - * This procedure is normally called when not debugging: i.e., when + * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote * the empty string. These objects have a NULL object type and NULL - * string representation byte pointer. Type managers call this routine - * to allocate new objects that they further initialize. + * string representation byte pointer. Type managers call this routine to + * allocate new objects that they further initialize. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewObj. * * Results: * The result is a newly allocated object that represents the empty - * string. The new object's typePtr is set NULL and its ref count - * is set to 0. + * string. The new object's typePtr is set NULL and its ref count is set + * to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this function increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ @@ -856,7 +1153,7 @@ Tcl_ConvertToType(interp, objPtr, typePtr) #undef Tcl_NewObj Tcl_Obj * -Tcl_NewObj() +Tcl_NewObj(void) { return Tcl_DbNewObj("unknown", 0); } @@ -864,13 +1161,12 @@ Tcl_NewObj() #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewObj() +Tcl_NewObj(void) { register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclNewObj(objPtr); @@ -883,24 +1179,24 @@ Tcl_NewObj() * * Tcl_DbNewObj -- * - * This procedure is normally called when debugging: i.e., when + * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the - * empty string. It is the same as the Tcl_NewObj procedure above - * except that it calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the correct file name and line + * empty string. It is the same as the Tcl_NewObj function above except + * that it calls Tcl_DbCkalloc directly with the file name and line + * number from its caller. This simplifies debugging since then the + * [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewObj. * * Results: - * The result is a newly allocated that represents the empty string. - * The new object's typePtr is set NULL and its ref count is set to 0. + * The result is a newly allocated that represents the empty string. The + * new object's typePtr is set NULL and its ref count is set to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this function increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ @@ -908,17 +1204,16 @@ Tcl_NewObj() #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewObj(file, line) - register CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - register int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewObj( + register CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + register int line) /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclDbNewObj(objPtr, file, line); @@ -927,11 +1222,11 @@ Tcl_DbNewObj(file, line) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewObj(file, line) - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewObj( + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewObj(); } @@ -942,8 +1237,8 @@ Tcl_DbNewObj(file, line) * * TclAllocateFreeObjects -- * - * Procedure to allocate a number of free Tcl_Objs. This is done using - * a single ckalloc to reduce the overhead for Tcl_Obj allocation. + * Function to allocate a number of free Tcl_Objs. This is done using a + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * @@ -953,7 +1248,7 @@ Tcl_DbNewObj(file, line) * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. + * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ @@ -961,7 +1256,7 @@ Tcl_DbNewObj(file, line) #define OBJS_TO_ALLOC_EACH_TIME 100 void -TclAllocateFreeObjects() +TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; @@ -969,22 +1264,20 @@ TclAllocateFreeObjects() register int i; /* - * This has been noted by Purify to be a potential leak. The problem is + * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated - * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of - * actually freeing the memory. TclFinalizeObjects() does not ckfree() - * this memory, but leaves it to Tcl's memory subsystem finalziation to - * release it. Purify apparently can't figure that out, and fires a - * false alarm. + * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually + * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, + * but leaves it to Tcl's memory subsystem finalization to release it. + * Purify apparently can't figure that out, and fires a false alarm. */ basePtr = (char *) ckalloc(bytesToAlloc); - memset(basePtr, 0, bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) prevPtr; prevPtr = objPtr; objPtr++; } @@ -997,64 +1290,178 @@ TclAllocateFreeObjects() * * TclFreeObj -- * - * This procedure frees the memory associated with the argument - * object. It is called by the tcl.h macro Tcl_DecrRefCount when an - * object's ref count is zero. It is only "public" since it must - * be callable by that macro wherever the macro is used. It should not - * be directly called by clients. + * This function frees the memory associated with the argument object. + * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref + * count is zero. It is only "public" since it must be callable by that + * macro wherever the macro is used. It should not be directly called by + * clients. * * Results: * None. * * Side effects: - * Deallocates the storage for the object's Tcl_Obj structure - * after deallocating the string representation and calling the - * type-specific Tcl_FreeInternalRepProc to deallocate the object's - * internal representation. If compiling with TCL_COMPILE_STATS, - * this procedure increments the global count of freed objects - * (tclObjsFreed). + * Deallocates the storage for the object's Tcl_Obj structure after + * deallocating the string representation and calling the type-specific + * Tcl_FreeInternalRepProc to deallocate the object's internal + * representation. If compiling with TCL_COMPILE_STATS, this function + * increments the global count of freed objects (tclObjsFreed). * *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG void -TclFreeObj(objPtr) - register Tcl_Obj *objPtr; /* The object to be freed. */ +TclFreeObj( + register Tcl_Obj *objPtr) /* The object to be freed. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; - -#ifdef TCL_MEM_DEBUG - if ((objPtr)->refCount < -1) { - panic("Reference count for %lx was negative", objPtr); + + /* + * This macro declares a variable, so must come here... + */ + + ObjInitDeletionContext(context); + + /* + * Check for a double free of the same value. This is slightly tricky + * because it is customary to free a Tcl_Obj when its refcount falls + * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, + * and so on, is always a sign of a botch in the caller. + */ + if (objPtr->refCount < -1) { + Tcl_Panic("Reference count for %lx was negative", objPtr); } -#endif /* TCL_MEM_DEBUG */ + /* + * Now, in case we just approved drop from 1 to 0 as acceptable, make + * sure we do not accept a second free when falling from 0 to -1. + * Skip that possibility so any double free will trigger the panic. + */ + objPtr->refCount = -1; - TCL_DTRACE_OBJ_FREE(objPtr); - if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - typePtr->freeIntRepProc(objPtr); + /* 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 = -1; + + if (ObjDeletePending(context)) { + PushObjToDelete(context, objPtr); + } else { + TCL_DTRACE_OBJ_FREE(objPtr); + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + ObjDeletionLock(context); + typePtr->freeIntRepProc(objPtr); + ObjDeletionUnlock(context); + } + + Tcl_MutexLock(&tclObjMutex); + ckfree((char *) objPtr); + Tcl_MutexUnlock(&tclObjMutex); + TclIncrObjsFreed(); + ObjDeletionLock(context); + while (ObjOnStack(context)) { + Tcl_Obj *objToFree; + + PopObjToDelete(context,objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); + TclFreeIntRep(objToFree); + + Tcl_MutexLock(&tclObjMutex); + ckfree((char *) objToFree); + Tcl_MutexUnlock(&tclObjMutex); + TclIncrObjsFreed(); + } + ObjDeletionUnlock(context); } - Tcl_InvalidateStringRep(objPtr); /* - * If debugging Tcl's memory usage, deallocate the object using ckfree. - * Otherwise, deallocate it by adding it onto the list of free - * Tcl_Obj structs we maintain. + * We cannot use TclGetContinuationTable() here, because that may + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). */ -#if defined(TCL_MEM_DEBUG) || defined(PURIFY) - Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objPtr); - Tcl_MutexUnlock(&tclObjMutex); -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclThreadFreeObj(objPtr); -#else - Tcl_MutexLock(&tclObjMutex); - objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; - tclFreeObjList = objPtr; - Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_MEM_DEBUG */ + { + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + if (tsdPtr->lineCLPtr) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); + if (hPtr) { + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); + } + } + } +} +#else /* TCL_MEM_DEBUG */ + +void +TclFreeObj( + register Tcl_Obj *objPtr) /* The object to be freed. */ +{ + /* Invalidate the string rep first so we can use the bytes value + * for our pointer chain, and signal an obj deletion (as opposed + * to shimmering) with 'length == -1' */ + + TclInvalidateStringRep(objPtr); + objPtr->length = -1; + + if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { + /* + * objPtr can be freed safely, as it will not attempt to free any + * other objects: it will not cause recursive calls to this function. + */ + + TCL_DTRACE_OBJ_FREE(objPtr); + TclFreeObjStorage(objPtr); + TclIncrObjsFreed(); + } else { + /* + * This macro declares a variable, so must come here... + */ + + ObjInitDeletionContext(context); + + if (ObjDeletePending(context)) { + PushObjToDelete(context, objPtr); + } else { + /* + * Note that the contents of the while loop assume that the string + * rep has already been freed and we don't want to do anything + * fancy with adding to the queue inside ourselves. Must take care + * to unstack the object first since freeing the internal rep can + * add further objects to the stack. The code assumes that it is + * the first thing in a block; all current usages in the core + * satisfy this. + */ + + TCL_DTRACE_OBJ_FREE(objPtr); + ObjDeletionLock(context); + objPtr->typePtr->freeIntRepProc(objPtr); + ObjDeletionUnlock(context); + + TclFreeObjStorage(objPtr); + TclIncrObjsFreed(); + ObjDeletionLock(context); + while (ObjOnStack(context)) { + Tcl_Obj *objToFree; + PopObjToDelete(context,objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); + if ((objToFree->typePtr != NULL) + && (objToFree->typePtr->freeIntRepProc != NULL)) { + objToFree->typePtr->freeIntRepProc(objToFree); + } + TclFreeObjStorage(objToFree); + TclIncrObjsFreed(); + } + ObjDeletionUnlock(context); + } + } -#ifdef TCL_TIP280 /* * We cannot use TclGetContinuationTable() here, because that may * re-initialize the thread-data for calls coming after the @@ -1076,9 +1483,34 @@ TclFreeObj(objPtr) } } } +} #endif - TclIncrObjsFreed(); + +/* + *---------------------------------------------------------------------- + * + * TclObjBeingDeleted -- + * + * This function returns 1 when the Tcl_Obj is being deleted. It is + * provided for the rare cases where the reason for the loss of an + * internal rep might be relevant. [FR 1512138] + * + * Results: + * 1 if being deleted, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjBeingDeleted( + Tcl_Obj *objPtr) +{ + return (objPtr->length == -1); } + /* *---------------------------------------------------------------------- @@ -1089,29 +1521,29 @@ TclFreeObj(objPtr) * object. * * Results: - * The return value is a pointer to a newly created Tcl_Obj. This - * object has reference count 0 and the same type, if any, as the - * source object objPtr. Also: + * The return value is a pointer to a newly created Tcl_Obj. This object + * has reference count 0 and the same type, if any, as the source object + * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; - * otherwise, the duplicate's string rep is set NULL to mark - * it invalid. + * otherwise, the duplicate's string rep is set NULL to mark it + * invalid. * 2) If the source object has an internal representation (i.e. its - * typePtr is non-NULL), the new object's internal rep is set to - * a copy; otherwise the new internal rep is marked invalid. + * typePtr is non-NULL), the new object's internal rep is set to a + * copy; otherwise the new internal rep is marked invalid. * * Side effects: - * What constitutes "copying" the internal representation depends on - * the type. For example, if the argument object is a list, - * the element objects it points to will not actually be copied but - * will be shared with the duplicate list. That is, the ref counts of - * the element objects will be incremented. + * What constitutes "copying" the internal representation depends on the + * type. For example, if the argument object is a list, the element + * objects it points to will not actually be copied but will be shared + * with the duplicate list. That is, the ref counts of the element + * objects will be incremented. * *---------------------------------------------------------------------- */ Tcl_Obj * -Tcl_DuplicateObj(objPtr) - register Tcl_Obj *objPtr; /* The object to duplicate. */ +Tcl_DuplicateObj( + register Tcl_Obj *objPtr) /* The object to duplicate. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; register Tcl_Obj *dupPtr; @@ -1123,7 +1555,7 @@ Tcl_DuplicateObj(objPtr) } else if (objPtr->bytes != tclEmptyStringRep) { TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); } - + if (typePtr != NULL) { if (typePtr->dupIntRepProc == NULL) { dupPtr->internalRep = objPtr->internalRep; @@ -1157,16 +1589,16 @@ Tcl_DuplicateObj(objPtr) */ char * -Tcl_GetString(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ +Tcl_GetString( + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + * be returned. */ { if (objPtr->bytes != NULL) { return objPtr->bytes; } if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", + Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } (*objPtr->typePtr->updateStringProc)(objPtr); @@ -1178,16 +1610,16 @@ Tcl_GetString(objPtr) * * Tcl_GetStringFromObj -- * - * Returns the string representation's byte array pointer and length - * for an object. + * Returns the string representation's byte array pointer and length for + * an object. * * Results: - * Returns a pointer to the string representation of objPtr. If - * lengthPtr isn't NULL, the length of the string representation is - * stored at *lengthPtr. The byte array referenced by the returned - * pointer must not be modified by the caller. Furthermore, the - * caller must copy the bytes if they need to retain them since the - * object's string rep can change as a result of other operations. + * Returns a pointer to the string representation of objPtr. If lengthPtr + * isn't NULL, the length of the string representation is stored at + * *lengthPtr. The byte array referenced by the returned pointer must not + * be modified by the caller. Furthermore, the caller must copy the bytes + * if they need to retain them since the object's string rep can change + * as a result of other operations. * * Side effects: * May call the object's updateStringProc to update the string @@ -1197,16 +1629,16 @@ Tcl_GetString(objPtr) */ char * -Tcl_GetStringFromObj(objPtr, lengthPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should +Tcl_GetStringFromObj( + register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - register 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) { if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", + Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } (*objPtr->typePtr->updateStringProc)(objPtr); @@ -1223,48 +1655,44 @@ Tcl_GetStringFromObj(objPtr, lengthPtr) * * Tcl_InvalidateStringRep -- * - * This procedure is called to invalidate an object's string - * representation. + * This function is called to invalidate an object's string + * representation. * * Results: * None. * * Side effects: - * Deallocates the storage for any old string representation, then - * sets the string representation NULL to mark it invalid. + * Deallocates the storage for any old string representation, then sets + * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void -Tcl_InvalidateStringRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be freed. */ +Tcl_InvalidateStringRep( + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + * be freed. */ { - if (objPtr->bytes != NULL) { - if (objPtr->bytes != tclEmptyStringRep) { - ckfree((char *) objPtr->bytes); - } - objPtr->bytes = NULL; - } + TclInvalidateStringRep(objPtr); } + /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * - * This procedure is normally called when not debugging: i.e., when + * 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 - * "boolValue" is coerced to 1. + * initializes it from the argument boolean value. A nonzero "boolValue" + * is coerced to 1. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewBooleanObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1276,8 +1704,8 @@ Tcl_InvalidateStringRep(objPtr) #undef Tcl_NewBooleanObj Tcl_Obj * -Tcl_NewBooleanObj(boolValue) - register int boolValue; /* Boolean used to initialize new object. */ +Tcl_NewBooleanObj( + register int boolValue) /* Boolean used to initialize new object. */ { return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); } @@ -1285,16 +1713,12 @@ Tcl_NewBooleanObj(boolValue) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewBooleanObj(boolValue) - register int boolValue; /* Boolean used to initialize new object. */ +Tcl_NewBooleanObj( + register int boolValue) /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; + TclNewBooleanObj(objPtr, boolValue); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1304,20 +1728,20 @@ Tcl_NewBooleanObj(boolValue) * * Tcl_DbNewBooleanObj -- * - * This procedure is normally called when debugging: i.e., when + * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the - * same as the Tcl_NewBooleanObj procedure above except that it calls + * same as the Tcl_NewBooleanObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1328,32 +1752,32 @@ Tcl_NewBooleanObj(boolValue) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewBooleanObj(boolValue, file, line) - register int boolValue; /* Boolean used to initialize new object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewBooleanObj( + register int boolValue, /* Boolean used to initialize new object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - + objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; + objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewBooleanObj(boolValue, file, line) - register int boolValue; /* Boolean used to initialize new object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewBooleanObj( + register int boolValue, /* Boolean used to initialize new object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewBooleanObj(boolValue); } @@ -1371,30 +1795,22 @@ Tcl_DbNewBooleanObj(boolValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void -Tcl_SetBooleanObj(objPtr, boolValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register int boolValue; /* Boolean used to set object's value. */ +Tcl_SetBooleanObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register int boolValue) /* Boolean used to set object's value. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetBooleanObj called with shared object"); - } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); + Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; - Tcl_InvalidateStringRep(objPtr); + + TclSetBooleanObj(objPtr, boolValue); } /* @@ -1402,9 +1818,8 @@ Tcl_SetBooleanObj(objPtr, boolValue) * * Tcl_GetBooleanFromObj -- * - * Attempt to return a boolean from the Tcl object "objPtr". If the - * object is not already a boolean, an attempt will be made to convert - * it to one. + * Attempt to return a boolean from the Tcl object "objPtr". This + * includes conversion from any of Tcl's numeric types. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -1412,30 +1827,56 @@ Tcl_SetBooleanObj(objPtr, boolValue) * result unless "interp" is NULL. * * Side effects: - * If the object is not already a boolean, the conversion will free - * any old internal representation. + * The intrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ int -Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get boolean. */ - register int *boolPtr; /* Place to store resulting boolean. */ +Tcl_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. */ { - register int result; + do { + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBooleanType) { + *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 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. + */ - if (objPtr->typePtr == &tclBooleanType) { - result = TCL_OK; - } else { - result = SetBooleanFromAny(interp, objPtr); - } + double d; - if (result == TCL_OK) { - *boolPtr = (int) objPtr->internalRep.longValue; - } - return result; + if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { + return TCL_ERROR; + } + *boolPtr = (d != 0.0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { + *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, "boolean value", NULL,-1,NULL,0))); + return TCL_ERROR; } /* @@ -1452,218 +1893,174 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) * unless "interp" is NULL. * * 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. + * 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. * *---------------------------------------------------------------------- */ static int -SetBooleanFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - register char c; - char lowerCase[10]; - int newBool, length; - register int i; - +SetBooleanFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ /* - * Get the string representation. Make it up-to-date if necessary. + * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine + * whether a boolean conversion is possible without generating the string + * rep. */ - - string = Tcl_GetStringFromObj(objPtr, &length); + + if (objPtr->bytes == NULL) { + if (objPtr->typePtr == &tclIntType) { + switch (objPtr->internalRep.longValue) { + case 0L: case 1L: + return TCL_OK; + } + goto badBoolean; + } + + if (objPtr->typePtr == &tclBignumType) { + goto badBoolean; + } + +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + goto badBoolean; + } +#endif + + if (objPtr->typePtr == &tclDoubleType) { + goto badBoolean; + } + } + + if (ParseBoolean(objPtr) == TCL_OK) { + return TCL_OK; + } + + badBoolean: + if (interp != NULL) { + 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); + } + return TCL_ERROR; +} + +static int +ParseBoolean( + register Tcl_Obj *objPtr) /* The object to parse/convert. */ +{ + 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; + } + + switch (str[0]) { + case '0': + if (length == 1) { + newBool = 0; + goto numericBoolean; + } + return TCL_ERROR; + case '1': + if (length == 1) { + newBool = 1; + goto numericBoolean; + } + return TCL_ERROR; + } /* - * Use the obvious shortcuts for numerical values; if objPtr is not - * of numerical type, parse its string rep. + * Force to lower case for case-insensitive detection. Filter out known + * invalid characters at the same time. */ - - if (objPtr->typePtr == &tclIntType) { - newBool = (objPtr->internalRep.longValue != 0); - } else if (objPtr->typePtr == &tclDoubleType) { - newBool = (objPtr->internalRep.doubleValue != 0.0); - } else if (objPtr->typePtr == &tclWideIntType) { - newBool = (objPtr->internalRep.wideValue != 0); - } else { - /* - * Copy the string converting its characters to lower case. - */ - - for (i = 0; (i < 9) && (i < length); i++) { - c = string[i]; - /* - * Weed out international characters so we can safely operate - * on single bytes. - */ - - if (c & 0x80) { - goto badBoolean; - } - if (Tcl_UniCharIsUpper(UCHAR(c))) { - c = (char) Tcl_UniCharToLower(UCHAR(c)); - } + + 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': + lowerCase[i] = c + (char) ('a' - 'A'); + break; + case 'a': case 'e': case 'f': case 'l': case 'n': + case 'o': case 'r': case 's': case 't': case 'u': case 'y': lowerCase[i] = c; + break; + default: + return TCL_ERROR; } - lowerCase[i] = 0; - + } + lowerCase[length] = 0; + switch (lowerCase[0]) { + case 'y': /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. + * Checking the 'y' is redundant, but makes the code clearer. */ - - c = lowerCase[0]; - if ((c == '0') && (lowerCase[1] == '\0')) { - newBool = 0; - } else if ((c == '1') && (lowerCase[1] == '\0')) { + if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; - } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { + goto goodBoolean; + } + return TCL_ERROR; + case 'n': + if (strncmp(lowerCase, "no", (size_t) length) == 0) { + newBool = 0; + goto goodBoolean; + } + return TCL_ERROR; + case 't': + if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; - } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { + goto goodBoolean; + } + return TCL_ERROR; + case 'f': + if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; - } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { + goto goodBoolean; + } + return TCL_ERROR; + case 'o': + if (length < 2) { + return TCL_ERROR; + } + if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; - } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { + goto goodBoolean; + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; - } else if ((c == 'o') && (length >= 2)) { - if (strncmp(lowerCase, "on", (size_t) length) == 0) { - newBool = 1; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { - newBool = 0; - } else { - goto badBoolean; - } - } else { - double dbl; - /* - * Boolean values can be extracted from ints or doubles. Note - * that we don't use strtoul or strtoull here because we don't - * care about what the value is, just whether it is equal to - * zero or not. - */ -#ifdef TCL_WIDE_INT_IS_LONG - newBool = strtol(string, &end, 0); - if (end != string) { - /* - * Make sure the string has no garbage after the end of - * the int. - */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end == (string+length)) { - newBool = (newBool != 0); - goto goodBoolean; - } - } -#else /* !TCL_WIDE_INT_IS_LONG */ - Tcl_WideInt wide = strtoll(string, &end, 0); - if (end != string) { - /* - * Make sure the string has no garbage after the end of - * the wide int. - */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end == (string+length)) { - newBool = (wide != Tcl_LongAsWide(0)); - goto goodBoolean; - } - } -#endif /* TCL_WIDE_INT_IS_LONG */ - /* - * Still might be a string containing the characters representing an - * int or double that wasn't handled above. This would be a string - * like "27" or "1.0" that is non-zero and not "1". Such a string - * would result in the boolean value true. We try converting to - * double. If that succeeds and the resulting double is non-zero, we - * have a "true". Note that numbers can't have embedded NULLs. - */ - - dbl = strtod(string, &end); - if (end == string) { - goto badBoolean; - } - - /* - * Make sure the string has no garbage after the end of the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end != (string+length)) { - goto badBoolean; - } - newBool = (dbl != 0.0); + goto goodBoolean; } + return TCL_ERROR; + default: + return TCL_ERROR; } /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - goodBoolean: - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - + goodBoolean: + TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; - badBoolean: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to a boolean. - */ - - char buf[100]; - sprintf(buf, "expected boolean value but got \"%.50s\"", string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfBoolean -- - * - * Update the string representation for a boolean object. - * Note: This procedure 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 boolean-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfBoolean(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - char *s = ckalloc((unsigned) 2); - - s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); - s[1] = '\0'; - objPtr->bytes = s; - objPtr->length = 1; + numericBoolean: + TclFreeIntRep(objPtr); + objPtr->internalRep.longValue = newBool; + objPtr->typePtr = &tclIntType; + return TCL_OK; } /* @@ -1671,12 +2068,12 @@ UpdateStringOfBoolean(objPtr) * * Tcl_NewDoubleObj -- * - * This procedure is normally called when not debugging: i.e., when + * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new double object and * initializes it from the argument double value. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDoubleObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewDoubleObj. * * Results: * The newly created object is returned. This object will have an @@ -1692,8 +2089,8 @@ UpdateStringOfBoolean(objPtr) #undef Tcl_NewDoubleObj Tcl_Obj * -Tcl_NewDoubleObj(dblValue) - register double dblValue; /* Double used to initialize the object. */ +Tcl_NewDoubleObj( + register double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } @@ -1701,16 +2098,12 @@ Tcl_NewDoubleObj(dblValue) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewDoubleObj(dblValue) - register double dblValue; /* Double used to initialize the object. */ +Tcl_NewDoubleObj( + register double dblValue) /* Double used to initialize the object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; + TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -1720,20 +2113,20 @@ Tcl_NewDoubleObj(dblValue) * * Tcl_DbNewDoubleObj -- * - * This procedure is normally called when debugging: i.e., when + * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new double objects. It is the - * same as the Tcl_NewDoubleObj procedure above except that it calls + * same as the Tcl_NewDoubleObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewDoubleObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1744,18 +2137,18 @@ Tcl_NewDoubleObj(dblValue) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewDoubleObj(dblValue, file, line) - register double dblValue; /* Double used to initialize the object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewDoubleObj( + register double dblValue, /* Double used to initialize the object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - + objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; @@ -1764,12 +2157,12 @@ Tcl_DbNewDoubleObj(dblValue, file, line) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewDoubleObj(dblValue, file, line) - register double dblValue; /* Double used to initialize the object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewDoubleObj( + register double dblValue, /* Double used to initialize the object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewDoubleObj(dblValue); } @@ -1787,30 +2180,22 @@ Tcl_DbNewDoubleObj(dblValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void -Tcl_SetDoubleObj(objPtr, dblValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register double dblValue; /* Double used to set the object's value. */ +Tcl_SetDoubleObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register double dblValue) /* Double used to set the object's value. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetDoubleObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); } - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; - Tcl_InvalidateStringRep(objPtr); + TclSetDoubleObj(objPtr, dblValue); } /* @@ -1818,9 +2203,8 @@ Tcl_SetDoubleObj(objPtr, dblValue) * * Tcl_GetDoubleFromObj -- * - * Attempt to return a double from the Tcl object "objPtr". If the - * object is not already a double, an attempt will be made to convert - * it to one. + * Attempt to return a double from the Tcl object "objPtr". If the object + * is not already a double, an attempt will be made to convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -1828,30 +2212,48 @@ Tcl_SetDoubleObj(objPtr, dblValue) * result unless "interp" is NULL. * * Side effects: - * If the object is not already a double, the conversion will free - * any old internal representation. + * If the object is not already a double, the conversion will free any + * old internal representation. * *---------------------------------------------------------------------- */ int -Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a double. */ - register double *dblPtr; /* Place to store resulting double. */ +Tcl_GetDoubleFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a double. */ + register double *dblPtr) /* Place to store resulting double. */ { - register int result; - - if (objPtr->typePtr == &tclDoubleType) { - *dblPtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } - - result = SetDoubleFromAny(interp, objPtr); - if (result == TCL_OK) { - *dblPtr = objPtr->internalRep.doubleValue; - } - return result; + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "floating point value is Not a Number", -1)); + } + return TCL_ERROR; + } + *dblPtr = (double) objPtr->internalRep.doubleValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *dblPtr = objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { + mp_int 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; } /* @@ -1875,78 +2277,12 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) */ static int -SetDoubleFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +SetDoubleFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - double newDouble; - int length; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an double. Numbers can't have embedded - * NULLs. We use an implementation here that doesn't report errors in - * interp if interp is NULL. - */ - - errno = 0; - newDouble = strtod(string, &end); - if (end == string) { - badDouble: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to an int. - */ - - char buf[100]; - sprintf(buf, "expected floating-point number but got \"%.50s\"", - string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } - return TCL_ERROR; - } - if (errno != 0) { - if (interp != NULL) { - TclExprFloatError(interp, newDouble); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badDouble; - } - - /* - * The conversion to double succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.doubleValue = newDouble; - objPtr->typePtr = &tclDoubleType; - return TCL_OK; + return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, + NULL, 0); } /* @@ -1954,9 +2290,9 @@ SetDoubleFromAny(interp, objPtr) * * UpdateStringOfDouble -- * - * Update the string representation for a double-precision floating - * point object. This must obey the current tcl_precision value for - * double-to-string conversions. Note: This procedure does not free an + * Update the string representation for a double-precision floating point + * object. This must obey the current tcl_precision value for + * double-to-string conversions. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * @@ -1964,23 +2300,22 @@ SetDoubleFromAny(interp, objPtr) * None. * * Side effects: - * The object's string is set to a valid string that results from - * the double-to-string conversion. + * The object's string is set to a valid string that results from the + * double-to-string conversion. * *---------------------------------------------------------------------- */ static void -UpdateStringOfDouble(objPtr) - register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ +UpdateStringOfDouble( + register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { char buffer[TCL_DOUBLE_SPACE]; register int len; - - Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, - buffer); + + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); - + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); strcpy(objPtr->bytes, buffer); objPtr->length = len; @@ -1993,22 +2328,22 @@ UpdateStringOfDouble(objPtr) * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewIntObj to create a new integer object end up calling the - * debugging procedure Tcl_DbNewLongObj instead. + * debugging function Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewIntObj implementations below. We provide two implementations so + * that the Tcl core can be compiled to do memory debugging of the core + * even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -2020,8 +2355,8 @@ UpdateStringOfDouble(objPtr) #undef Tcl_NewIntObj Tcl_Obj * -Tcl_NewIntObj(intValue) - register int intValue; /* Int used to initialize the new object. */ +Tcl_NewIntObj( + register int intValue) /* Int used to initialize the new object. */ { return Tcl_DbNewLongObj((long)intValue, "unknown", 0); } @@ -2029,16 +2364,12 @@ Tcl_NewIntObj(intValue) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewIntObj(intValue) - register int intValue; /* Int used to initialize the new object. */ +Tcl_NewIntObj( + register int intValue) /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (long)intValue; - objPtr->typePtr = &tclIntType; + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2055,30 +2386,22 @@ Tcl_NewIntObj(intValue) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void -Tcl_SetIntObj(objPtr, intValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register int intValue; /* Integer used to set object's value. */ +Tcl_SetIntObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register int intValue) /* Integer used to set object's value. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetIntObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = (long) intValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); + + TclSetIntObj(objPtr, intValue); } /* @@ -2091,67 +2414,48 @@ Tcl_SetIntObj(objPtr, intValue) * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object - * can not be represented by an int, an error message is left in - * the interpreter's result unless "interp" is NULL. + * during conversion or if the long integer held by the object can not be + * represented by an int, an error message is left in the interpreter's + * result unless "interp" is NULL. * * Side effects: - * If the object is not already an int, the conversion will free - * any old internal representation. + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ int -Tcl_GetIntFromObj(interp, objPtr, intPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a int. */ - register int *intPtr; /* Place to store resulting int. */ +Tcl_GetIntFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a int. */ + register int *intPtr) /* Place to store resulting int. */ { - int result; - Tcl_WideInt w = 0; - - /* - * If the object isn't already an integer of any width, try to - * convert it to one. - */ - - if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { - result = SetIntOrWideFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; - } - } - - /* - * Object should now be either int or wide. Get its value. - */ +#if (LONG_MAX == INT_MAX) + return TclGetLongFromObj(interp, objPtr, (long *) intPtr); +#else + long l; -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - w = objPtr->internalRep.wideValue; - } else -#endif - { - w = Tcl_LongAsWide(objPtr->internalRep.longValue); + if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { + return TCL_ERROR; } - - if ((LLONG_MAX > UINT_MAX) - && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", - -1)); + 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, NULL); } return TCL_ERROR; } - *intPtr = (int)w; + *intPtr = (int) l; return TCL_OK; +#endif } /* @@ -2159,173 +2463,24 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) * * SetIntFromAny -- * - * Attempts to force the internal representation for a Tcl object - * to tclIntType, specifically. - * - * Results: - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -SetIntFromAny( Tcl_Interp* interp, - /* Tcl interpreter */ - Tcl_Obj* objPtr ) - /* Pointer to the object to convert */ -{ - int result; - - result = SetIntOrWideFromAny( interp, objPtr ); - if ( result != TCL_OK ) { - return result; - } - if ( objPtr->typePtr != &tclIntType ) { - if ( interp != NULL ) { - char *s = "integer value too large to represent"; - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetIntOrWideFromAny -- - * - * Attempt to generate an integer internal form for the Tcl object - * "objPtr". + * Attempts to force the internal representation for a Tcl object to + * tclIntType, specifically. * * Results: * 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 no error occurs, an int is stored as "objPtr"s internal - * representation. - * *---------------------------------------------------------------------- */ static int -SetIntOrWideFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - int length; - register char *p; - unsigned long newLong; - int isNegative = 0; - int isWide = 0; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - p = string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an int. We use an implementation here - * that doesn't report errors in interp if interp is NULL. Note: use - * strtoul instead of strtol for integer conversions to allow full-size - * unsigned numbers, but don't depend on strtoul to handle sign - * characters; it won't in some implementations. - */ - - errno = 0; - for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - isNegative = 1; - } else if (*p == '+') { - p++; - } - if (!isdigit(UCHAR(*p))) { - badInteger: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to an int. - */ - - char buf[100]; - sprintf(buf, "expected integer but got \"%.50s\"", string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - newLong = strtoul(p, &end, 0); - if (end == p) { - goto badInteger; - } - if (errno == ERANGE) { - if (interp != NULL) { - char *s = "integer value too large to represent"; - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the int. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badInteger; - } - - /* - * If the resulting integer will exceed the range of a long, - * put it into a wide instead. (Tcl Bug #868489) - */ - -#ifndef TCL_WIDE_INT_IS_LONG - if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) - || (!isNegative && newLong > LONG_MAX)) { - isWide = 1; - } -#endif - - /* - * The conversion to int succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - if (isWide) { - objPtr->internalRep.wideValue = - (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); - objPtr->typePtr = &tclWideIntType; - } else { - objPtr->internalRep.longValue = - (isNegative ? -(long)newLong : (long)newLong); - objPtr->typePtr = &tclIntType; - } - return TCL_OK; +SetIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ +{ + long l; + return TclGetLongFromObj(interp, objPtr, &l); } /* @@ -2333,29 +2488,29 @@ SetIntOrWideFromAny(interp, objPtr) * * UpdateStringOfInt -- * - * Update the string representation for an integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for an 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 int-to-string conversion. + * The object's string is set to a valid string that results from the + * int-to-string conversion. * *---------------------------------------------------------------------- */ static void -UpdateStringOfInt(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +UpdateStringOfInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE]; register int len; - + len = TclFormatInt(buffer, objPtr->internalRep.longValue); - + objPtr->bytes = ckalloc((unsigned) len + 1); strcpy(objPtr->bytes, buffer); objPtr->length = len; @@ -2367,23 +2522,23 @@ UpdateStringOfInt(objPtr) * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling - * the debugging procedure Tcl_DbNewLongObj instead. + * Tcl_NewLongObj to create a new long integer object end up calling the + * debugging function Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewLongObj result in a call to one of the two * Tcl_NewLongObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the + * so that the Tcl core can be compiled to do memory debugging of the * core even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -2395,8 +2550,8 @@ UpdateStringOfInt(objPtr) #undef Tcl_NewLongObj Tcl_Obj * -Tcl_NewLongObj(longValue) - register long longValue; /* Long integer used to initialize the +Tcl_NewLongObj( + register long longValue) /* Long integer used to initialize the * new object. */ { return Tcl_DbNewLongObj(longValue, "unknown", 0); @@ -2405,17 +2560,13 @@ Tcl_NewLongObj(longValue) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewLongObj(longValue) - register long longValue; /* Long integer used to initialize the +Tcl_NewLongObj( + register long longValue) /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; + TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2426,26 +2577,25 @@ Tcl_NewLongObj(longValue) * Tcl_DbNewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or - * long integer objects end up calling the debugging procedure - * Tcl_DbNewLongObj instead. We provide two implementations of - * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do - * memory debugging of the core is independent of whether a client - * requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the caller's file name and - * line number when reporting objects that haven't been freed. + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer + * objects end up calling the debugging function Tcl_DbNewLongObj + * instead. We provide two implementations of Tcl_DbNewLongObj so that + * whether the Tcl core is compiled to do memory debugging of the core is + * independent of whether a client requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj + * calls Tcl_DbCkalloc directly with the file name and line number from + * its caller. This simplifies debugging since then the [memory active] + * command will report the caller's file name and line number when + * reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, - * this procedure just returns the result of calling Tcl_NewLongObj. + * this function just returns the result of calling Tcl_NewLongObj. * * Results: - * The newly created long integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created long integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. @@ -2456,19 +2606,19 @@ Tcl_NewLongObj(longValue) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewLongObj( + register long longValue, /* Long integer used to initialize the new + * object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - + objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; @@ -2477,13 +2627,13 @@ Tcl_DbNewLongObj(longValue, file, line) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbNewLongObj( + register long longValue, /* Long integer used to initialize the new + * object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewLongObj(longValue); } @@ -2501,31 +2651,23 @@ Tcl_DbNewLongObj(longValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void -Tcl_SetLongObj(objPtr, longValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register long longValue; /* Long integer used to initialize the +Tcl_SetLongObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register long longValue) /* Long integer used to initialize the * object's value. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetLongObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); + TclSetLongObj(objPtr, longValue); } /* @@ -2533,8 +2675,8 @@ Tcl_SetLongObj(objPtr, longValue) * * Tcl_GetLongFromObj -- * - * Attempt to return an long integer from the Tcl object "objPtr". If - * the object is not already an int object, an attempt will be made to + * Attempt to return an long integer from the Tcl object "objPtr". If the + * object is not already an int object, an attempt will be made to * convert it to one. * * Results: @@ -2550,211 +2692,133 @@ Tcl_SetLongObj(objPtr, longValue) */ int -Tcl_GetLongFromObj(interp, objPtr, longPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a long. */ - register long *longPtr; /* Place to store resulting long. */ +Tcl_GetLongFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a long. */ + register long *longPtr) /* Place to store resulting long. */ { - register int result; - - if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { - result = SetIntOrWideFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; + do { + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; } - } - -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - /* - * If the object is already a wide integer, don't convert it. - * This code allows for any integer in the range -ULONG_MAX to - * ULONG_MAX to be 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 the internal rep. - */ +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + /* + * 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 + * the internal rep. + */ - Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = Tcl_WideAsLong(w); - return TCL_OK; - } else { - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "integer value too large to represent", -1); + Tcl_WideInt w = objPtr->internalRep.wideValue; + if (w >= -(Tcl_WideInt)(ULONG_MAX) + && w <= (Tcl_WideInt)(ULONG_MAX)) { + *longPtr = Tcl_WideAsLong(w); + return TCL_OK; } - return TCL_ERROR; + goto tooLarge; } - } #endif - - *longPtr = objPtr->internalRep.longValue; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetWideIntFromAny -- - * - * Attempt to generate an integer internal form for the Tcl object - * "objPtr". - * - * Results: - * 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 no error occurs, an int is stored as "objPtr"s internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetWideIntFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - int length; - register char *p; - Tcl_WideInt newWide; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - p = string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an int. We use an implementation here - * that doesn't report errors in interp if interp is NULL. Note: use - * strtoull instead of strtoll for integer conversions to allow full-size - * unsigned numbers, but don't depend on strtoull to handle sign - * characters; it won't in some implementations. - */ - - errno = 0; -#ifdef TCL_STRTOUL_SIGN_CHECK - for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); - } else if (*p == '+') { - p++; - newWide = strtoull(p, &end, 0); - } else -#else - newWide = strtoull(p, &end, 0); -#endif - if (end == p) { - badInteger: - if (interp != 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) { /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to an int. + * Must check for those bignum values that can fit in a long, even + * when auto-narrowing is enabled. Only those values in the signed + * long range get auto-narrowed to tclIntType, while all the + * values in the unsigned long range will fit in a long. */ - - char buf[100]; - sprintf(buf, "expected integer but got \"%.50s\"", string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - if (errno == ERANGE) { - if (interp != NULL) { - char *s = "integer value too large to represent"; - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - /* - * Make sure that the string has no garbage after the end of the int. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badInteger; - } - - /* - * The conversion to int succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.wideValue = newWide; -#else - if (TCL_ERROR == SetIntFromAny(interp, objPtr)) { - return TCL_ERROR; - } + mp_int big; + + 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) { + *longPtr = - (long) value; + } else { + *longPtr = (long) value; + } + return TCL_OK; + } + } +#ifndef NO_WIDE_TYPE + tooLarge: #endif - objPtr->typePtr = &tclWideIntType; - return TCL_OK; + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_Obj *msg = Tcl_NewStringObj(s, -1); + + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + 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 procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * 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. + * The object's string is set to a valid string that results from the + * wideInt-to-string conversion. * *---------------------------------------------------------------------- */ -#ifndef TCL_WIDE_INT_IS_LONG static void -UpdateStringOfWideInt(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +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. + * 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 /* TCL_WIDE_INT_IS_LONG */ +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- @@ -2763,17 +2827,17 @@ UpdateStringOfWideInt(objPtr) * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling - * the debugging procedure Tcl_DbNewWideIntObj instead. + * the debugging function Tcl_DbNewWideIntObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewWideIntObj result in a call to one of the two - * Tcl_NewWideIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewWideIntObj implementations below. We provide two + * implementations so that the Tcl core can be compiled to do memory + * debugging of the core even if a client does not request it for itself. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -2785,9 +2849,10 @@ UpdateStringOfWideInt(objPtr) #undef Tcl_NewWideIntObj Tcl_Obj * -Tcl_NewWideIntObj(wideValue) - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the new object. */ +Tcl_NewWideIntObj( + register Tcl_WideInt wideValue) + /* Wide integer used to initialize the new + * object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } @@ -2795,17 +2860,15 @@ Tcl_NewWideIntObj(wideValue) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewWideIntObj(wideValue) - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the new object. */ +Tcl_NewWideIntObj( + register Tcl_WideInt wideValue) + /* Wide integer used to initialize the new + * object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2816,27 +2879,25 @@ Tcl_NewWideIntObj(wideValue) * Tcl_DbNewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewWideIntObj to create new wide integer end up calling - * the debugging procedure Tcl_DbNewWideIntObj instead. We - * provide two implementations of Tcl_DbNewWideIntObj so that - * whether the Tcl core is compiled to do memory debugging of the - * core is independent of whether a client requests debugging for - * itself. + * Tcl_NewWideIntObj to create new wide integer end up calling the + * debugging function Tcl_DbNewWideIntObj instead. We provide two + * implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is + * compiled to do memory debugging of the core is independent of whether + * a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file - * name and line number from its caller. This simplifies - * debugging since then the checkmem command will report the - * caller's file name and line number when reporting objects that - * haven't been freed. + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name + * and line number from its caller. This simplifies debugging since then + * the checkmem command will report the caller's file name and line + * number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, - * this procedure just returns the result of calling Tcl_NewWideIntObj. + * this function just returns the result of calling Tcl_NewWideIntObj. * * Results: - * The newly created wide integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created wide integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. @@ -2847,36 +2908,33 @@ Tcl_NewWideIntObj(wideValue) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for - * debugging. */ - int line; /* Line number in the source file; - * used for debugging. */ +Tcl_DbNewWideIntObj( + register Tcl_WideInt wideValue, + /* Wide integer used to initialize the new + * object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Long integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for - * debugging. */ - int line; /* Line number in the source file; - * used for debugging. */ +Tcl_DbNewWideIntObj( + register Tcl_WideInt wideValue, + /* Long integer used to initialize the new + * object. */ + CONST char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewWideIntObj(wideValue); } @@ -2887,38 +2945,43 @@ Tcl_DbNewWideIntObj(wideValue, file, line) * * Tcl_SetWideIntObj -- * - * Modify an object to be a wide integer object and to have the - * specified wide integer value. + * Modify an object to be a wide integer object and to have the specified + * wide integer value. * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void -Tcl_SetWideIntObj(objPtr, wideValue) - register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the object's value. */ +Tcl_SetWideIntObj( + register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue) + /* Wide integer used to initialize the + * object's value. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetWideIntObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); + 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 } - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; - Tcl_InvalidateStringRep(objPtr); } /* @@ -2926,9 +2989,9 @@ Tcl_SetWideIntObj(objPtr, wideValue) * * Tcl_GetWideIntFromObj -- * - * Attempt to return a wide integer from the Tcl object "objPtr". If - * the object is not already a wide int object, an attempt will be made - * to convert it to one. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a wide int 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 @@ -2943,33 +3006,589 @@ Tcl_SetWideIntObj(objPtr, wideValue) */ int -Tcl_GetWideIntFromObj(interp, objPtr, 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. */ +Tcl_GetWideIntFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr) + /* Place to store resulting long. */ { - register int result; + do { +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } +#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) { + /* + * Must check for those bignum values that can fit in a + * Tcl_WideInt, even when auto-narrowing is enabled. + */ - if (objPtr->typePtr == &tclWideIntType) { - gotWide: - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; + mp_int big; + + 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++; + } + if (big.sign) { + *wideIntPtr = - (Tcl_WideInt) value; + } else { + *wideIntPtr = (Tcl_WideInt) value; + } + return TCL_OK; + } + } + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_Obj* msg = Tcl_NewStringObj(s, -1); + + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; +} +#ifndef NO_WIDE_TYPE + +/* + *---------------------------------------------------------------------- + * + * SetWideIntFromAny -- + * + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ +{ + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); +} +#endif /* !NO_WIDE_TYPE */ + +/* + *---------------------------------------------------------------------- + * + * FreeBignum -- + * + * This function frees the internal rep of a bignum. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FreeBignum( + Tcl_Obj *objPtr) +{ + mp_int toFree; /* Bignum to free */ + + UNPACK_BIGNUM(objPtr, toFree); + mp_clear(&toFree); + if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); + } +} + +/* + *---------------------------------------------------------------------- + * + * DupBignum -- + * + * This function duplicates the internal rep of a bignum. + * + * Results: + * None. + * + * Side effects: + * The destination object receies a copy of the source object + * + *---------------------------------------------------------------------- + */ + +static void +DupBignum( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + mp_int bignumVal; + mp_int bignumCopy; + + copyPtr->typePtr = &tclBignumType; + UNPACK_BIGNUM(srcPtr, bignumVal); + if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { + Tcl_Panic("initialization failure in DupBignum"); + } + PACK_BIGNUM(bignumCopy, copyPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfBignum -- + * + * This function updates the string representation of a bignum object. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to whatever results from the bignum- + * to-string conversion. + * + * The object's existing string representation is NOT freed; memory will leak + * if the string rep is still valid at the time this function is called. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfBignum( + Tcl_Obj *objPtr) +{ + mp_int bignumVal; + int size; + int status; + char* stringVal; + + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { + Tcl_Panic("radix size failure in UpdateStringOfBignum"); } - if (objPtr->typePtr == &tclIntType) { + if (size == 3) { /* - * This cast is safe; all valid ints/longs are wides. + * 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). 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. */ - objPtr->internalRep.wideValue = - Tcl_LongAsWide(objPtr->internalRep.longValue); - objPtr->typePtr = &tclWideIntType; - goto gotWide; + Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - result = SetWideIntFromAny(interp, objPtr); - if (result == TCL_OK) { - *wideIntPtr = objPtr->internalRep.wideValue; + stringVal = ckalloc((size_t) size); + status = mp_toradix_n(&bignumVal, stringVal, 10, size); + if (status != MP_OKAY) { + Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - return result; + objPtr->bytes = stringVal; + objPtr->length = size - 1; /* size includes a trailing null byte */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewBignumObj -- + * + * Creates an initializes a bignum object. + * + * Results: + * Returns the newly created object. + * + * Side effects: + * The bignum value is cleared, since ownership has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewBignumObj + +Tcl_Obj * +Tcl_NewBignumObj( + mp_int *bignumValue) +{ + return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); +} +#else +Tcl_Obj * +Tcl_NewBignumObj( + mp_int *bignumValue) +{ + Tcl_Obj* objPtr; + + TclNewObj(objPtr); + Tcl_SetBignumObj(objPtr, bignumValue); + return objPtr; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBignumObj -- + * + * This function is normally called when debugging: that is, when + * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording the + * creation point so that [memory active] can report it. + * + * Results: + * Returns the newly created object. + * + * Side effects: + * The bignum value is cleared, since ownership has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +Tcl_Obj * +Tcl_DbNewBignumObj( + mp_int *bignumValue, + CONST char *file, + int line) +{ + Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + Tcl_SetBignumObj(objPtr, bignumValue); + return objPtr; +} +#else +Tcl_Obj * +Tcl_DbNewBignumObj( + mp_int *bignumValue, + CONST char *file, + int line) +{ + return Tcl_NewBignumObj(bignumValue); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * GetBignumFromObj -- + * + * This function retrieves a 'bignum' value from a Tcl object, converting + * the object if necessary. Either copies or transfers the mp_int value + * depending on the copy flag value passed in. + * + * Results: + * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. + * + * Side effects: + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, and the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +static int +GetBignumFromObj( + Tcl_Interp *interp, /* Tcl interpreter for error reporting */ + Tcl_Obj *objPtr, /* Object to read */ + int copy, /* Whether to copy the returned bignum value */ + mp_int *bignumValue) /* Returned bignum value. */ +{ + do { + if (objPtr->typePtr == &tclBignumType) { + if (copy || Tcl_IsShared(objPtr)) { + mp_int temp; + UNPACK_BIGNUM(objPtr, temp); + mp_init_copy(bignumValue, &temp); + } else { + UNPACK_BIGNUM(objPtr, *bignumValue); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = 0; + objPtr->typePtr = NULL; + if (objPtr->bytes == NULL) { + TclInitStringRep(objPtr, tclEmptyStringRep, 0); + } + } + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + 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_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBignumFromObj -- + * + * This function retrieves a 'bignum' value from a Tcl object, converting + * the object if necessary. + * + * Results: + * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. + * + * Side effects: + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, an the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. + * + * It is expected that the caller will NOT have invoked mp_init on the + * bignum value before passing it in. Tcl will initialize the mp_int as + * it sets the value. The value is a copy of the value in objPtr, so it + * becomes the responsibility of the caller to call mp_clear on it. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBignumFromObj( + Tcl_Interp *interp, /* Tcl interpreter for error reporting */ + Tcl_Obj *objPtr, /* Object to read */ + mp_int *bignumValue) /* Returned bignum value. */ +{ + return GetBignumFromObj(interp, objPtr, 1, bignumValue); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TakeBignumFromObj -- + * + * This function retrieves a 'bignum' value from a Tcl object, converting + * the object if necessary. + * + * Results: + * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. + * + * Side effects: + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, an the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. + * + * It is expected that the caller will NOT have invoked mp_init on the + * bignum value before passing it in. Tcl will initialize the mp_int as + * it sets the value. The value is transferred from the internals of + * objPtr to the caller, passing responsibility of the caller to call + * mp_clear on it. The objPtr is cleared to hold an empty value. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TakeBignumFromObj( + Tcl_Interp *interp, /* Tcl interpreter for error reporting */ + Tcl_Obj *objPtr, /* Object to read */ + mp_int *bignumValue) /* Returned bignum value. */ +{ + return GetBignumFromObj(interp, objPtr, 0, bignumValue); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBignumObj -- + * + * This function sets the value of a Tcl_Obj to a large integer. + * + * Results: + * None. + * + * Side effects: + * Object value is stored. The bignum value is cleared, since ownership + * has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetBignumObj( + Tcl_Obj *objPtr, /* Object to set */ + mp_int *bignumValue) /* Value to store */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); + } + if ((size_t)(bignumValue->used) + <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForLong; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { + goto tooLargeForLong; + } + if (bignumValue->sign) { + TclSetLongObj(objPtr, -(long)value); + } else { + TclSetLongObj(objPtr, (long)value); + } + mp_clear(bignumValue); + return; + } + tooLargeForLong: +#ifndef 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; + } + tooLargeForWide: +#endif + TclInvalidateStringRep(objPtr); + TclFreeIntRep(objPtr); + TclSetBignumIntRep(objPtr, bignumValue); +} + +void +TclSetBignumIntRep( + Tcl_Obj *objPtr, + mp_int *bignumValue) +{ + 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. + */ + + bignumValue->dp = NULL; + bignumValue->alloc = bignumValue->used = 0; + bignumValue->sign = MP_NEG; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNumberFromObj -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int TclGetNumberFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + ClientData *clientDataPtr, + int *typePtr) +{ + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + *typePtr = TCL_NUMBER_NAN; + } else { + *typePtr = TCL_NUMBER_DOUBLE; + } + *clientDataPtr = &(objPtr->internalRep.doubleValue); + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *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 = Tcl_GetThreadData(&bignumKey, + (int) sizeof(mp_int)); + UNPACK_BIGNUM( objPtr, *bigPtr ); + *typePtr = TCL_NUMBER_BIG; + *clientDataPtr = bigPtr; + return TCL_OK; + } + } while (TCL_OK == + TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); + return TCL_ERROR; } /* @@ -2977,12 +3596,12 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) * * Tcl_DbIncrRefCount -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before incrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just increments - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this function just increments the + * reference count of the object. * * Results: * None. @@ -2994,20 +3613,45 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) */ void -Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are registering a - * reference to. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbIncrRefCount( + register Tcl_Obj *objPtr, /* The object we are registering a reference + * to. */ + CONST char *file, /* The name of the source file calling this + * 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); - panic("Trying to increment refCount of previously disposed object."); + Tcl_Panic("incrementing refCount of previously disposed object"); + } + +# ifdef TCL_THREADS + /* + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. + */ + + if (!TclInExit()) { + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (!hPtr) { + Tcl_Panic("%s%s", + "Trying to incr ref count of " + "Tcl_Obj allocated in another thread"); + } } +# endif #endif ++(objPtr)->refCount; } @@ -3017,12 +3661,12 @@ Tcl_DbIncrRefCount(objPtr, file, line) * * Tcl_DbDecrRefCount -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before decrementing the ref count. + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before decrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just decrements - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this function just decrements the + * reference count of the object. * * Results: * None. @@ -3034,20 +3678,59 @@ Tcl_DbIncrRefCount(objPtr, file, line) */ void -Tcl_DbDecrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are releasing a reference +Tcl_DbDecrRefCount( + register Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + 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); - panic("Trying to decrement refCount of previously disposed object."); + Tcl_Panic("decrementing refCount of previously disposed object"); } + +# ifdef TCL_THREADS + /* + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. + */ + + if (!TclInExit()) { + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (!hPtr) { + Tcl_Panic("%s%s", + "Trying to decr ref count of " + "Tcl_Obj allocated in another thread"); + } + + /* + * If the Tcl_Obj is going to be deleted, remove the entry. + */ + + if ((objPtr->refCount - 1) <= 0) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree((char *) objData); + } + + Tcl_DeleteHashEntry(hPtr); + } + } +# endif #endif if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); @@ -3059,12 +3742,12 @@ Tcl_DbDecrRefCount(objPtr, file, line) * * Tcl_DbIsShared -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It tests whether the object has a ref - * count greater than one. + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref count + * greater than one. * - * When TCL_MEM_DEBUG is not defined, this procedure just tests - * if the object has a ref count greater than one. + * When TCL_MEM_DEBUG is not defined, this function just tests if the + * object has a ref count greater than one. * * Results: * None. @@ -3076,20 +3759,45 @@ Tcl_DbDecrRefCount(objPtr, file, line) */ int -Tcl_DbIsShared(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object to test for being shared. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +Tcl_DbIsShared( + 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. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); - panic("Trying to check whether previously disposed object is shared."); + Tcl_Panic("checking whether previously disposed object is shared"); } + +# ifdef TCL_THREADS + /* + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. + */ + + if (!TclInExit()) { + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (!hPtr) { + Tcl_Panic("%s%s", + "Trying to check shared status of" + "Tcl_Obj allocated in another thread"); + } + } +# endif #endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); if ((objPtr)->refCount <= 1) { @@ -3101,6 +3809,7 @@ Tcl_DbIsShared(objPtr, file, line) } Tcl_MutexUnlock(&tclObjMutex); #endif + return ((objPtr)->refCount > 1); } @@ -3109,8 +3818,8 @@ Tcl_DbIsShared(objPtr, file, line) * * Tcl_InitObjHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use, the keys are Tcl_Obj *. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use, the keys are Tcl_Obj *. * * Results: * None. @@ -3123,9 +3832,10 @@ Tcl_DbIsShared(objPtr, file, line) */ void -Tcl_InitObjHashTable(tablePtr) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ +Tcl_InitObjHashTable( + register Tcl_HashTable *tablePtr) + /* Pointer to table record, which is supplied + * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); @@ -3148,16 +3858,17 @@ Tcl_InitObjHashTable(tablePtr) */ static Tcl_HashEntry * -AllocObjEntry(tablePtr, keyPtr) - Tcl_HashTable *tablePtr; /* Hash table. */ - VOID *keyPtr; /* Key to store in the hash table entry. */ +AllocObjEntry( + Tcl_HashTable *tablePtr, /* Hash table. */ + void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; Tcl_HashEntry *hPtr; hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); hPtr->key.oneWordValue = (char *) objPtr; - Tcl_IncrRefCount (objPtr); + Tcl_IncrRefCount(objPtr); + hPtr->clientData = NULL; return hPtr; } @@ -3165,13 +3876,13 @@ AllocObjEntry(tablePtr, keyPtr) /* *---------------------------------------------------------------------- * - * CompareObjKeys -- + * TclCompareObjKeys -- * * Compares two Tcl_Obj * keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. @@ -3179,10 +3890,10 @@ AllocObjEntry(tablePtr, keyPtr) *---------------------------------------------------------------------- */ -static int -CompareObjKeys(keyPtr, hPtr) - VOID *keyPtr; /* New key to compare. */ - Tcl_HashEntry *hPtr; /* Existing key to compare. */ +int +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; @@ -3192,6 +3903,7 @@ CompareObjKeys(keyPtr, hPtr) /* * If the object pointers are the same then they match. */ + if (objPtr1 == objPtr2) { return 1; } @@ -3200,14 +3912,16 @@ CompareObjKeys(keyPtr, hPtr) * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being * in a register. */ + p1 = TclGetString(objPtr1); l1 = objPtr1->length; p2 = TclGetString(objPtr2); l2 = objPtr2->length; - + /* * Only compare if the string representations are of the same length. */ + if (l1 == l2) { for (;; p1++, p2++, l1--) { if (*p1 != *p2) { @@ -3225,7 +3939,7 @@ CompareObjKeys(keyPtr, hPtr) /* *---------------------------------------------------------------------- * - * FreeObjEntry -- + * TclFreeObjEntry -- * * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. * @@ -3238,27 +3952,27 @@ CompareObjKeys(keyPtr, hPtr) *---------------------------------------------------------------------- */ -static void -FreeObjEntry(hPtr) - Tcl_HashEntry *hPtr; /* Hash entry to free. */ +void +TclFreeObjEntry( + Tcl_HashEntry *hPtr) /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; - Tcl_DecrRefCount (objPtr); - ckfree ((char *) hPtr); + Tcl_DecrRefCount(objPtr); + ckfree((char *) hPtr); } /* *---------------------------------------------------------------------- * - * HashObjKey -- + * TclHashObjKey -- * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * the string representation of the Tcl_Obj. + * The return value is a one-word summary of the information in the + * string representation of the Tcl_Obj. * * Side effects: * None. @@ -3266,36 +3980,35 @@ FreeObjEntry(hPtr) *---------------------------------------------------------------------- */ -static unsigned int -HashObjKey(tablePtr, keyPtr) - Tcl_HashTable *tablePtr; /* Hash table. */ - VOID *keyPtr; /* Key from which to compute hash value. */ +unsigned int +TclHashObjKey( + Tcl_HashTable *tablePtr, /* Hash table. */ + void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; CONST char *string = TclGetString(objPtr); int length = objPtr->length; - unsigned int result; + unsigned int result = 0; int i; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and 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. + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * 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. */ - result = 0; for (i=0 ; i<length ; i++) { - result += (result<<3) + string[i]; + result += (result << 3) + string[i]; } return result; } @@ -3305,111 +4018,78 @@ HashObjKey(tablePtr, keyPtr) * * Tcl_GetCommandFromObj -- * - * Returns the command specified by the name in a Tcl_Obj. + * Returns the command specified by the name in a Tcl_Obj. * * Results: - * Returns a token for the command if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL. + * Returns a token for the command if it is found. Otherwise, if it can't + * be found or there is an error, returns NULL. * * Side effects: - * May update the internal representation for the object, caching - * the command reference so that the next time this procedure is - * called with the same object, the command can be found quickly. + * May update the internal representation for the object, caching the + * command reference so that the next time this function is called with + * the same object, the command can be found quickly. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_GetCommandFromObj(interp, objPtr) - Tcl_Interp *interp; /* The interpreter in which to resolve the +Tcl_GetCommandFromObj( + Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ - register Tcl_Obj *objPtr; /* The object containing the command's - * name. If the name starts with "::", will - * be looked up in global namespace. Else, - * looked up first in the current namespace, - * then in global namespace. */ + register 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. */ { - Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Command *cmdPtr; - Namespace *currNsPtr; + Namespace *refNsPtr; int result; - CallFrame *savedFramePtr; - char *name; - - /* - * If the variable name is fully qualified, do as if the lookup were - * done from the global namespace; this helps avoid repeated lookups - * of fully qualified names. It costs close to nothing, and may be very - * helpful for OO applications which pass along a command name ("this"), - * [Patch 456668] - */ - - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; - } /* * Get the internal representation, converting to a command type if - * needed. The internal representation is a ResolvedCmdName that points - * to the actual command. + * needed. The internal representation is a ResolvedCmdName that points to + * the actual command. + * + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. Note that we verify that the + * namespace id of the context namespace is the same as the one we cached; + * this insures that the namespace wasn't deleted and a new one created at + * the same address with the same command epoch. Note that fully qualified + * names have a NULL refNsPtr, these checks needn't be made. + * + * Check also that the command's epoch is up to date, and that the command + * is not deleted. + * + * If any check fails, then force another conversion to the command type, + * to discard the old rep and create a new one. */ - - if (objPtr->typePtr != &tclCmdNameType) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; + 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; + } } - - /* - * Check the context namespace and the namespace epoch of the resolved - * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a - * new one. Note that we verify that the namespace id of the context - * namespace is the same as the one we cached; this insures that the - * namespace wasn't deleted and a new one created at the same address - * with the same command epoch. - */ - cmdPtr = NULL; - if ((resPtr != NULL) - && (resPtr->refNsPtr == currNsPtr) - && (resPtr->refNsId == currNsPtr->nsId) - && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { - cmdPtr = resPtr->cmdPtr; - if (cmdPtr->cmdEpoch != resPtr->cmdEpoch - || (cmdPtr->flags & CMD_IS_DELETED)) { - cmdPtr = NULL; - } - } - - if (cmdPtr == NULL) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { - cmdPtr = resPtr->cmdPtr; - } - } - iPtr->varFramePtr = savedFramePtr; return (Tcl_Command) cmdPtr; } @@ -3426,54 +4106,59 @@ Tcl_GetCommandFromObj(interp, objPtr) * * Side effects: * 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 + * changed. The refcount in the Command structure is incremented to keep + * it from being freed if the command is later deleted until * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ void -TclSetCmdNameObj(interp, objPtr, cmdPtr) - Tcl_Interp *interp; /* Points to interpreter containing command +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 + 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; register ResolvedCmdName *resPtr; - Tcl_ObjType *oldTypePtr = objPtr->typePtr; register Namespace *currNsPtr; + char *name; - if (oldTypePtr == &tclCmdNameType) { + if (objPtr->typePtr == &tclCmdNameType) { return; } - - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - + cmdPtr->refCount++; resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); + + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; } - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; } @@ -3491,17 +4176,17 @@ TclSetCmdNameObj(interp, objPtr, cmdPtr) * * Side effects: * Decrements the ref count of any cached ResolvedCmdName structure - * pointed to by the cmdName's internal representation. If this is - * the last use of the ResolvedCmdName, it is freed. This in turn - * decrements the ref count of the Command structure pointed to by - * the ResolvedSymbol, which may free the Command structure. + * pointed to by the cmdName's internal representation. If this is the + * last use of the ResolvedCmdName, it is freed. This in turn decrements + * the ref count of the Command structure pointed to by the + * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void -FreeCmdNameInternalRep(objPtr) - register Tcl_Obj *objPtr; /* CmdName object with internal +FreeCmdNameInternalRep( + register Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { register ResolvedCmdName *resPtr = @@ -3509,23 +4194,24 @@ FreeCmdNameInternalRep(objPtr) if (resPtr != NULL) { /* - * Decrement the reference count of the ResolvedCmdName structure. - * If there are no more uses, free the ResolvedCmdName structure. + * Decrement the reference count of the ResolvedCmdName structure. If + * there are no more uses, free the ResolvedCmdName structure. */ - - 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 objects. + + 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 + * objects. */ - - Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommand(cmdPtr); - ckfree((char *) resPtr); - } + + Command *cmdPtr = resPtr->cmdPtr; + TclCleanupCommandMacro(cmdPtr); + ckfree((char *) resPtr); + } } + objPtr->typePtr = NULL; } /* @@ -3533,33 +4219,33 @@ FreeCmdNameInternalRep(objPtr) * * DupCmdNameInternalRep -- * - * Initialize the internal representation of an cmdName Tcl_Obj to a - * copy of the internal representation of an existing cmdName object. + * Initialize the internal representation of an cmdName Tcl_Obj to a copy + * of the internal representation of an existing cmdName object. * * Results: * None. * * Side effects: * "copyPtr"s internal rep is set to point to the ResolvedCmdName - * structure corresponding to "srcPtr"s internal rep. Increments the - * ref count of the ResolvedCmdName structure pointed to by the - * cmdName's internal representation. + * structure corresponding to "srcPtr"s internal rep. Increments the ref + * count of the ResolvedCmdName structure pointed to by the cmdName's + * internal representation. * *---------------------------------------------------------------------- */ static void -DupCmdNameInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +DupCmdNameInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { - resPtr->refCount++; + resPtr->refCount++; } copyPtr->typePtr = &tclCmdNameType; } @@ -3577,22 +4263,21 @@ DupCmdNameInternalRep(srcPtr, copyPtr) * * Side effects: * A pointer to a ResolvedCmdName structure that holds a cached pointer - * to the command with a name that matches objPtr's string rep is - * stored as objPtr's internal representation. This ResolvedCmdName - * pointer will be NULL if no matching command was found. The ref count - * of the cached Command's structure (if any) is also incremented. + * to the command with a name that matches objPtr's string rep is stored + * as objPtr's internal representation. This ResolvedCmdName pointer will + * be NULL if no matching command was found. The ref count of the cached + * Command's structure (if any) is also incremented. * *---------------------------------------------------------------------- */ static int -SetCmdNameFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +SetCmdNameFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; char *name; - Tcl_Command cmd; register Command *cmdPtr; Namespace *currNsPtr; register ResolvedCmdName *resPtr; @@ -3602,15 +4287,6 @@ SetCmdNameFromAny(interp, objPtr) } /* - * Get "objPtr"s string representation. Make it up-to-date if necessary. - */ - - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); - } - - /* * Find the Command structure, if any, that describes the command called * "name". Build a ResolvedCmdName that holds a cached pointer to this * Command, and bump the reference count in the referenced Command @@ -3618,47 +4294,62 @@ SetCmdNameFromAny(interp, objPtr) * referenced from a CmdName object. */ - cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, - /*flags*/ 0); - cmdPtr = (Command *) cmd; - if (cmdPtr != NULL) { - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - - cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - } else { - resPtr = NULL; /* no command named "name" was found */ - } + name = TclGetString(objPtr); + cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular - * GetStringFromObj, to use that old internalRep. If no Command - * structure was found, leave NULL as the cached value. + * 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 ((objPtr->typePtr != NULL) - && (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); + 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 + */ + + 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; + } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + } else { + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } - - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; return TCL_OK; } @@ -3669,4 +4360,3 @@ SetCmdNameFromAny(interp, objPtr) * fill-column: 78 * End: */ - |