/* * tclObj.c -- * * This file contains Tcl object-related procedures 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclObj.c,v 1.81 2005/04/22 15:46:59 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Table of all object types. */ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* * Head of the list of free Tcl_Obj structs we maintain. */ Tcl_Obj *tclFreeObjList = NULL; /* * The object allocator is single threaded. This mutex is referenced * by the TclNewObj macro, however, so must be visible. */ #ifdef TCL_THREADS 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. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; #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. */ typedef struct ThreadSpecificData { Tcl_HashTable *objThreadMap; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #endif /* TCL_MEM_DEBUG && TCL_THREADS */ /* * 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) \ /* Invalidate the string rep first so we can use the bytes value \ * for our pointer chain. */ \ if (((objPtr)->bytes != NULL) \ && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ } \ /* Now 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 PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *CONST contextPtr = &pendingObjData #else Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *CONST contextPtr = (PendingObjData *) \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* * Prototypes for procedures defined later in this file: */ 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)); #ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif /* * 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)); /* * 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)); /* * 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 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ Tcl_ObjType tclBooleanType = { "boolean", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfBoolean, /* updateStringProc */ SetBooleanFromAny /* setFromAnyProc */ }; Tcl_ObjType tclDoubleType = { "double", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; Tcl_ObjType tclIntType = { "int", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; 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 */ UpdateStringOfWideInt, /* updateStringProc */ #endif /* TCL_WIDE_INT_IS_LONG */ SetWideIntFromAny /* 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 */ }; /* * 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. * * 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. */ static Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ (Tcl_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. */ 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). */ long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid * (e.g., it's possible that the cmd's * containing namespace was deleted and a * new one created at the same address). */ int refNsCmdEpoch; /* Value of the referencing namespace's * 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. */ } 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. * * Results: * None. * * Side effects: * Initializes the table of defined object types "typeTable" with * builtin object types defined in this file. * *------------------------------------------------------------------------- */ void TclInitObjSubsystem() { 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(&tclEnsembleCmdType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclLocalVarNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclLevelReferenceType); #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { int i; for (i=0 ; iname); if (hPtr != (Tcl_HashEntry *) NULL) { Tcl_DeleteHashEntry(hPtr); } /* * Now insert the new object type. */ hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); if (new) { Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * * 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. * * 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. * * Side effects: * 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. */ { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_ObjType *typePtr; int result; /* * This code assumes that types names do not contain embedded NULLs. */ Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); result = Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(typePtr->name, -1)); if (result == TCL_ERROR) { Tcl_MutexUnlock(&tableMutex); return result; } } Tcl_MutexUnlock(&tableMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetObjType -- * * This procedure 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_ObjType * Tcl_GetObjType(typeName) CONST char *typeName; /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); Tcl_MutexUnlock(&tableMutex); return typePtr; } Tcl_MutexUnlock(&tableMutex); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_ConvertToType -- * * Convert the Tcl object "objPtr" to have type "typePtr" if possible. * * 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). * * Side effects: * Any internal representation for the old type is freed. * *---------------------------------------------------------------------- */ 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. */ { 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 * representation. */ if (typePtr->setFromAnyProc == NULL) { Tcl_Panic("may not convert object to type %s", typePtr->name); } return typePtr->setFromAnyProc(interp, objPtr); } /* *---------------------------------------------------------------------- * * 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(objPtr) register Tcl_Obj *objPtr; { 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 new; 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, &new); if (!new) { Tcl_Panic("expected to create new entry for object map"); } Tcl_SetHashValue(hPtr, NULL); } # endif /* TCL_THREADS */ } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_NewObj -- * * This procedure 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. * * When TCL_MEM_DEBUG is defined, this procedure 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. * * Side effects: * If compiling with TCL_COMPILE_STATS, this procedure increments * the global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewObj Tcl_Obj * Tcl_NewObj() { return Tcl_DbNewObj("unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewObj() { register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the * correct allocator. */ TclNewObj(objPtr); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewObj -- * * This procedure 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 * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure 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. * * Side effects: * If compiling with TCL_COMPILE_STATS, this procedure increments * the global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #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. */ { register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the * correct allocator. */ TclDbNewObj(objPtr, file, line); return objPtr; } #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. */ { return Tcl_NewObj(); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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. * * Assumes mutex is held. * * Results: * None. * * 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. * *---------------------------------------------------------------------- */ #define OBJS_TO_ALLOC_EACH_TIME 100 void TclAllocateFreeObjects() { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; register Tcl_Obj *prevPtr, *objPtr; register int i; /* * 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. These never do get freed properly. */ 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; prevPtr = objPtr; objPtr++; } tclFreeObjList = prevPtr; } #undef OBJS_TO_ALLOC_EACH_TIME /* *---------------------------------------------------------------------- * * 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. * * 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). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... */ ObjInitDeletionContext(context); if (objPtr->refCount < -1) { Tcl_Panic("Reference count for %lx was negative", objPtr); } if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } Tcl_InvalidateStringRep(objPtr); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ } ObjDeletionUnlock(context); } } #else /* TCL_MEM_DEBUG */ void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { 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. */ if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objPtr->bytes); } 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. */ ObjDeletionLock(context); objPtr->typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objPtr->bytes); } TclFreeObjStorage(objPtr); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { objToFree->typePtr->freeIntRepProc(objToFree); } TclFreeObjStorage(objToFree); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } } } #endif /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument * 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: * 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. * 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. * * 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. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_DuplicateObj(objPtr) register Tcl_Obj *objPtr; /* The object to duplicate. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; register Tcl_Obj *dupPtr; TclNewObj(dupPtr); if (objPtr->bytes == NULL) { dupPtr->bytes = NULL; } else if (objPtr->bytes != tclEmptyStringRep) { TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); } if (typePtr != NULL) { if (typePtr->dupIntRepProc == NULL) { dupPtr->internalRep = objPtr->internalRep; dupPtr->typePtr = typePtr; } else { (*typePtr->dupIntRepProc)(objPtr, dupPtr); } } return dupPtr; } /* *---------------------------------------------------------------------- * * Tcl_GetString -- * * Returns the string representation byte array pointer for an object. * * Results: * Returns a pointer to the string representation of objPtr. 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 * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetString(objPtr) 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) { Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } (*objPtr->typePtr->updateStringProc)(objPtr); return objPtr->bytes; } /* *---------------------------------------------------------------------- * * Tcl_GetStringFromObj -- * * 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. * * Side effects: * May call the object's updateStringProc to update the string * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetStringFromObj(objPtr, lengthPtr) register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should * be returned. */ 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) { Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } (*objPtr->typePtr->updateStringProc)(objPtr); } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } return objPtr->bytes; } /* *---------------------------------------------------------------------- * * Tcl_InvalidateStringRep -- * * This procedure 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. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep(objPtr) register Tcl_Obj *objPtr; /* Object whose string rep byte pointer * should be freed. */ { TclInvalidateStringRep(objPtr); } /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new boolean object and * 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. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj Tcl_Obj * Tcl_NewBooleanObj(boolValue) register int boolValue; /* Boolean used to initialize new object. */ { return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewBooleanObj(boolValue) register int boolValue; /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; TclNewBooleanObj(objPtr, boolValue); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewBooleanObj -- * * This procedure 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 * 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 * result of calling Tcl_NewBooleanObj. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #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. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.longValue = (boolValue? 1 : 0); objPtr->typePtr = &tclBooleanType; 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. */ { return Tcl_NewBooleanObj(boolValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetBooleanObj -- * * Modify an object to be a boolean object and to have the specified * boolean value. A nonzero "boolValue" is coerced to 1. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old * internal rep is freed. * *---------------------------------------------------------------------- */ 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetBooleanObj called with shared object"); } TclSetBooleanObj(objPtr, boolValue); } /* *---------------------------------------------------------------------- * * Tcl_GetBooleanFromObj -- * * 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 * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * 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. */ { double d; long l; if (objPtr->typePtr == &tclBooleanType) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } /* * The following call retrieves a numeric value without shimmering * away any existing numeric intrep Tcl_ObjTypes. */ if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { *boolPtr = (d != 0.0); /* Attempt shimmer to "boolean" objType */ SetBooleanFromAny(NULL, objPtr); return TCL_OK; } /* * Value didn't already have a numeric intrep, but perhaps we can * generate one. Try a long value first... */ if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) { *boolPtr = (l != 0); return TCL_OK; } #ifndef TCL_WIDE_INT_IS_LONG else { Tcl_WideInt w; /* * ...then a wide. Check in that order so that we don't promote * anything to wide unnecessarily. */ if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) { *boolPtr = (w != 0); return TCL_OK; } } #endif /* * Finally, check for the string values like "yes" * and generate error message for non-boolean values. */ if (SetBooleanFromAny(interp, objPtr) == TCL_OK) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * SetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". * * Results: * The return value is a standard 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 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. */ { char *str, lowerCase[6]; int i, newBool, length; /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can * determine whether a boolean conversion is possible without * generating the string rep. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } if (objPtr->typePtr == &tclIntType) { long l = objPtr->internalRep.longValue; switch (l) { case 0: case 1: newBool = (int)l; goto goodBoolean; } goto badBoolean; } if (objPtr->typePtr == &tclWideIntType) { Tcl_WideInt w = objPtr->internalRep.wideValue; switch (w) { case 0: case 1: newBool = (int)w; goto goodBoolean; } goto badBoolean; } } /* * Parse the string as a boolean. We use an implementation here * that doesn't report errors in interp if interp is NULL. */ str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { /* longest valid boolean string rep. is "false" */ goto badBoolean; } switch (str[0]) { case '0': if (length == 1) { newBool = 0; goto goodBoolean; } goto badBoolean; case '1': if (length == 1) { newBool = 1; goto goodBoolean; } goto badBoolean; } /* * Force to lower case for case-insensitive detection. * Filter out known invalid characters at the same time. */ 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: goto badBoolean; } } lowerCase[length] = 0; switch (lowerCase[0]) { case 'y': /* * Checking the 'y' is redundant, but makes the code clearer. */ if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } goto badBoolean; case 'n': if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } goto badBoolean; case 't': if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } goto badBoolean; case 'f': if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } goto badBoolean; case 'o': if (length < 2) { goto badBoolean; } if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } goto badBoolean; default: goto badBoolean; } /* * 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: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; badBoolean: if (interp != NULL) { Tcl_Obj *msg = Tcl_NewStringObj("expected boolean value but got \"", -1); str = Tcl_GetStringFromObj(objPtr, &length); TclAppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } 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; } /* *---------------------------------------------------------------------- * * Tcl_NewDoubleObj -- * * This procedure 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. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj(dblValue) register double dblValue; /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewDoubleObj(dblValue) register double dblValue; /* Double used to initialize the object. */ { register Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewDoubleObj -- * * This procedure 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 * 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 * 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ #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. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; } #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. */ { return Tcl_NewDoubleObj(dblValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetDoubleObj -- * * Modify an object to be a double object and to have the specified * double value. * * Results: * None. * * Side effects: * 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetDoubleObj called with shared object"); } TclSetDoubleObj(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. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already 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. */ { register int result; if (objPtr->typePtr == &tclDoubleType) { *dblPtr = objPtr->internalRep.doubleValue; return TCL_OK; } else if (objPtr->typePtr == &tclIntType) { *dblPtr = objPtr->internalRep.longValue; return TCL_OK; } else if (objPtr->typePtr == &tclWideIntType) { *dblPtr = objPtr->internalRep.wideValue; return TCL_OK; } result = SetDoubleFromAny(interp, objPtr); if (result == TCL_OK) { *dblPtr = objPtr->internalRep.doubleValue; } return result; } /* *---------------------------------------------------------------------- * * SetDoubleFromAny -- * * Attempt to generate an double-precision floating point internal form * for the Tcl object "objPtr". * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If no error occurs, a double is stored as "objPtr"s internal * representation. * *---------------------------------------------------------------------- */ static int SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { 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) { Tcl_Obj *msg = Tcl_NewStringObj( "expected floating-point number but got \"", -1); TclAppendLimitedToObj(msg, string, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } 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; } if (errno != 0) { if (interp != NULL) { TclExprFloatError(interp, newDouble); } return TCL_ERROR; } /* * 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. */ TclFreeIntRep(objPtr); objPtr->internalRep.doubleValue = newDouble; objPtr->typePtr = &tclDoubleType; return TCL_OK; } /* *---------------------------------------------------------------------- * * 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 * 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 double-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfDouble(objPtr) 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); len = strlen(buffer); objPtr->bytes = (char *) ckalloc((unsigned) len + 1); strcpy(objPtr->bytes, buffer); objPtr->length = len; } /* *---------------------------------------------------------------------- * * Tcl_NewIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewIntObj to create a new integer object end up calling the * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two * Tcl_NewIntObj implementations below. We provide two implementations * so that the Tcl core can be compiled to do memory debugging of the * core even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by * an int. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewIntObj Tcl_Obj * Tcl_NewIntObj(intValue) register int intValue; /* Int used to initialize the new object. */ { return Tcl_DbNewLongObj((long)intValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewIntObj(intValue) register int intValue; /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetIntObj -- * * Modify an object to be an integer and to have the specified integer * value. * * Results: * None. * * Side effects: * 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetIntObj called with shared object"); } TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * * Attempt to return an int from the Tcl object "objPtr". If the object * is not already an int, an attempt will be made to convert it to one. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by * an int. * * Results: * The 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. * * Side effects: * 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. */ { 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. */ #ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { w = objPtr->internalRep.wideValue; } else #endif { w = Tcl_LongAsWide(objPtr->internalRep.longValue); } if ((LLONG_MAX > UINT_MAX) && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent as non-long integer", -1)); } return TCL_ERROR; } *intPtr = (int)w; return TCL_OK; } /* *---------------------------------------------------------------------- * * 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(interp, objPtr) 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) { CONST char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(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". * * 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. */ { char *string, *end; int length; register char *p; unsigned long newLong; int isNegative = 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. We parse the leading space and sign ourselves so * we can tell the difference between apparently positive and negative * values. */ errno = 0; for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { isNegative = 1; p++; } else if (*p == '+') { p++; } if (!isdigit(UCHAR(*p))) { badInteger: if (interp != NULL) { Tcl_Obj *msg = Tcl_NewStringObj("expected integer but got \"", -1); TclAppendLimitedToObj(msg, string, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); TclCheckBadOctal(interp, string); } return TCL_ERROR; } newLong = strtoul(p, &end, 0); if (end == p) { goto badInteger; } /* * 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 (errno == ERANGE) { if (interp != NULL) { CONST char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); } return TCL_ERROR; } /* * 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. */ TclFreeIntRep(objPtr); #ifndef TCL_WIDE_INT_IS_LONG /* * If the resulting integer will exceed the range of a long, * put it into a wide instead. (Tcl Bug #868489) */ if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) || (!isNegative && newLong > LONG_MAX)) { objPtr->internalRep.wideValue = (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); objPtr->typePtr = &tclWideIntType; } else #endif { objPtr->internalRep.longValue = (isNegative ? -(long)newLong : (long)newLong); objPtr->typePtr = &tclIntType; } return TCL_OK; } /* *---------------------------------------------------------------------- * * 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. * * Results: * None. * * Side effects: * 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. */ { 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; } /* *---------------------------------------------------------------------- * * 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. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewLongObj result in a call to one of the two * Tcl_NewLongObj implementations below. We provide two implementations * so that the Tcl core can be compiled to do memory debugging of the * core even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by * an int. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewLongObj Tcl_Obj * Tcl_NewLongObj(longValue) register long longValue; /* Long integer used to initialize the * new object. */ { return Tcl_DbNewLongObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewLongObj(longValue) register long longValue; /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. * * Results: * The newly created long integer object is returned. This object * will have an invalid string representation. The returned object has * ref count 0. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #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. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } #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. */ { return Tcl_NewLongObj(longValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetLongObj -- * * Modify an object to be an integer object and to have the specified * long integer value. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old * internal rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetLongObj(objPtr, longValue) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ register long longValue; /* Long integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetLongObj called with shared object"); } TclSetLongObj(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 * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already an int object, the conversion will free * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_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. */ { register int result; if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { result = SetIntOrWideFromAny(interp, objPtr); if (result != TCL_OK) { return result; } } #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. */ 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_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); } return TCL_ERROR; } } #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 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. */ errno = 0; newWide = strtoull(p, &end, 0); if (end == p) { badInteger: if (interp != NULL) { Tcl_Obj *msg = Tcl_NewStringObj("expected integer but got \"", -1); TclAppendLimitedToObj(msg, string, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); TclCheckBadOctal(interp, string); } 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 (errno == ERANGE) { if (interp != NULL) { CONST char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); } return TCL_ERROR; } /* * 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. */ TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = newWide; #else if (TCL_ERROR == SetIntFromAny(interp, objPtr)) { return TCL_ERROR; } #endif objPtr->typePtr = &tclWideIntType; return TCL_OK; } /* *---------------------------------------------------------------------- * * 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. * * Results: * None. * * Side effects: * 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. */ { char buffer[TCL_INTEGER_SPACE+2]; register unsigned len; register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* * Note that sprintf will generate a compiler warning under * Mingw claiming %I64 is an unknown format specifier. * Just ignore this warning. We can't use %L as the format * specifier since that gets printed as a 32 bit value. */ sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); objPtr->bytes = ckalloc((unsigned) len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } #endif /* TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- * * 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. * * 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. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj(wideValue) register Tcl_WideInt wideValue; /* Wide integer used to initialize * the new object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewWideIntObj(wideValue) register Tcl_WideInt wideValue; /* Wide integer used to initialize * the new object. */ { register Tcl_Obj *objPtr; TclNewWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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. * * 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. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure 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. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #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. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.wideValue = wideValue; objPtr->typePtr = &tclWideIntType; 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. */ { return Tcl_NewWideIntObj(wideValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetWideIntObj -- * * 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. * *---------------------------------------------------------------------- */ 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetWideIntObj called with shared object"); } TclSetWideIntObj(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. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already an int object, the conversion will free * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_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. */ { register int result; if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } result = SetWideIntFromAny(interp, objPtr); if (result == TCL_OK) { *wideIntPtr = objPtr->internalRep.wideValue; } return result; } /* *---------------------------------------------------------------------- * * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just increments * the reference count of the object. * * Results: * None. * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ 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. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to increment 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; } /* *---------------------------------------------------------------------- * * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just decrements * the reference count of the object. * * Results: * None. * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ void Tcl_DbDecrRefCount(objPtr, file, line) 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. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to decrement 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) { Tcl_DeleteHashEntry(hPtr); } } # endif #endif if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } } /* *---------------------------------------------------------------------- * * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just tests * if the object has a ref count greater than one. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to check 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) { tclObjsShared[1]++; } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { tclObjsShared[(objPtr)->refCount]++; } else { tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); #endif return ((objPtr)->refCount > 1); } /* *---------------------------------------------------------------------- * * Tcl_InitObjHashTable -- * * Given storage for a hash table, set up the fields to prepare * the hash table for use, the keys are Tcl_Obj *. * * Results: * None. * * Side effects: * TablePtr is now ready to be passed to Tcl_FindHashEntry and * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable(tablePtr) register Tcl_HashTable *tablePtr; /* Pointer to table record, which * is supplied by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); } /* *---------------------------------------------------------------------- * * AllocObjEntry -- * * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key. * * Results: * The return value is a pointer to the created entry. * * Side effects: * Increments the reference count on the object. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocObjEntry(tablePtr, keyPtr) 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); return hPtr; } /* *---------------------------------------------------------------------- * * CompareObjKeys -- * * Compares two Tcl_Obj * keys. * * Results: * The return value is 0 if they are different and 1 if they are * the same. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int CompareObjKeys(keyPtr, hPtr) 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; register CONST char *p1, *p2; register int l1, l2; /* * If the object pointers are the same then they match. */ if (objPtr1 == objPtr2) { return 1; } /* * 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) { break; } if (l1 == 0) { return 1; } } } return 0; } /* *---------------------------------------------------------------------- * * FreeObjEntry -- * * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. * * Results: * The return value is a pointer to the created entry. * * Side effects: * Decrements the reference count of the object. * *---------------------------------------------------------------------- */ static void FreeObjEntry(hPtr) Tcl_HashEntry *hPtr; /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); ckfree((char *) hPtr); } /* *---------------------------------------------------------------------- * * HashObjKey -- * * 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashObjKey(tablePtr, keyPtr) 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 = 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: * * 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. */ for (i=0 ; ivarFramePtr; 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. */ 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; } /* * 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 = 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; } /* *---------------------------------------------------------------------- * * TclSetCmdNameObj -- * * Modify an object to be an CmdName object that refers to the argument * Command structure. * * Results: * None. * * 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 * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ void TclSetCmdNameObj(interp, objPtr, cmdPtr) Tcl_Interp *interp; /* Points to interpreter containing command * that should be cached in objPtr. */ register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to * a CmdName object. */ Command *cmdPtr; /* Points to Command structure that the * CmdName object should refer to. */ { Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; CallFrame *savedFramePtr; char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } /* * 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] (Copied over from Tcl_GetCommandFromObj) */ savedFramePtr = iPtr->varFramePtr; name = Tcl_GetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = 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; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; iPtr->varFramePtr = savedFramePtr; } /* *---------------------------------------------------------------------- * * FreeCmdNameInternalRep -- * * Frees the resources associated with a cmdName object's internal * representation. * * Results: * None. * * 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. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep(objPtr) register Tcl_Obj *objPtr; /* CmdName object with internal * representation to free. */ { register ResolvedCmdName *resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. * If there are no more uses, free the ResolvedCmdName structure. */ 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); } } } /* *---------------------------------------------------------------------- * * DupCmdNameInternalRep -- * * 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. * *---------------------------------------------------------------------- */ static void DupCmdNameInternalRep(srcPtr, copyPtr) 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; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; } copyPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- * * SetCmdNameFromAny -- * * Generate an cmdName internal form for the Tcl object "objPtr". * * Results: * The return value is a standard Tcl result. The conversion always * succeeds and TCL_OK is returned. * * 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. * *---------------------------------------------------------------------- */ static int SetCmdNameFromAny(interp, objPtr) 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; /* * 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 * structure. A Command structure will not be deleted as long as it is * 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 */ } /* * 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. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; return TCL_OK; }