sl@0: /* sl@0: * tclObj.c -- sl@0: * sl@0: * This file contains Tcl object-related procedures that are used by sl@0: * many Tcl commands. sl@0: * sl@0: * Copyright (c) 1995-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1999 by Scriptics Corporation. sl@0: * Copyright (c) 2001 by ActiveState Corporation. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclObj.c,v 1.42.2.14 2005/11/29 14:02:04 dkf Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclCompile.h" sl@0: #include "tclPort.h" sl@0: #if defined(__SYMBIAN32__) sl@0: #include "tclSymbianGlobals.h" sl@0: #endif sl@0: sl@0: /* sl@0: * Table of all object types. sl@0: */ sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: static Tcl_HashTable typeTable; sl@0: static int typeTableInitialized = 0; /* 0 means not yet initialized. */ sl@0: #endif sl@0: TCL_DECLARE_MUTEX(tableMutex) sl@0: sl@0: /* sl@0: * Head of the list of free Tcl_Obj structs we maintain. sl@0: */ sl@0: sl@0: Tcl_Obj *tclFreeObjList = NULL; sl@0: sl@0: /* sl@0: * The object allocator is single threaded. This mutex is referenced sl@0: * by the TclNewObj macro, however, so must be visible. sl@0: */ sl@0: sl@0: #ifdef TCL_THREADS sl@0: Tcl_Mutex tclObjMutex; sl@0: #endif sl@0: sl@0: /* sl@0: * Pointer to a heap-allocated string of length zero that the Tcl core uses sl@0: * as the value of an empty string representation for an object. This value sl@0: * is shared by all new objects allocated by Tcl_NewObj. sl@0: */ sl@0: sl@0: char tclEmptyString = '\0'; sl@0: char *tclEmptyStringRep = &tclEmptyString; sl@0: sl@0: /* sl@0: * Prototypes for procedures defined later in this file: sl@0: */ sl@0: sl@0: static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp, sl@0: Tcl_Obj *objPtr)); sl@0: static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: #endif sl@0: sl@0: /* sl@0: * Prototypes for the array hash key methods. sl@0: */ sl@0: sl@0: static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( sl@0: Tcl_HashTable *tablePtr, VOID *keyPtr)); sl@0: static int CompareObjKeys _ANSI_ARGS_(( sl@0: VOID *keyPtr, Tcl_HashEntry *hPtr)); sl@0: static void FreeObjEntry _ANSI_ARGS_(( sl@0: Tcl_HashEntry *hPtr)); sl@0: static unsigned int HashObjKey _ANSI_ARGS_(( sl@0: Tcl_HashTable *tablePtr, sl@0: VOID *keyPtr)); sl@0: sl@0: /* sl@0: * Prototypes for the CommandName object type. sl@0: */ sl@0: sl@0: static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, sl@0: Tcl_Obj *copyPtr)); sl@0: static void FreeCmdNameInternalRep _ANSI_ARGS_(( sl@0: Tcl_Obj *objPtr)); sl@0: static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: sl@0: sl@0: /* sl@0: * The structures below defines the Tcl object types defined in this file by sl@0: * means of procedures that can be invoked by generic object code. See also sl@0: * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager sl@0: * implementations. sl@0: */ sl@0: sl@0: Tcl_ObjType tclBooleanType = { sl@0: "boolean", /* name */ sl@0: (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ sl@0: (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ sl@0: UpdateStringOfBoolean, /* updateStringProc */ sl@0: SetBooleanFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: Tcl_ObjType tclDoubleType = { sl@0: "double", /* name */ sl@0: (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ sl@0: (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ sl@0: UpdateStringOfDouble, /* updateStringProc */ sl@0: SetDoubleFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: Tcl_ObjType tclIntType = { sl@0: "int", /* name */ sl@0: (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ sl@0: (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ sl@0: UpdateStringOfInt, /* updateStringProc */ sl@0: SetIntFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: Tcl_ObjType tclWideIntType = { sl@0: "wideInt", /* name */ sl@0: (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ sl@0: (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ sl@0: #ifdef TCL_WIDE_INT_IS_LONG sl@0: UpdateStringOfInt, /* updateStringProc */ sl@0: #else /* !TCL_WIDE_INT_IS_LONG */ sl@0: UpdateStringOfWideInt, /* updateStringProc */ sl@0: #endif sl@0: SetWideIntFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: /* sl@0: * The structure below defines the Tcl obj hash key type. sl@0: */ sl@0: Tcl_HashKeyType tclObjHashKeyType = { sl@0: TCL_HASH_KEY_TYPE_VERSION, /* version */ sl@0: 0, /* flags */ sl@0: HashObjKey, /* hashKeyProc */ sl@0: CompareObjKeys, /* compareKeysProc */ sl@0: AllocObjEntry, /* allocEntryProc */ sl@0: FreeObjEntry /* freeEntryProc */ sl@0: }; sl@0: sl@0: /* sl@0: * The structure below defines the command name Tcl object type by means of sl@0: * procedures that can be invoked by generic object code. Objects of this sl@0: * type cache the Command pointer that results from looking up command names sl@0: * in the command hashtable. Such objects appear as the zeroth ("command sl@0: * name") argument in a Tcl command. sl@0: * sl@0: * NOTE: the ResolvedCmdName that gets cached is stored in the sl@0: * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. sl@0: * You might think you could use the simpler otherValuePtr field to sl@0: * store the single ResolvedCmdName pointer, but DO NOT DO THIS. It sl@0: * seems that some extensions use the second internal pointer field sl@0: * of the twoPtrValue field for their own purposes. sl@0: */ sl@0: sl@0: static Tcl_ObjType tclCmdNameType = { sl@0: "cmdName", /* name */ sl@0: FreeCmdNameInternalRep, /* freeIntRepProc */ sl@0: DupCmdNameInternalRep, /* dupIntRepProc */ sl@0: (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ sl@0: SetCmdNameFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: sl@0: /* sl@0: * Structure containing a cached pointer to a command that is the result sl@0: * of resolving the command's name in some namespace. It is the internal sl@0: * representation for a cmdName object. It contains the pointer along sl@0: * with some information that is used to check the pointer's validity. sl@0: */ sl@0: sl@0: typedef struct ResolvedCmdName { sl@0: Command *cmdPtr; /* A cached Command pointer. */ sl@0: Namespace *refNsPtr; /* Points to the namespace containing the sl@0: * reference (not the namespace that sl@0: * contains the referenced command). */ sl@0: long refNsId; /* refNsPtr's unique namespace id. Used to sl@0: * verify that refNsPtr is still valid sl@0: * (e.g., it's possible that the cmd's sl@0: * containing namespace was deleted and a sl@0: * new one created at the same address). */ sl@0: int refNsCmdEpoch; /* Value of the referencing namespace's sl@0: * cmdRefEpoch when the pointer was cached. sl@0: * Before using the cached pointer, we check sl@0: * if the namespace's epoch was incremented; sl@0: * if so, this cached pointer is invalid. */ sl@0: int cmdEpoch; /* Value of the command's cmdEpoch when this sl@0: * pointer was cached. Before using the sl@0: * cached pointer, we check if the cmd's sl@0: * epoch was incremented; if so, the cmd was sl@0: * renamed, deleted, hidden, or exposed, and sl@0: * so the pointer is invalid. */ sl@0: int refCount; /* Reference count: 1 for each cmdName sl@0: * object that has a pointer to this sl@0: * ResolvedCmdName structure as its internal sl@0: * rep. This structure can be freed when sl@0: * refCount becomes zero. */ sl@0: } ResolvedCmdName; sl@0: sl@0: sl@0: /* sl@0: *------------------------------------------------------------------------- sl@0: * sl@0: * TclInitObjectSubsystem -- sl@0: * sl@0: * This procedure is invoked to perform once-only initialization of sl@0: * the type table. It also registers the object types defined in sl@0: * this file. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Initializes the table of defined object types "typeTable" with sl@0: * builtin object types defined in this file. sl@0: * sl@0: *------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclInitObjSubsystem() sl@0: { sl@0: Tcl_MutexLock(&tableMutex); sl@0: typeTableInitialized = 1; sl@0: Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); sl@0: Tcl_MutexUnlock(&tableMutex); sl@0: sl@0: Tcl_RegisterObjType(&tclBooleanType); sl@0: Tcl_RegisterObjType(&tclByteArrayType); sl@0: Tcl_RegisterObjType(&tclDoubleType); sl@0: Tcl_RegisterObjType(&tclEndOffsetType); sl@0: Tcl_RegisterObjType(&tclIntType); sl@0: Tcl_RegisterObjType(&tclWideIntType); sl@0: Tcl_RegisterObjType(&tclStringType); sl@0: Tcl_RegisterObjType(&tclListType); sl@0: Tcl_RegisterObjType(&tclByteCodeType); sl@0: Tcl_RegisterObjType(&tclProcBodyType); sl@0: Tcl_RegisterObjType(&tclArraySearchType); sl@0: Tcl_RegisterObjType(&tclIndexType); sl@0: Tcl_RegisterObjType(&tclNsNameType); sl@0: Tcl_RegisterObjType(&tclCmdNameType); sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: Tcl_MutexLock(&tclObjMutex); sl@0: tclObjsAlloced = 0; sl@0: tclObjsFreed = 0; sl@0: { sl@0: int i; sl@0: for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) { sl@0: tclObjsShared[i] = 0; sl@0: } sl@0: } sl@0: Tcl_MutexUnlock(&tclObjMutex); sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFinalizeObjects -- sl@0: * sl@0: * This procedure is called by Tcl_Finalize to clean up all sl@0: * registered Tcl_ObjType's and to reset the tclFreeObjList. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclFinalizeObjects() sl@0: { sl@0: Tcl_MutexLock(&tableMutex); sl@0: if (typeTableInitialized) { sl@0: Tcl_DeleteHashTable(&typeTable); sl@0: typeTableInitialized = 0; sl@0: } sl@0: Tcl_MutexUnlock(&tableMutex); sl@0: sl@0: /* sl@0: * All we do here is reset the head pointer of the linked list of sl@0: * free Tcl_Obj's to NULL; the memory finalization will take care sl@0: * of releasing memory for us. sl@0: */ sl@0: Tcl_MutexLock(&tclObjMutex); sl@0: tclFreeObjList = NULL; sl@0: Tcl_MutexUnlock(&tclObjMutex); sl@0: } sl@0: sl@0: /* sl@0: *-------------------------------------------------------------- sl@0: * sl@0: * Tcl_RegisterObjType -- sl@0: * sl@0: * This procedure is called to register a new Tcl object type sl@0: * in the table of all object types supported by Tcl. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The type is registered in the Tcl type table. If there was already sl@0: * a type with the same name as in typePtr, it is replaced with the sl@0: * new type. sl@0: * sl@0: *-------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_RegisterObjType(typePtr) sl@0: Tcl_ObjType *typePtr; /* Information about object type; sl@0: * storage must be statically sl@0: * allocated (must live forever). */ sl@0: { sl@0: int new; sl@0: Tcl_MutexLock(&tableMutex); sl@0: Tcl_SetHashValue( sl@0: Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr); sl@0: Tcl_MutexUnlock(&tableMutex); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendAllObjTypes -- sl@0: * sl@0: * This procedure appends onto the argument object the name of each sl@0: * object type as a list element. This includes the builtin object sl@0: * types (e.g. int, list) as well as those added using sl@0: * Tcl_NewObj. These names can be used, for example, with sl@0: * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType sl@0: * structures. sl@0: * sl@0: * Results: sl@0: * The return value is normally TCL_OK; in this case the object sl@0: * referenced by objPtr has each type name appended to it. If an sl@0: * error occurs, TCL_ERROR is returned and the interpreter's result sl@0: * holds an error message. sl@0: * sl@0: * Side effects: sl@0: * If necessary, the object referenced by objPtr is converted into sl@0: * a list object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_AppendAllObjTypes(interp, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter used for error reporting. */ sl@0: Tcl_Obj *objPtr; /* Points to the Tcl object onto which the sl@0: * name of each registered type is appended sl@0: * as a list element. */ sl@0: { sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch search; sl@0: int objc; sl@0: Tcl_Obj **objv; sl@0: sl@0: /* sl@0: * Get the test for a valid list out of the way first. sl@0: */ sl@0: sl@0: if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Type names are NUL-terminated, not counted strings. sl@0: * This code relies on that. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&tableMutex); sl@0: for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: Tcl_ListObjAppendElement(NULL, objPtr, sl@0: Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); sl@0: } sl@0: Tcl_MutexUnlock(&tableMutex); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetObjType -- sl@0: * sl@0: * This procedure looks up an object type by name. sl@0: * sl@0: * Results: sl@0: * If an object type with name matching "typeName" is found, a pointer sl@0: * to its Tcl_ObjType structure is returned; otherwise, NULL is sl@0: * returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_ObjType * sl@0: Tcl_GetObjType(typeName) sl@0: CONST char *typeName; /* Name of Tcl object type to look up. */ sl@0: { sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_ObjType *typePtr = NULL; sl@0: sl@0: Tcl_MutexLock(&tableMutex); sl@0: hPtr = Tcl_FindHashEntry(&typeTable, typeName); sl@0: if (hPtr != (Tcl_HashEntry *) NULL) { sl@0: typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: Tcl_MutexUnlock(&tableMutex); sl@0: return typePtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ConvertToType -- sl@0: * sl@0: * Convert the Tcl object "objPtr" to have type "typePtr" if possible. sl@0: * sl@0: * Results: sl@0: * The return value is TCL_OK on success and TCL_ERROR on failure. If sl@0: * TCL_ERROR is returned, then the interpreter's result contains an sl@0: * error message unless "interp" is NULL. Passing a NULL "interp" sl@0: * allows this procedure to be used as a test whether the conversion sl@0: * could be done (and in fact was done). sl@0: * sl@0: * Side effects: sl@0: * Any internal representation for the old type is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ConvertToType(interp, objPtr, typePtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: Tcl_Obj *objPtr; /* The object to convert. */ sl@0: Tcl_ObjType *typePtr; /* The target type. */ sl@0: { sl@0: if (objPtr->typePtr == typePtr) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal sl@0: * form as appropriate for the target type. This frees the old internal sl@0: * representation. sl@0: */ sl@0: sl@0: return typePtr->setFromAnyProc(interp, objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewObj -- sl@0: * sl@0: * This procedure is normally called when not debugging: i.e., when sl@0: * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote sl@0: * the empty string. These objects have a NULL object type and NULL sl@0: * string representation byte pointer. Type managers call this routine sl@0: * to allocate new objects that they further initialize. sl@0: * sl@0: * When TCL_MEM_DEBUG is defined, this procedure just returns the sl@0: * result of calling the debugging version Tcl_DbNewObj. sl@0: * sl@0: * Results: sl@0: * The result is a newly allocated object that represents the empty sl@0: * string. The new object's typePtr is set NULL and its ref count sl@0: * is set to 0. sl@0: * sl@0: * Side effects: sl@0: * If compiling with TCL_COMPILE_STATS, this procedure increments sl@0: * the global count of allocated objects (tclObjsAlloced). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewObj() sl@0: { sl@0: return Tcl_DbNewObj("unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewObj() sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: /* sl@0: * Use the macro defined in tclInt.h - it will use the sl@0: * correct allocator. sl@0: */ sl@0: sl@0: TclNewObj(objPtr); sl@0: return objPtr; sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewObj -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the sl@0: * empty string. It is the same as the Tcl_NewObj procedure above sl@0: * except that it calls Tcl_DbCkalloc directly with the file name and sl@0: * line number from its caller. This simplifies debugging since then sl@0: * the [memory active] command will report the correct file name and line sl@0: * number when reporting objects that haven't been freed. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just returns the sl@0: * result of calling Tcl_NewObj. sl@0: * sl@0: * Results: sl@0: * The result is a newly allocated that represents the empty string. sl@0: * The new object's typePtr is set NULL and its ref count is set to 0. sl@0: * sl@0: * Side effects: sl@0: * If compiling with TCL_COMPILE_STATS, this procedure increments sl@0: * the global count of allocated objects (tclObjsAlloced). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewObj(file, line) sl@0: register CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: register int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: /* sl@0: * Use the macro defined in tclInt.h - it will use the sl@0: * correct allocator. sl@0: */ sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: return objPtr; sl@0: } sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewObj(file, line) sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: return Tcl_NewObj(); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclAllocateFreeObjects -- sl@0: * sl@0: * Procedure to allocate a number of free Tcl_Objs. This is done using sl@0: * a single ckalloc to reduce the overhead for Tcl_Obj allocation. sl@0: * sl@0: * Assumes mutex is held. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the sl@0: * first of a number of free Tcl_Obj's linked together by their sl@0: * internalRep.otherValuePtrs. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #define OBJS_TO_ALLOC_EACH_TIME 100 sl@0: sl@0: void sl@0: TclAllocateFreeObjects() sl@0: { sl@0: size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); sl@0: char *basePtr; sl@0: register Tcl_Obj *prevPtr, *objPtr; sl@0: register int i; sl@0: sl@0: /* sl@0: * This has been noted by Purify to be a potential leak. The problem is sl@0: * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated sl@0: * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of sl@0: * actually freeing the memory. TclFinalizeObjects() does not ckfree() sl@0: * this memory, but leaves it to Tcl's memory subsystem finalziation to sl@0: * release it. Purify apparently can't figure that out, and fires a sl@0: * false alarm. sl@0: */ sl@0: sl@0: basePtr = (char *) ckalloc(bytesToAlloc); sl@0: memset(basePtr, 0, bytesToAlloc); sl@0: sl@0: prevPtr = NULL; sl@0: objPtr = (Tcl_Obj *) basePtr; sl@0: for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { sl@0: objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; sl@0: prevPtr = objPtr; sl@0: objPtr++; sl@0: } sl@0: tclFreeObjList = prevPtr; sl@0: } sl@0: #undef OBJS_TO_ALLOC_EACH_TIME sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFreeObj -- sl@0: * sl@0: * This procedure frees the memory associated with the argument sl@0: * object. It is called by the tcl.h macro Tcl_DecrRefCount when an sl@0: * object's ref count is zero. It is only "public" since it must sl@0: * be callable by that macro wherever the macro is used. It should not sl@0: * be directly called by clients. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Deallocates the storage for the object's Tcl_Obj structure sl@0: * after deallocating the string representation and calling the sl@0: * type-specific Tcl_FreeInternalRepProc to deallocate the object's sl@0: * internal representation. If compiling with TCL_COMPILE_STATS, sl@0: * this procedure increments the global count of freed objects sl@0: * (tclObjsFreed). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: TclFreeObj(objPtr) sl@0: register Tcl_Obj *objPtr; /* The object to be freed. */ sl@0: { sl@0: register Tcl_ObjType *typePtr = objPtr->typePtr; sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: if ((objPtr)->refCount < -1) { sl@0: panic("Reference count for %lx was negative", objPtr); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { sl@0: typePtr->freeIntRepProc(objPtr); sl@0: } sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: sl@0: /* sl@0: * If debugging Tcl's memory usage, deallocate the object using ckfree. sl@0: * Otherwise, deallocate it by adding it onto the list of free sl@0: * Tcl_Obj structs we maintain. sl@0: */ sl@0: sl@0: #if defined(TCL_MEM_DEBUG) || defined(PURIFY) sl@0: Tcl_MutexLock(&tclObjMutex); sl@0: ckfree((char *) objPtr); sl@0: Tcl_MutexUnlock(&tclObjMutex); sl@0: #elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) sl@0: TclThreadFreeObj(objPtr); sl@0: #else sl@0: Tcl_MutexLock(&tclObjMutex); sl@0: objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; sl@0: tclFreeObjList = objPtr; sl@0: Tcl_MutexUnlock(&tclObjMutex); sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: tclObjsFreed++; sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DuplicateObj -- sl@0: * sl@0: * Create and return a new object that is a duplicate of the argument sl@0: * object. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to a newly created Tcl_Obj. This sl@0: * object has reference count 0 and the same type, if any, as the sl@0: * source object objPtr. Also: sl@0: * 1) If the source object has a valid string rep, we copy it; sl@0: * otherwise, the duplicate's string rep is set NULL to mark sl@0: * it invalid. sl@0: * 2) If the source object has an internal representation (i.e. its sl@0: * typePtr is non-NULL), the new object's internal rep is set to sl@0: * a copy; otherwise the new internal rep is marked invalid. sl@0: * sl@0: * Side effects: sl@0: * What constitutes "copying" the internal representation depends on sl@0: * the type. For example, if the argument object is a list, sl@0: * the element objects it points to will not actually be copied but sl@0: * will be shared with the duplicate list. That is, the ref counts of sl@0: * the element objects will be incremented. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DuplicateObj(objPtr) sl@0: register Tcl_Obj *objPtr; /* The object to duplicate. */ sl@0: { sl@0: register Tcl_ObjType *typePtr = objPtr->typePtr; sl@0: register Tcl_Obj *dupPtr; sl@0: sl@0: TclNewObj(dupPtr); sl@0: sl@0: if (objPtr->bytes == NULL) { sl@0: dupPtr->bytes = NULL; sl@0: } else if (objPtr->bytes != tclEmptyStringRep) { sl@0: TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); sl@0: } sl@0: sl@0: if (typePtr != NULL) { sl@0: if (typePtr->dupIntRepProc == NULL) { sl@0: dupPtr->internalRep = objPtr->internalRep; sl@0: dupPtr->typePtr = typePtr; sl@0: } else { sl@0: (*typePtr->dupIntRepProc)(objPtr, dupPtr); sl@0: } sl@0: } sl@0: return dupPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetString -- sl@0: * sl@0: * Returns the string representation byte array pointer for an object. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the string representation of objPtr. The byte sl@0: * array referenced by the returned pointer must not be modified by the sl@0: * caller. Furthermore, the caller must copy the bytes if they need to sl@0: * retain them since the object's string rep can change as a result of sl@0: * other operations. sl@0: * sl@0: * Side effects: sl@0: * May call the object's updateStringProc to update the string sl@0: * representation from the internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_GetString(objPtr) sl@0: register Tcl_Obj *objPtr; /* Object whose string rep byte pointer sl@0: * should be returned. */ sl@0: { sl@0: if (objPtr->bytes != NULL) { sl@0: return objPtr->bytes; sl@0: } sl@0: sl@0: if (objPtr->typePtr->updateStringProc == NULL) { sl@0: panic("UpdateStringProc should not be invoked for type %s", sl@0: objPtr->typePtr->name); sl@0: } sl@0: (*objPtr->typePtr->updateStringProc)(objPtr); sl@0: return objPtr->bytes; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetStringFromObj -- sl@0: * sl@0: * Returns the string representation's byte array pointer and length sl@0: * for an object. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the string representation of objPtr. If sl@0: * lengthPtr isn't NULL, the length of the string representation is sl@0: * stored at *lengthPtr. The byte array referenced by the returned sl@0: * pointer must not be modified by the caller. Furthermore, the sl@0: * caller must copy the bytes if they need to retain them since the sl@0: * object's string rep can change as a result of other operations. sl@0: * sl@0: * Side effects: sl@0: * May call the object's updateStringProc to update the string sl@0: * representation from the internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_GetStringFromObj(objPtr, lengthPtr) sl@0: register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should sl@0: * be returned. */ sl@0: register int *lengthPtr; /* If non-NULL, the location where the string sl@0: * rep's byte array length should * be stored. sl@0: * If NULL, no length is stored. */ sl@0: { sl@0: if (objPtr->bytes == NULL) { sl@0: if (objPtr->typePtr->updateStringProc == NULL) { sl@0: panic("UpdateStringProc should not be invoked for type %s", sl@0: objPtr->typePtr->name); sl@0: } sl@0: (*objPtr->typePtr->updateStringProc)(objPtr); sl@0: } sl@0: sl@0: if (lengthPtr != NULL) { sl@0: *lengthPtr = objPtr->length; sl@0: } sl@0: return objPtr->bytes; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_InvalidateStringRep -- sl@0: * sl@0: * This procedure is called to invalidate an object's string sl@0: * representation. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Deallocates the storage for any old string representation, then sl@0: * sets the string representation NULL to mark it invalid. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_InvalidateStringRep(objPtr) sl@0: register Tcl_Obj *objPtr; /* Object whose string rep byte pointer sl@0: * should be freed. */ sl@0: { sl@0: if (objPtr->bytes != NULL) { sl@0: if (objPtr->bytes != tclEmptyStringRep) { sl@0: ckfree((char *) objPtr->bytes); sl@0: } sl@0: objPtr->bytes = NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewBooleanObj -- sl@0: * sl@0: * This procedure is normally called when not debugging: i.e., when sl@0: * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and sl@0: * initializes it from the argument boolean value. A nonzero sl@0: * "boolValue" is coerced to 1. sl@0: * sl@0: * When TCL_MEM_DEBUG is defined, this procedure just returns the sl@0: * result of calling the debugging version Tcl_DbNewBooleanObj. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewBooleanObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewBooleanObj(boolValue) sl@0: register int boolValue; /* Boolean used to initialize new object. */ sl@0: { sl@0: return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewBooleanObj(boolValue) sl@0: register int boolValue; /* Boolean used to initialize new object. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.longValue = (boolValue? 1 : 0); sl@0: objPtr->typePtr = &tclBooleanType; sl@0: return objPtr; sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewBooleanObj -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the sl@0: * same as the Tcl_NewBooleanObj procedure above except that it calls sl@0: * Tcl_DbCkalloc directly with the file name and line number from its sl@0: * caller. This simplifies debugging since then the [memory active] sl@0: * command will report the correct file name and line number when sl@0: * reporting objects that haven't been freed. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just returns the sl@0: * result of calling Tcl_NewBooleanObj. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewBooleanObj(boolValue, file, line) sl@0: register int boolValue; /* Boolean used to initialize new object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.longValue = (boolValue? 1 : 0); sl@0: objPtr->typePtr = &tclBooleanType; sl@0: return objPtr; sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewBooleanObj(boolValue, file, line) sl@0: register int boolValue; /* Boolean used to initialize new object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: return Tcl_NewBooleanObj(boolValue); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetBooleanObj -- sl@0: * sl@0: * Modify an object to be a boolean object and to have the specified sl@0: * boolean value. A nonzero "boolValue" is coerced to 1. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep, if any, is freed. Also, any old sl@0: * internal rep is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetBooleanObj(objPtr, boolValue) sl@0: register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ sl@0: register int boolValue; /* Boolean used to set object's value. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetBooleanObj called with shared object"); sl@0: } sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.longValue = (boolValue? 1 : 0); sl@0: objPtr->typePtr = &tclBooleanType; sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetBooleanFromObj -- sl@0: * sl@0: * Attempt to return a boolean from the Tcl object "objPtr". If the sl@0: * object is not already a boolean, an attempt will be made to convert sl@0: * it to one. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If the object is not already a boolean, the conversion will free sl@0: * any old internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object from which to get boolean. */ sl@0: register int *boolPtr; /* Place to store resulting boolean. */ sl@0: { sl@0: register int result; sl@0: sl@0: if (objPtr->typePtr == &tclBooleanType) { sl@0: result = TCL_OK; sl@0: } else { sl@0: result = SetBooleanFromAny(interp, objPtr); sl@0: } sl@0: sl@0: if (result == TCL_OK) { sl@0: *boolPtr = (int) objPtr->internalRep.longValue; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetBooleanFromAny -- sl@0: * sl@0: * Attempt to generate a boolean internal form for the Tcl object sl@0: * "objPtr". sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl result. If an error occurs during sl@0: * conversion, an error message is left in the interpreter's result sl@0: * unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s sl@0: * internal representation and the type of "objPtr" is set to boolean. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetBooleanFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: char *string, *end; sl@0: register char c; sl@0: char lowerCase[10]; sl@0: int newBool, length; sl@0: register int i; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: string = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: /* sl@0: * Use the obvious shortcuts for numerical values; if objPtr is not sl@0: * of numerical type, parse its string rep. sl@0: */ sl@0: sl@0: if (objPtr->typePtr == &tclIntType) { sl@0: newBool = (objPtr->internalRep.longValue != 0); sl@0: } else if (objPtr->typePtr == &tclDoubleType) { sl@0: newBool = (objPtr->internalRep.doubleValue != 0.0); sl@0: } else if (objPtr->typePtr == &tclWideIntType) { sl@0: newBool = (objPtr->internalRep.wideValue != 0); sl@0: } else { sl@0: /* sl@0: * Copy the string converting its characters to lower case. sl@0: */ sl@0: sl@0: for (i = 0; (i < 9) && (i < length); i++) { sl@0: c = string[i]; sl@0: /* sl@0: * Weed out international characters so we can safely operate sl@0: * on single bytes. sl@0: */ sl@0: sl@0: if (c & 0x80) { sl@0: goto badBoolean; sl@0: } sl@0: if (Tcl_UniCharIsUpper(UCHAR(c))) { sl@0: c = (char) Tcl_UniCharToLower(UCHAR(c)); sl@0: } sl@0: lowerCase[i] = c; sl@0: } sl@0: lowerCase[i] = 0; sl@0: sl@0: /* sl@0: * Parse the string as a boolean. We use an implementation here that sl@0: * doesn't report errors in interp if interp is NULL. sl@0: */ sl@0: sl@0: c = lowerCase[0]; sl@0: if ((c == '0') && (lowerCase[1] == '\0')) { sl@0: newBool = 0; sl@0: } else if ((c == '1') && (lowerCase[1] == '\0')) { sl@0: newBool = 1; sl@0: } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { sl@0: newBool = 1; sl@0: } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { sl@0: newBool = 0; sl@0: } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { sl@0: newBool = 1; sl@0: } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { sl@0: newBool = 0; sl@0: } else if ((c == 'o') && (length >= 2)) { sl@0: if (strncmp(lowerCase, "on", (size_t) length) == 0) { sl@0: newBool = 1; sl@0: } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { sl@0: newBool = 0; sl@0: } else { sl@0: goto badBoolean; sl@0: } sl@0: } else { sl@0: double dbl; sl@0: /* sl@0: * Boolean values can be extracted from ints or doubles. Note sl@0: * that we don't use strtoul or strtoull here because we don't sl@0: * care about what the value is, just whether it is equal to sl@0: * zero or not. sl@0: */ sl@0: #ifdef TCL_WIDE_INT_IS_LONG sl@0: newBool = strtol(string, &end, 0); sl@0: if (end != string) { sl@0: /* sl@0: * Make sure the string has no garbage after the end of sl@0: * the int. sl@0: */ sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO only */ sl@0: end++; sl@0: } sl@0: if (end == (string+length)) { sl@0: newBool = (newBool != 0); sl@0: goto goodBoolean; sl@0: } sl@0: } sl@0: #else /* !TCL_WIDE_INT_IS_LONG */ sl@0: Tcl_WideInt wide = strtoll(string, &end, 0); sl@0: if (end != string) { sl@0: /* sl@0: * Make sure the string has no garbage after the end of sl@0: * the wide int. sl@0: */ sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO only */ sl@0: end++; sl@0: } sl@0: if (end == (string+length)) { sl@0: newBool = (wide != Tcl_LongAsWide(0)); sl@0: goto goodBoolean; sl@0: } sl@0: } sl@0: #endif /* TCL_WIDE_INT_IS_LONG */ sl@0: /* sl@0: * Still might be a string containing the characters representing an sl@0: * int or double that wasn't handled above. This would be a string sl@0: * like "27" or "1.0" that is non-zero and not "1". Such a string sl@0: * would result in the boolean value true. We try converting to sl@0: * double. If that succeeds and the resulting double is non-zero, we sl@0: * have a "true". Note that numbers can't have embedded NULLs. sl@0: */ sl@0: sl@0: dbl = strtod(string, &end); sl@0: if (end == string) { sl@0: goto badBoolean; sl@0: } sl@0: sl@0: /* sl@0: * Make sure the string has no garbage after the end of the double. sl@0: */ sl@0: sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO only */ sl@0: end++; sl@0: } sl@0: if (end != (string+length)) { sl@0: goto badBoolean; sl@0: } sl@0: newBool = (dbl != 0.0); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Free the old internalRep before setting the new one. We do this as sl@0: * late as possible to allow the conversion code, in particular sl@0: * Tcl_GetStringFromObj, to use that old internalRep. sl@0: */ sl@0: sl@0: goodBoolean: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.longValue = newBool; sl@0: objPtr->typePtr = &tclBooleanType; sl@0: return TCL_OK; sl@0: sl@0: badBoolean: sl@0: if (interp != NULL) { sl@0: /* sl@0: * Must copy string before resetting the result in case a caller sl@0: * is trying to convert the interpreter's result to a boolean. sl@0: */ sl@0: sl@0: char buf[100]; sl@0: sprintf(buf, "expected boolean value but got \"%.50s\"", string); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfBoolean -- sl@0: * sl@0: * Update the string representation for a boolean object. sl@0: * Note: This procedure does not free an existing old string rep sl@0: * so storage will be lost if this has not already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a valid string that results from sl@0: * the boolean-to-string conversion. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfBoolean(objPtr) sl@0: register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ sl@0: { sl@0: char *s = ckalloc((unsigned) 2); sl@0: sl@0: s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); sl@0: s[1] = '\0'; sl@0: objPtr->bytes = s; sl@0: objPtr->length = 1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewDoubleObj -- sl@0: * sl@0: * This procedure is normally called when not debugging: i.e., when sl@0: * TCL_MEM_DEBUG is not defined. It creates a new double object and sl@0: * initializes it from the argument double value. sl@0: * sl@0: * When TCL_MEM_DEBUG is defined, this procedure just returns the sl@0: * result of calling the debugging version Tcl_DbNewDoubleObj. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewDoubleObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewDoubleObj(dblValue) sl@0: register double dblValue; /* Double used to initialize the object. */ sl@0: { sl@0: return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewDoubleObj(dblValue) sl@0: register double dblValue; /* Double used to initialize the object. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.doubleValue = dblValue; sl@0: objPtr->typePtr = &tclDoubleType; sl@0: return objPtr; sl@0: } sl@0: #endif /* if TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewDoubleObj -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. It creates new double objects. It is the sl@0: * same as the Tcl_NewDoubleObj procedure above except that it calls sl@0: * Tcl_DbCkalloc directly with the file name and line number from its sl@0: * caller. This simplifies debugging since then the [memory active] sl@0: * command will report the correct file name and line number when sl@0: * reporting objects that haven't been freed. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just returns the sl@0: * result of calling Tcl_NewDoubleObj. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewDoubleObj(dblValue, file, line) sl@0: register double dblValue; /* Double used to initialize the object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.doubleValue = dblValue; sl@0: objPtr->typePtr = &tclDoubleType; sl@0: return objPtr; sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewDoubleObj(dblValue, file, line) sl@0: register double dblValue; /* Double used to initialize the object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: return Tcl_NewDoubleObj(dblValue); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetDoubleObj -- sl@0: * sl@0: * Modify an object to be a double object and to have the specified sl@0: * double value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep, if any, is freed. Also, any old sl@0: * internal rep is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetDoubleObj(objPtr, dblValue) sl@0: register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ sl@0: register double dblValue; /* Double used to set the object's value. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetDoubleObj called with shared object"); sl@0: } sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.doubleValue = dblValue; sl@0: objPtr->typePtr = &tclDoubleType; sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetDoubleFromObj -- sl@0: * sl@0: * Attempt to return a double from the Tcl object "objPtr". If the sl@0: * object is not already a double, an attempt will be made to convert sl@0: * it to one. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If the object is not already a double, the conversion will free sl@0: * any old internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object from which to get a double. */ sl@0: register double *dblPtr; /* Place to store resulting double. */ sl@0: { sl@0: register int result; sl@0: sl@0: if (objPtr->typePtr == &tclDoubleType) { sl@0: *dblPtr = objPtr->internalRep.doubleValue; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: result = SetDoubleFromAny(interp, objPtr); sl@0: if (result == TCL_OK) { sl@0: *dblPtr = objPtr->internalRep.doubleValue; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetDoubleFromAny -- sl@0: * sl@0: * Attempt to generate an double-precision floating point internal form sl@0: * for the Tcl object "objPtr". sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If no error occurs, a double is stored as "objPtr"s internal sl@0: * representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetDoubleFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: char *string, *end; sl@0: double newDouble; sl@0: int length; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: string = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: /* sl@0: * Now parse "objPtr"s string as an double. Numbers can't have embedded sl@0: * NULLs. We use an implementation here that doesn't report errors in sl@0: * interp if interp is NULL. sl@0: */ sl@0: sl@0: errno = 0; sl@0: newDouble = strtod(string, &end); sl@0: if (end == string) { sl@0: badDouble: sl@0: if (interp != NULL) { sl@0: /* sl@0: * Must copy string before resetting the result in case a caller sl@0: * is trying to convert the interpreter's result to an int. sl@0: */ sl@0: sl@0: char buf[100]; sl@0: sprintf(buf, "expected floating-point number but got \"%.50s\"", sl@0: string); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: if (errno != 0) { sl@0: if (interp != NULL) { sl@0: TclExprFloatError(interp, newDouble); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure that the string has no garbage after the end of the double. sl@0: */ sl@0: sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO space. */ sl@0: end++; sl@0: } sl@0: if (end != (string+length)) { sl@0: goto badDouble; sl@0: } sl@0: sl@0: /* sl@0: * The conversion to double succeeded. Free the old internalRep before sl@0: * setting the new one. We do this as late as possible to allow the sl@0: * conversion code, in particular Tcl_GetStringFromObj, to use that old sl@0: * internalRep. sl@0: */ sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.doubleValue = newDouble; sl@0: objPtr->typePtr = &tclDoubleType; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfDouble -- sl@0: * sl@0: * Update the string representation for a double-precision floating sl@0: * point object. This must obey the current tcl_precision value for sl@0: * double-to-string conversions. Note: This procedure does not free an sl@0: * existing old string rep so storage will be lost if this has not sl@0: * already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a valid string that results from sl@0: * the double-to-string conversion. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfDouble(objPtr) sl@0: register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ sl@0: { sl@0: char buffer[TCL_DOUBLE_SPACE]; sl@0: register int len; sl@0: sl@0: Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, sl@0: buffer); sl@0: len = strlen(buffer); sl@0: sl@0: objPtr->bytes = (char *) ckalloc((unsigned) len + 1); sl@0: strcpy(objPtr->bytes, buffer); sl@0: objPtr->length = len; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewIntObj -- sl@0: * sl@0: * If a client is compiled with TCL_MEM_DEBUG defined, calls to sl@0: * Tcl_NewIntObj to create a new integer object end up calling the sl@0: * debugging procedure Tcl_DbNewLongObj instead. sl@0: * sl@0: * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, sl@0: * calls to Tcl_NewIntObj result in a call to one of the two sl@0: * Tcl_NewIntObj implementations below. We provide two implementations sl@0: * so that the Tcl core can be compiled to do memory debugging of the sl@0: * core even if a client does not request it for itself. sl@0: * sl@0: * Integer and long integer objects share the same "integer" type sl@0: * implementation. We store all integers as longs and Tcl_GetIntFromObj sl@0: * checks whether the current value of the long can be represented by sl@0: * an int. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewIntObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewIntObj(intValue) sl@0: register int intValue; /* Int used to initialize the new object. */ sl@0: { sl@0: return Tcl_DbNewLongObj((long)intValue, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewIntObj(intValue) sl@0: register int intValue; /* Int used to initialize the new object. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.longValue = (long)intValue; sl@0: objPtr->typePtr = &tclIntType; sl@0: return objPtr; sl@0: } sl@0: #endif /* if TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetIntObj -- sl@0: * sl@0: * Modify an object to be an integer and to have the specified integer sl@0: * value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep, if any, is freed. Also, any old sl@0: * internal rep is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetIntObj(objPtr, intValue) sl@0: register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ sl@0: register int intValue; /* Integer used to set object's value. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetIntObj called with shared object"); sl@0: } sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.longValue = (long) intValue; sl@0: objPtr->typePtr = &tclIntType; sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetIntFromObj -- sl@0: * sl@0: * Attempt to return an int from the Tcl object "objPtr". If the object sl@0: * is not already an int, an attempt will be made to convert it to one. sl@0: * sl@0: * Integer and long integer objects share the same "integer" type sl@0: * implementation. We store all integers as longs and Tcl_GetIntFromObj sl@0: * checks whether the current value of the long can be represented by sl@0: * an int. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion or if the long integer held by the object sl@0: * can not be represented by an int, an error message is left in sl@0: * the interpreter's result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If the object is not already an int, the conversion will free sl@0: * any old internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetIntFromObj(interp, objPtr, intPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object from which to get a int. */ sl@0: register int *intPtr; /* Place to store resulting int. */ sl@0: { sl@0: int result; sl@0: Tcl_WideInt w = 0; sl@0: sl@0: /* sl@0: * If the object isn't already an integer of any width, try to sl@0: * convert it to one. sl@0: */ sl@0: sl@0: if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { sl@0: result = SetIntOrWideFromAny(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Object should now be either int or wide. Get its value. sl@0: */ sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: if (objPtr->typePtr == &tclWideIntType) { sl@0: w = objPtr->internalRep.wideValue; sl@0: } else sl@0: #endif sl@0: { sl@0: w = Tcl_LongAsWide(objPtr->internalRep.longValue); sl@0: } sl@0: sl@0: if ((LLONG_MAX > UINT_MAX) sl@0: && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) { sl@0: if (interp != NULL) { sl@0: Tcl_SetObjResult(interp, Tcl_NewStringObj( sl@0: "integer value too large to represent as non-long integer", sl@0: -1)); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: *intPtr = (int)w; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetIntFromAny -- sl@0: * sl@0: * Attempts to force the internal representation for a Tcl object sl@0: * to tclIntType, specifically. sl@0: * sl@0: * Results: sl@0: * The return value is a standard object Tcl result. If an sl@0: * error occurs during conversion, an error message is left in sl@0: * the interpreter's result unless "interp" is NULL. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetIntFromAny( Tcl_Interp* interp, sl@0: /* Tcl interpreter */ sl@0: Tcl_Obj* objPtr ) sl@0: /* Pointer to the object to convert */ sl@0: { sl@0: int result; sl@0: sl@0: result = SetIntOrWideFromAny( interp, objPtr ); sl@0: if ( result != TCL_OK ) { sl@0: return result; sl@0: } sl@0: if ( objPtr->typePtr != &tclIntType ) { sl@0: if ( interp != NULL ) { sl@0: char *s = "integer value too large to represent"; sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetIntOrWideFromAny -- sl@0: * sl@0: * Attempt to generate an integer internal form for the Tcl object sl@0: * "objPtr". sl@0: * sl@0: * Results: sl@0: * The return value is a standard object Tcl result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If no error occurs, an int is stored as "objPtr"s internal sl@0: * representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetIntOrWideFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: char *string, *end; sl@0: int length; sl@0: register char *p; sl@0: unsigned long newLong; sl@0: int isNegative = 0; sl@0: int isWide = 0; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: p = string = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: /* sl@0: * Now parse "objPtr"s string as an int. We use an implementation here sl@0: * that doesn't report errors in interp if interp is NULL. Note: use sl@0: * strtoul instead of strtol for integer conversions to allow full-size sl@0: * unsigned numbers, but don't depend on strtoul to handle sign sl@0: * characters; it won't in some implementations. sl@0: */ sl@0: sl@0: errno = 0; sl@0: for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ sl@0: /* Empty loop body. */ sl@0: } sl@0: if (*p == '-') { sl@0: p++; sl@0: isNegative = 1; sl@0: } else if (*p == '+') { sl@0: p++; sl@0: } sl@0: if (!isdigit(UCHAR(*p))) { sl@0: badInteger: sl@0: if (interp != NULL) { sl@0: /* sl@0: * Must copy string before resetting the result in case a caller sl@0: * is trying to convert the interpreter's result to an int. sl@0: */ sl@0: sl@0: char buf[100]; sl@0: sprintf(buf, "expected integer but got \"%.50s\"", string); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); sl@0: TclCheckBadOctal(interp, string); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: newLong = strtoul(p, &end, 0); sl@0: if (end == p) { sl@0: goto badInteger; sl@0: } sl@0: if (errno == ERANGE) { sl@0: if (interp != NULL) { sl@0: char *s = "integer value too large to represent"; sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure that the string has no garbage after the end of the int. sl@0: */ sl@0: sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO space. */ sl@0: end++; sl@0: } sl@0: if (end != (string+length)) { sl@0: goto badInteger; sl@0: } sl@0: sl@0: /* sl@0: * If the resulting integer will exceed the range of a long, sl@0: * put it into a wide instead. (Tcl Bug #868489) sl@0: */ sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) sl@0: || (!isNegative && newLong > LONG_MAX)) { sl@0: isWide = 1; sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: * The conversion to int succeeded. Free the old internalRep before sl@0: * setting the new one. We do this as late as possible to allow the sl@0: * conversion code, in particular Tcl_GetStringFromObj, to use that old sl@0: * internalRep. sl@0: */ sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: if (isWide) { sl@0: objPtr->internalRep.wideValue = sl@0: (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); sl@0: objPtr->typePtr = &tclWideIntType; sl@0: } else { sl@0: objPtr->internalRep.longValue = sl@0: (isNegative ? -(long)newLong : (long)newLong); sl@0: objPtr->typePtr = &tclIntType; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfInt -- sl@0: * sl@0: * Update the string representation for an integer object. sl@0: * Note: This procedure does not free an existing old string rep sl@0: * so storage will be lost if this has not already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a valid string that results from sl@0: * the int-to-string conversion. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfInt(objPtr) sl@0: register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ sl@0: { sl@0: char buffer[TCL_INTEGER_SPACE]; sl@0: register int len; sl@0: sl@0: len = TclFormatInt(buffer, objPtr->internalRep.longValue); sl@0: sl@0: objPtr->bytes = ckalloc((unsigned) len + 1); sl@0: strcpy(objPtr->bytes, buffer); sl@0: objPtr->length = len; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewLongObj -- sl@0: * sl@0: * If a client is compiled with TCL_MEM_DEBUG defined, calls to sl@0: * Tcl_NewLongObj to create a new long integer object end up calling sl@0: * the debugging procedure Tcl_DbNewLongObj instead. sl@0: * sl@0: * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, sl@0: * calls to Tcl_NewLongObj result in a call to one of the two sl@0: * Tcl_NewLongObj implementations below. We provide two implementations sl@0: * so that the Tcl core can be compiled to do memory debugging of the sl@0: * core even if a client does not request it for itself. sl@0: * sl@0: * Integer and long integer objects share the same "integer" type sl@0: * implementation. We store all integers as longs and Tcl_GetIntFromObj sl@0: * checks whether the current value of the long can be represented by sl@0: * an int. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewLongObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewLongObj(longValue) sl@0: register long longValue; /* Long integer used to initialize the sl@0: * new object. */ sl@0: { sl@0: return Tcl_DbNewLongObj(longValue, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewLongObj(longValue) sl@0: register long longValue; /* Long integer used to initialize the sl@0: * new object. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.longValue = longValue; sl@0: objPtr->typePtr = &tclIntType; sl@0: return objPtr; sl@0: } sl@0: #endif /* if TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewLongObj -- sl@0: * sl@0: * If a client is compiled with TCL_MEM_DEBUG defined, calls to sl@0: * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or sl@0: * long integer objects end up calling the debugging procedure sl@0: * Tcl_DbNewLongObj instead. We provide two implementations of sl@0: * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do sl@0: * memory debugging of the core is independent of whether a client sl@0: * requests debugging for itself. sl@0: * sl@0: * When the core is compiled with TCL_MEM_DEBUG defined, sl@0: * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and sl@0: * line number from its caller. This simplifies debugging since then sl@0: * the [memory active] command will report the caller's file name and sl@0: * line number when reporting objects that haven't been freed. sl@0: * sl@0: * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, sl@0: * this procedure just returns the result of calling Tcl_NewLongObj. sl@0: * sl@0: * Results: sl@0: * The newly created long integer object is returned. This object sl@0: * will have an invalid string representation. The returned object has sl@0: * ref count 0. sl@0: * sl@0: * Side effects: sl@0: * Allocates memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewLongObj(longValue, file, line) sl@0: register long longValue; /* Long integer used to initialize the sl@0: * new object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.longValue = longValue; sl@0: objPtr->typePtr = &tclIntType; sl@0: return objPtr; sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewLongObj(longValue, file, line) sl@0: register long longValue; /* Long integer used to initialize the sl@0: * new object. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: return Tcl_NewLongObj(longValue); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetLongObj -- sl@0: * sl@0: * Modify an object to be an integer object and to have the specified sl@0: * long integer value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep, if any, is freed. Also, any old sl@0: * internal rep is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetLongObj(objPtr, longValue) sl@0: register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ sl@0: register long longValue; /* Long integer used to initialize the sl@0: * object's value. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetLongObj called with shared object"); sl@0: } sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.longValue = longValue; sl@0: objPtr->typePtr = &tclIntType; sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetLongFromObj -- sl@0: * sl@0: * Attempt to return an long integer from the Tcl object "objPtr". If sl@0: * the object is not already an int object, an attempt will be made to sl@0: * convert it to one. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If the object is not already an int object, the conversion will free sl@0: * any old internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetLongFromObj(interp, objPtr, longPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object from which to get a long. */ sl@0: register long *longPtr; /* Place to store resulting long. */ sl@0: { sl@0: register int result; sl@0: sl@0: if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { sl@0: result = SetIntOrWideFromAny(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: if (objPtr->typePtr == &tclWideIntType) { sl@0: /* sl@0: * If the object is already a wide integer, don't convert it. sl@0: * This code allows for any integer in the range -ULONG_MAX to sl@0: * ULONG_MAX to be converted to a long, ignoring overflow. sl@0: * The rule preserves existing semantics for conversion of sl@0: * integers on input, but avoids inadvertent demotion of sl@0: * wide integers to 32-bit ones in the internal rep. sl@0: */ sl@0: sl@0: Tcl_WideInt w = objPtr->internalRep.wideValue; sl@0: if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { sl@0: *longPtr = Tcl_WideAsLong(w); sl@0: return TCL_OK; sl@0: } else { sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "integer value too large to represent", -1); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: *longPtr = objPtr->internalRep.longValue; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetWideIntFromAny -- sl@0: * sl@0: * Attempt to generate an integer internal form for the Tcl object sl@0: * "objPtr". sl@0: * sl@0: * Results: sl@0: * The return value is a standard object Tcl result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If no error occurs, an int is stored as "objPtr"s internal sl@0: * representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetWideIntFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: char *string, *end; sl@0: int length; sl@0: register char *p; sl@0: Tcl_WideInt newWide; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: p = string = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: /* sl@0: * Now parse "objPtr"s string as an int. We use an implementation here sl@0: * that doesn't report errors in interp if interp is NULL. Note: use sl@0: * strtoull instead of strtoll for integer conversions to allow full-size sl@0: * unsigned numbers, but don't depend on strtoull to handle sign sl@0: * characters; it won't in some implementations. sl@0: */ sl@0: sl@0: errno = 0; sl@0: #ifdef TCL_STRTOUL_SIGN_CHECK sl@0: for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ sl@0: /* Empty loop body. */ sl@0: } sl@0: if (*p == '-') { sl@0: p++; sl@0: newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); sl@0: } else if (*p == '+') { sl@0: p++; sl@0: newWide = strtoull(p, &end, 0); sl@0: } else sl@0: #else sl@0: newWide = strtoull(p, &end, 0); sl@0: #endif sl@0: if (end == p) { sl@0: badInteger: sl@0: if (interp != NULL) { sl@0: /* sl@0: * Must copy string before resetting the result in case a caller sl@0: * is trying to convert the interpreter's result to an int. sl@0: */ sl@0: sl@0: char buf[100]; sl@0: sprintf(buf, "expected integer but got \"%.50s\"", string); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); sl@0: TclCheckBadOctal(interp, string); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: if (errno == ERANGE) { sl@0: if (interp != NULL) { sl@0: char *s = "integer value too large to represent"; sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure that the string has no garbage after the end of the int. sl@0: */ sl@0: sl@0: while ((end < (string+length)) sl@0: && isspace(UCHAR(*end))) { /* INTL: ISO space. */ sl@0: end++; sl@0: } sl@0: if (end != (string+length)) { sl@0: goto badInteger; sl@0: } sl@0: sl@0: /* sl@0: * The conversion to int succeeded. Free the old internalRep before sl@0: * setting the new one. We do this as late as possible to allow the sl@0: * conversion code, in particular Tcl_GetStringFromObj, to use that old sl@0: * internalRep. sl@0: */ sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.wideValue = newWide; sl@0: #else sl@0: if (TCL_ERROR == SetIntFromAny(interp, objPtr)) { sl@0: return TCL_ERROR; sl@0: } sl@0: #endif sl@0: objPtr->typePtr = &tclWideIntType; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfWideInt -- sl@0: * sl@0: * Update the string representation for a wide integer object. sl@0: * Note: This procedure does not free an existing old string rep sl@0: * so storage will be lost if this has not already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a valid string that results from sl@0: * the wideInt-to-string conversion. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: static void sl@0: UpdateStringOfWideInt(objPtr) sl@0: register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ sl@0: { sl@0: char buffer[TCL_INTEGER_SPACE+2]; sl@0: register unsigned len; sl@0: register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; sl@0: sl@0: /* sl@0: * Note that sprintf will generate a compiler warning under sl@0: * Mingw claiming %I64 is an unknown format specifier. sl@0: * Just ignore this warning. We can't use %L as the format sl@0: * specifier since that gets printed as a 32 bit value. sl@0: */ sl@0: sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); sl@0: len = strlen(buffer); sl@0: objPtr->bytes = ckalloc((unsigned) len + 1); sl@0: memcpy(objPtr->bytes, buffer, len + 1); sl@0: objPtr->length = len; sl@0: } sl@0: #endif /* TCL_WIDE_INT_IS_LONG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewWideIntObj -- sl@0: * sl@0: * If a client is compiled with TCL_MEM_DEBUG defined, calls to sl@0: * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling sl@0: * the debugging procedure Tcl_DbNewWideIntObj instead. sl@0: * sl@0: * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, sl@0: * calls to Tcl_NewWideIntObj result in a call to one of the two sl@0: * Tcl_NewWideIntObj implementations below. We provide two implementations sl@0: * so that the Tcl core can be compiled to do memory debugging of the sl@0: * core even if a client does not request it for itself. sl@0: * sl@0: * Results: sl@0: * The newly created object is returned. This object will have an sl@0: * invalid string representation. The returned object has ref count 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewWideIntObj sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewWideIntObj(wideValue) sl@0: register Tcl_WideInt wideValue; /* Wide integer used to initialize sl@0: * the new object. */ sl@0: { sl@0: return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewWideIntObj(wideValue) sl@0: register Tcl_WideInt wideValue; /* Wide integer used to initialize sl@0: * the new object. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.wideValue = wideValue; sl@0: objPtr->typePtr = &tclWideIntType; sl@0: return objPtr; sl@0: } sl@0: #endif /* if TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewWideIntObj -- sl@0: * sl@0: * If a client is compiled with TCL_MEM_DEBUG defined, calls to sl@0: * Tcl_NewWideIntObj to create new wide integer end up calling sl@0: * the debugging procedure Tcl_DbNewWideIntObj instead. We sl@0: * provide two implementations of Tcl_DbNewWideIntObj so that sl@0: * whether the Tcl core is compiled to do memory debugging of the sl@0: * core is independent of whether a client requests debugging for sl@0: * itself. sl@0: * sl@0: * When the core is compiled with TCL_MEM_DEBUG defined, sl@0: * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file sl@0: * name and line number from its caller. This simplifies sl@0: * debugging since then the checkmem command will report the sl@0: * caller's file name and line number when reporting objects that sl@0: * haven't been freed. sl@0: * sl@0: * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, sl@0: * this procedure just returns the result of calling Tcl_NewWideIntObj. sl@0: * sl@0: * Results: sl@0: * The newly created wide integer object is returned. This object sl@0: * will have an invalid string representation. The returned object has sl@0: * ref count 0. sl@0: * sl@0: * Side effects: sl@0: * Allocates memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewWideIntObj(wideValue, file, line) sl@0: register Tcl_WideInt wideValue; /* Wide integer used to initialize sl@0: * the new object. */ sl@0: CONST char *file; /* The name of the source file sl@0: * calling this procedure; used for sl@0: * debugging. */ sl@0: int line; /* Line number in the source file; sl@0: * used for debugging. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: objPtr->bytes = NULL; sl@0: sl@0: objPtr->internalRep.wideValue = wideValue; sl@0: objPtr->typePtr = &tclWideIntType; sl@0: return objPtr; sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewWideIntObj(wideValue, file, line) sl@0: register Tcl_WideInt wideValue; /* Long integer used to initialize sl@0: * the new object. */ sl@0: CONST char *file; /* The name of the source file sl@0: * calling this procedure; used for sl@0: * debugging. */ sl@0: int line; /* Line number in the source file; sl@0: * used for debugging. */ sl@0: { sl@0: return Tcl_NewWideIntObj(wideValue); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetWideIntObj -- sl@0: * sl@0: * Modify an object to be a wide integer object and to have the sl@0: * specified wide integer value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep, if any, is freed. Also, any old sl@0: * internal rep is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetWideIntObj(objPtr, wideValue) sl@0: register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ sl@0: register Tcl_WideInt wideValue; /* Wide integer used to initialize sl@0: * the object's value. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetWideIntObj called with shared object"); sl@0: } sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.wideValue = wideValue; sl@0: objPtr->typePtr = &tclWideIntType; sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetWideIntFromObj -- sl@0: * sl@0: * Attempt to return a wide integer from the Tcl object "objPtr". If sl@0: * the object is not already a wide int object, an attempt will be made sl@0: * to convert it to one. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl object result. If an error occurs sl@0: * during conversion, an error message is left in the interpreter's sl@0: * result unless "interp" is NULL. sl@0: * sl@0: * Side effects: sl@0: * If the object is not already an int object, the conversion will free sl@0: * any old internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ sl@0: register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ sl@0: { sl@0: register int result; sl@0: sl@0: if (objPtr->typePtr == &tclWideIntType) { sl@0: gotWide: sl@0: *wideIntPtr = objPtr->internalRep.wideValue; sl@0: return TCL_OK; sl@0: } sl@0: if (objPtr->typePtr == &tclIntType) { sl@0: /* sl@0: * This cast is safe; all valid ints/longs are wides. sl@0: */ sl@0: sl@0: objPtr->internalRep.wideValue = sl@0: Tcl_LongAsWide(objPtr->internalRep.longValue); sl@0: objPtr->typePtr = &tclWideIntType; sl@0: goto gotWide; sl@0: } sl@0: result = SetWideIntFromAny(interp, objPtr); sl@0: if (result == TCL_OK) { sl@0: *wideIntPtr = objPtr->internalRep.wideValue; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbIncrRefCount -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. This checks to see whether or not sl@0: * the memory has been freed before incrementing the ref count. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just increments sl@0: * the reference count of the object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's ref count is incremented. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DbIncrRefCount(objPtr, file, line) sl@0: register Tcl_Obj *objPtr; /* The object we are registering a sl@0: * reference to. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: #ifdef TCL_MEM_DEBUG sl@0: if (objPtr->refCount == 0x61616161) { sl@0: fprintf(stderr, "file = %s, line = %d\n", file, line); sl@0: fflush(stderr); sl@0: panic("Trying to increment refCount of previously disposed object."); sl@0: } sl@0: #endif sl@0: ++(objPtr)->refCount; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbDecrRefCount -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. This checks to see whether or not sl@0: * the memory has been freed before decrementing the ref count. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just decrements sl@0: * the reference count of the object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's ref count is incremented. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DbDecrRefCount(objPtr, file, line) sl@0: register Tcl_Obj *objPtr; /* The object we are releasing a reference sl@0: * to. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: #ifdef TCL_MEM_DEBUG sl@0: if (objPtr->refCount == 0x61616161) { sl@0: fprintf(stderr, "file = %s, line = %d\n", file, line); sl@0: fflush(stderr); sl@0: panic("Trying to decrement refCount of previously disposed object."); sl@0: } sl@0: #endif sl@0: if (--(objPtr)->refCount <= 0) { sl@0: TclFreeObj(objPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbIsShared -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. It tests whether the object has a ref sl@0: * count greater than one. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just tests sl@0: * if the object has a ref count greater than one. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_DbIsShared(objPtr, file, line) sl@0: register Tcl_Obj *objPtr; /* The object to test for being shared. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: #ifdef TCL_MEM_DEBUG sl@0: if (objPtr->refCount == 0x61616161) { sl@0: fprintf(stderr, "file = %s, line = %d\n", file, line); sl@0: fflush(stderr); sl@0: panic("Trying to check whether previously disposed object is shared."); sl@0: } sl@0: #endif sl@0: #ifdef TCL_COMPILE_STATS sl@0: Tcl_MutexLock(&tclObjMutex); sl@0: if ((objPtr)->refCount <= 1) { sl@0: tclObjsShared[1]++; sl@0: } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { sl@0: tclObjsShared[(objPtr)->refCount]++; sl@0: } else { sl@0: tclObjsShared[0]++; sl@0: } sl@0: Tcl_MutexUnlock(&tclObjMutex); sl@0: #endif sl@0: return ((objPtr)->refCount > 1); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_InitObjHashTable -- sl@0: * sl@0: * Given storage for a hash table, set up the fields to prepare sl@0: * the hash table for use, the keys are Tcl_Obj *. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * TablePtr is now ready to be passed to Tcl_FindHashEntry and sl@0: * Tcl_CreateHashEntry. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_InitObjHashTable(tablePtr) sl@0: register Tcl_HashTable *tablePtr; /* Pointer to table record, which sl@0: * is supplied by the caller. */ sl@0: { sl@0: Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, sl@0: &tclObjHashKeyType); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AllocObjEntry -- sl@0: * sl@0: * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the created entry. sl@0: * sl@0: * Side effects: sl@0: * Increments the reference count on the object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_HashEntry * sl@0: AllocObjEntry(tablePtr, keyPtr) sl@0: Tcl_HashTable *tablePtr; /* Hash table. */ sl@0: VOID *keyPtr; /* Key to store in the hash table entry. */ sl@0: { sl@0: Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); sl@0: hPtr->key.oneWordValue = (char *) objPtr; sl@0: Tcl_IncrRefCount (objPtr); sl@0: sl@0: return hPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CompareObjKeys -- sl@0: * sl@0: * Compares two Tcl_Obj * keys. sl@0: * sl@0: * Results: sl@0: * The return value is 0 if they are different and 1 if they are sl@0: * the same. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CompareObjKeys(keyPtr, hPtr) sl@0: VOID *keyPtr; /* New key to compare. */ sl@0: Tcl_HashEntry *hPtr; /* Existing key to compare. */ sl@0: { sl@0: Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; sl@0: Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; sl@0: register CONST char *p1, *p2; sl@0: register int l1, l2; sl@0: sl@0: /* sl@0: * If the object pointers are the same then they match. sl@0: */ sl@0: if (objPtr1 == objPtr2) { sl@0: return 1; sl@0: } sl@0: sl@0: /* sl@0: * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being sl@0: * in a register. sl@0: */ sl@0: p1 = TclGetString(objPtr1); sl@0: l1 = objPtr1->length; sl@0: p2 = TclGetString(objPtr2); sl@0: l2 = objPtr2->length; sl@0: sl@0: /* sl@0: * Only compare if the string representations are of the same length. sl@0: */ sl@0: if (l1 == l2) { sl@0: for (;; p1++, p2++, l1--) { sl@0: if (*p1 != *p2) { sl@0: break; sl@0: } sl@0: if (l1 == 0) { sl@0: return 1; sl@0: } sl@0: } sl@0: } sl@0: sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FreeObjEntry -- sl@0: * sl@0: * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the created entry. sl@0: * sl@0: * Side effects: sl@0: * Decrements the reference count of the object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: FreeObjEntry(hPtr) sl@0: Tcl_HashEntry *hPtr; /* Hash entry to free. */ sl@0: { sl@0: Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; sl@0: sl@0: Tcl_DecrRefCount (objPtr); sl@0: ckfree ((char *) hPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * HashObjKey -- sl@0: * sl@0: * Compute a one-word summary of the string representation of the sl@0: * Tcl_Obj, which can be used to generate a hash index. sl@0: * sl@0: * Results: sl@0: * The return value is a one-word summary of the information in sl@0: * the string representation of the Tcl_Obj. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static unsigned int sl@0: HashObjKey(tablePtr, keyPtr) sl@0: Tcl_HashTable *tablePtr; /* Hash table. */ sl@0: VOID *keyPtr; /* Key from which to compute hash value. */ sl@0: { sl@0: Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; sl@0: CONST char *string = TclGetString(objPtr); sl@0: int length = objPtr->length; sl@0: unsigned int result; sl@0: int i; sl@0: sl@0: /* sl@0: * I tried a zillion different hash functions and asked many other sl@0: * people for advice. Many people had their own favorite functions, sl@0: * all different, but no-one had much idea why they were good ones. sl@0: * I chose the one below (multiply by 9 and add new character) sl@0: * because of the following reasons: sl@0: * sl@0: * 1. Multiplying by 10 is perfect for keys that are decimal strings, sl@0: * and multiplying by 9 is just about as good. sl@0: * 2. Times-9 is (shift-left-3) plus (old). This means that each sl@0: * character's bits hang around in the low-order bits of the sl@0: * hash value for ever, plus they spread fairly rapidly up to sl@0: * the high-order bits to fill out the hash value. This seems sl@0: * works well both for decimal and non-decimal strings. sl@0: */ sl@0: sl@0: result = 0; sl@0: for (i=0 ; ivarFramePtr; sl@0: name = Tcl_GetString(objPtr); sl@0: if ((*name++ == ':') && (*name == ':')) { sl@0: iPtr->varFramePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Get the internal representation, converting to a command type if sl@0: * needed. The internal representation is a ResolvedCmdName that points sl@0: * to the actual command. sl@0: */ sl@0: sl@0: if (objPtr->typePtr != &tclCmdNameType) { sl@0: result = tclCmdNameType.setFromAnyProc(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: iPtr->varFramePtr = savedFramePtr; sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: } sl@0: resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: sl@0: /* sl@0: * Get the current namespace. sl@0: */ sl@0: sl@0: if (iPtr->varFramePtr != NULL) { sl@0: currNsPtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: currNsPtr = iPtr->globalNsPtr; sl@0: } sl@0: sl@0: /* sl@0: * Check the context namespace and the namespace epoch of the resolved sl@0: * symbol to make sure that it is fresh. If not, then force another sl@0: * conversion to the command type, to discard the old rep and create a sl@0: * new one. Note that we verify that the namespace id of the context sl@0: * namespace is the same as the one we cached; this insures that the sl@0: * namespace wasn't deleted and a new one created at the same address sl@0: * with the same command epoch. sl@0: */ sl@0: sl@0: cmdPtr = NULL; sl@0: if ((resPtr != NULL) sl@0: && (resPtr->refNsPtr == currNsPtr) sl@0: && (resPtr->refNsId == currNsPtr->nsId) sl@0: && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { sl@0: cmdPtr = resPtr->cmdPtr; sl@0: if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { sl@0: cmdPtr = NULL; sl@0: } sl@0: } sl@0: sl@0: if (cmdPtr == NULL) { sl@0: result = tclCmdNameType.setFromAnyProc(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: iPtr->varFramePtr = savedFramePtr; sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: if (resPtr != NULL) { sl@0: cmdPtr = resPtr->cmdPtr; sl@0: } sl@0: } sl@0: iPtr->varFramePtr = savedFramePtr; sl@0: return (Tcl_Command) cmdPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclSetCmdNameObj -- sl@0: * sl@0: * Modify an object to be an CmdName object that refers to the argument sl@0: * Command structure. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old internal rep is freed. It's string rep is not sl@0: * changed. The refcount in the Command structure is incremented to sl@0: * keep it from being freed if the command is later deleted until sl@0: * TclExecuteByteCode has a chance to recognize that it was deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclSetCmdNameObj(interp, objPtr, cmdPtr) sl@0: Tcl_Interp *interp; /* Points to interpreter containing command sl@0: * that should be cached in objPtr. */ sl@0: register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to sl@0: * a CmdName object. */ sl@0: Command *cmdPtr; /* Points to Command structure that the sl@0: * CmdName object should refer to. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register ResolvedCmdName *resPtr; sl@0: Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: register Namespace *currNsPtr; sl@0: sl@0: if (oldTypePtr == &tclCmdNameType) { sl@0: return; sl@0: } sl@0: sl@0: /* sl@0: * Get the current namespace. sl@0: */ sl@0: sl@0: if (iPtr->varFramePtr != NULL) { sl@0: currNsPtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: currNsPtr = iPtr->globalNsPtr; sl@0: } sl@0: sl@0: cmdPtr->refCount++; sl@0: resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); sl@0: resPtr->cmdPtr = cmdPtr; sl@0: resPtr->refNsPtr = currNsPtr; sl@0: resPtr->refNsId = currNsPtr->nsId; sl@0: resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; sl@0: resPtr->cmdEpoch = cmdPtr->cmdEpoch; sl@0: resPtr->refCount = 1; sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; sl@0: objPtr->internalRep.twoPtrValue.ptr2 = NULL; sl@0: objPtr->typePtr = &tclCmdNameType; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FreeCmdNameInternalRep -- sl@0: * sl@0: * Frees the resources associated with a cmdName object's internal sl@0: * representation. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Decrements the ref count of any cached ResolvedCmdName structure sl@0: * pointed to by the cmdName's internal representation. If this is sl@0: * the last use of the ResolvedCmdName, it is freed. This in turn sl@0: * decrements the ref count of the Command structure pointed to by sl@0: * the ResolvedSymbol, which may free the Command structure. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: FreeCmdNameInternalRep(objPtr) sl@0: register Tcl_Obj *objPtr; /* CmdName object with internal sl@0: * representation to free. */ sl@0: { sl@0: register ResolvedCmdName *resPtr = sl@0: (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: sl@0: if (resPtr != NULL) { sl@0: /* sl@0: * Decrement the reference count of the ResolvedCmdName structure. sl@0: * If there are no more uses, free the ResolvedCmdName structure. sl@0: */ sl@0: sl@0: resPtr->refCount--; sl@0: if (resPtr->refCount == 0) { sl@0: /* sl@0: * Now free the cached command, unless it is still in its sl@0: * hash table or if there are other references to it sl@0: * from other cmdName objects. sl@0: */ sl@0: sl@0: Command *cmdPtr = resPtr->cmdPtr; sl@0: TclCleanupCommand(cmdPtr); sl@0: ckfree((char *) resPtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DupCmdNameInternalRep -- sl@0: * sl@0: * Initialize the internal representation of an cmdName Tcl_Obj to a sl@0: * copy of the internal representation of an existing cmdName object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * "copyPtr"s internal rep is set to point to the ResolvedCmdName sl@0: * structure corresponding to "srcPtr"s internal rep. Increments the sl@0: * ref count of the ResolvedCmdName structure pointed to by the sl@0: * cmdName's internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DupCmdNameInternalRep(srcPtr, copyPtr) sl@0: Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ sl@0: register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ sl@0: { sl@0: register ResolvedCmdName *resPtr = sl@0: (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1; sl@0: sl@0: copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; sl@0: copyPtr->internalRep.twoPtrValue.ptr2 = NULL; sl@0: if (resPtr != NULL) { sl@0: resPtr->refCount++; sl@0: } sl@0: copyPtr->typePtr = &tclCmdNameType; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetCmdNameFromAny -- sl@0: * sl@0: * Generate an cmdName internal form for the Tcl object "objPtr". sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl result. The conversion always sl@0: * succeeds and TCL_OK is returned. sl@0: * sl@0: * Side effects: sl@0: * A pointer to a ResolvedCmdName structure that holds a cached pointer sl@0: * to the command with a name that matches objPtr's string rep is sl@0: * stored as objPtr's internal representation. This ResolvedCmdName sl@0: * pointer will be NULL if no matching command was found. The ref count sl@0: * of the cached Command's structure (if any) is also incremented. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetCmdNameFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *name; sl@0: Tcl_Command cmd; sl@0: register Command *cmdPtr; sl@0: Namespace *currNsPtr; sl@0: register ResolvedCmdName *resPtr; sl@0: sl@0: /* sl@0: * Get "objPtr"s string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: name = objPtr->bytes; sl@0: if (name == NULL) { sl@0: name = Tcl_GetString(objPtr); sl@0: } sl@0: sl@0: /* sl@0: * Find the Command structure, if any, that describes the command called sl@0: * "name". Build a ResolvedCmdName that holds a cached pointer to this sl@0: * Command, and bump the reference count in the referenced Command sl@0: * structure. A Command structure will not be deleted as long as it is sl@0: * referenced from a CmdName object. sl@0: */ sl@0: sl@0: cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: cmdPtr = (Command *) cmd; sl@0: if (cmdPtr != NULL) { sl@0: /* sl@0: * Get the current namespace. sl@0: */ sl@0: sl@0: if (iPtr->varFramePtr != NULL) { sl@0: currNsPtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: currNsPtr = iPtr->globalNsPtr; sl@0: } sl@0: sl@0: cmdPtr->refCount++; sl@0: resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); sl@0: resPtr->cmdPtr = cmdPtr; sl@0: resPtr->refNsPtr = currNsPtr; sl@0: resPtr->refNsId = currNsPtr->nsId; sl@0: resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; sl@0: resPtr->cmdEpoch = cmdPtr->cmdEpoch; sl@0: resPtr->refCount = 1; sl@0: } else { sl@0: resPtr = NULL; /* no command named "name" was found */ sl@0: } sl@0: sl@0: /* sl@0: * Free the old internalRep before setting the new one. We do this as sl@0: * late as possible to allow the conversion code, in particular sl@0: * GetStringFromObj, to use that old internalRep. If no Command sl@0: * structure was found, leave NULL as the cached value. sl@0: */ sl@0: sl@0: if ((objPtr->typePtr != NULL) sl@0: && (objPtr->typePtr->freeIntRepProc != NULL)) { sl@0: objPtr->typePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; sl@0: objPtr->internalRep.twoPtrValue.ptr2 = NULL; sl@0: objPtr->typePtr = &tclCmdNameType; sl@0: return TCL_OK; sl@0: }