--- projs/trunk/shared_source/tcl_base/tclobj.c 2016/10/14 01:50:00 42 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclobj.c 2016/11/05 11:07:06 71 @@ -1,2289 +1,2273 @@ -/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclobj.c,v 1.3 2001/09/12 18:12:20 dtashley Exp $ */ - -/* - * tclObj.c -- - * - * This file contains Tcl object-related procedures that are used by - * many Tcl commands. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclobj.c,v 1.3 2001/09/12 18:12:20 dtashley Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Table of all object types. - */ - -static Tcl_HashTable typeTable; -static int typeTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(tableMutex) - -/* - * Head of the list of free Tcl_Obj structs we maintain. - */ - -Tcl_Obj *tclFreeObjList = NULL; - -/* - * The object allocator is single threaded. This mutex is referenced - * by the TclNewObj macro, however, so must be visible. - */ - -#ifdef TCL_THREADS -Tcl_Mutex tclObjMutex; -#endif - -/* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. - */ - -static char emptyString; -char *tclEmptyStringRep = &emptyString; - -/* - * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed - * (by TclFreeObj). - */ - -#ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -#endif /* TCL_COMPILE_STATS */ - -/* - * Prototypes for procedures defined later in this file: - */ - -static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); - -/* - * The structures below defines the Tcl object types defined in this file by - * means of procedures that can be invoked by generic object code. See also - * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager - * implementations. - */ - -Tcl_ObjType tclBooleanType = { - "boolean", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfBoolean, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ -}; - -Tcl_ObjType tclDoubleType = { - "double", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ -}; - -Tcl_ObjType tclIntType = { - "int", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ -}; - -/* - *------------------------------------------------------------------------- - * - * TclInitObjectSubsystem -- - * - * This procedure is invoked to perform once-only initialization of - * the type table. It also registers the object types defined in - * this file. - * - * Results: - * None. - * - * Side effects: - * Initializes the table of defined object types "typeTable" with - * builtin object types defined in this file. - * - *------------------------------------------------------------------------- - */ - -void -TclInitObjSubsystem() -{ - Tcl_MutexLock(&tableMutex); - typeTableInitialized = 1; - Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); - Tcl_MutexUnlock(&tableMutex); - - Tcl_RegisterObjType(&tclBooleanType); - Tcl_RegisterObjType(&tclByteArrayType); - Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclStringType); - Tcl_RegisterObjType(&tclListType); - Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclProcBodyType); - -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - tclObjsAlloced = 0; - tclObjsFreed = 0; - Tcl_MutexUnlock(&tclObjMutex); -#endif -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeCompExecEnv -- - * - * This procedure is called by Tcl_Finalize to clean up the Tcl - * compilation and execution environment so it can later be properly - * reinitialized. - * - * Results: - * None. - * - * Side effects: - * Cleans up the compilation and execution environment - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeCompExecEnv() -{ - Tcl_MutexLock(&tableMutex); - if (typeTableInitialized) { - Tcl_DeleteHashTable(&typeTable); - typeTableInitialized = 0; - } - Tcl_MutexUnlock(&tableMutex); - Tcl_MutexLock(&tclObjMutex); - tclFreeObjList = NULL; - Tcl_MutexUnlock(&tclObjMutex); - - TclFinalizeCompilation(); - TclFinalizeExecution(); -} - -/* - *-------------------------------------------------------------- - * - * Tcl_RegisterObjType -- - * - * This procedure is called to register a new Tcl object type - * in the table of all object types supported by Tcl. - * - * Results: - * None. - * - * Side effects: - * The type is registered in the Tcl type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. - * - *-------------------------------------------------------------- - */ - -void -Tcl_RegisterObjType(typePtr) - Tcl_ObjType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ -{ - register Tcl_HashEntry *hPtr; - int new; - - /* - * If there's already an object type with the given name, remove it. - */ - Tcl_MutexLock(&tableMutex); - hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); - if (hPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(hPtr); - } - - /* - * Now insert the new object type. - */ - - hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); - if (new) { - Tcl_SetHashValue(hPtr, typePtr); - } - Tcl_MutexUnlock(&tableMutex); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendAllObjTypes -- - * - * This procedure appends onto the argument object the name of each - * object type as a list element. This includes the builtin object - * types (e.g. int, list) as well as those added using - * Tcl_NewObj. These names can be used, for example, with - * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType - * structures. - * - * Results: - * The return value is normally TCL_OK; in this case the object - * referenced by objPtr has each type name appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. - * - * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppendAllObjTypes(interp, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * name of each registered type is appended - * as a list element. */ -{ - register Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_ObjType *typePtr; - int result; - - /* - * This code assumes that types names do not contain embedded NULLs. - */ - - Tcl_MutexLock(&tableMutex); - for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); - result = Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj(typePtr->name, -1)); - if (result == TCL_ERROR) { - Tcl_MutexUnlock(&tableMutex); - return result; - } - } - Tcl_MutexUnlock(&tableMutex); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetObjType -- - * - * This procedure looks up an object type by name. - * - * Results: - * If an object type with name matching "typeName" is found, a pointer - * to its Tcl_ObjType structure is returned; otherwise, NULL is - * returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_ObjType * -Tcl_GetObjType(typeName) - char *typeName; /* Name of Tcl object type to look up. */ -{ - register Tcl_HashEntry *hPtr; - Tcl_ObjType *typePtr; - - Tcl_MutexLock(&tableMutex); - hPtr = Tcl_FindHashEntry(&typeTable, typeName); - if (hPtr != (Tcl_HashEntry *) NULL) { - typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); - Tcl_MutexUnlock(&tableMutex); - return typePtr; - } - Tcl_MutexUnlock(&tableMutex); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConvertToType -- - * - * Convert the Tcl object "objPtr" to have type "typePtr" if possible. - * - * Results: - * The return value is TCL_OK on success and TCL_ERROR on failure. If - * TCL_ERROR is returned, then the interpreter's result contains an - * error message unless "interp" is NULL. Passing a NULL "interp" - * allows this procedure to be used as a test whether the conversion - * could be done (and in fact was done). - * - * Side effects: - * Any internal representation for the old type is freed. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ConvertToType(interp, objPtr, typePtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ - Tcl_ObjType *typePtr; /* The target type. */ -{ - if (objPtr->typePtr == typePtr) { - return TCL_OK; - } - - /* - * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal - * form as appropriate for the target type. This frees the old internal - * representation. - */ - - return typePtr->setFromAnyProc(interp, objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewObj -- - * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote - * the empty string. These objects have a NULL object type and NULL - * string representation byte pointer. Type managers call this routine - * to allocate new objects that they further initialize. - * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewObj. - * - * Results: - * The result is a newly allocated object that represents the empty - * string. The new object's typePtr is set NULL and its ref count - * is set to 0. - * - * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewObj - -Tcl_Obj * -Tcl_NewObj() -{ - return Tcl_DbNewObj("unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewObj() -{ - register Tcl_Obj *objPtr; - - /* - * Allocate the object using the list of free Tcl_Obj structs - * we maintain. - */ - - Tcl_MutexLock(&tclObjMutex); - if (tclFreeObjList == NULL) { - TclAllocateFreeObjects(); - } - objPtr = tclFreeObjList; - tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; - - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - tclObjsAlloced++; -#endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewObj -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the - * empty string. It is the same as the Tcl_NewObj procedure above - * except that it calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the checkmem command will report the correct file name and line - * number when reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the - * result of calling Tcl_NewObj. - * - * Results: - * The result is a newly allocated that represents the empty string. - * The new object's typePtr is set NULL and its ref count is set to 0. - * - * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewObj(file, line) - register char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - register int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *objPtr; - - /* - * If debugging Tcl's memory usage, allocate the object using ckalloc. - * Otherwise, allocate it using the list of free Tcl_Obj structs we - * maintain. - */ - - objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - tclObjsAlloced++; - Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewObj(file, line) - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - return Tcl_NewObj(); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclAllocateFreeObjects -- - * - * Procedure to allocate a number of free Tcl_Objs. This is done using - * a single ckalloc to reduce the overhead for Tcl_Obj allocation. - * - * Assumes mutex is held. - * - * Results: - * None. - * - * Side effects: - * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the - * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. - * - *---------------------------------------------------------------------- - */ - -#define OBJS_TO_ALLOC_EACH_TIME 100 - -void -TclAllocateFreeObjects() -{ - Tcl_Obj tmp[2]; - size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ - ((int)(&(tmp[1])) - (int)(&(tmp[0]))); - size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); - char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; - - basePtr = (char *) ckalloc(bytesToAlloc); - memset(basePtr, 0, bytesToAlloc); - - prevPtr = NULL; - objPtr = (Tcl_Obj *) basePtr; - for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; - prevPtr = objPtr; - objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); - } - tclFreeObjList = prevPtr; -} -#undef OBJS_TO_ALLOC_EACH_TIME - -/* - *---------------------------------------------------------------------- - * - * TclFreeObj -- - * - * This procedure frees the memory associated with the argument - * object. It is called by the tcl.h macro Tcl_DecrRefCount when an - * object's ref count is zero. It is only "public" since it must - * be callable by that macro wherever the macro is used. It should not - * be directly called by clients. - * - * Results: - * None. - * - * Side effects: - * Deallocates the storage for the object's Tcl_Obj structure - * after deallocating the string representation and calling the - * type-specific Tcl_FreeInternalRepProc to deallocate the object's - * internal representation. If compiling with TCL_COMPILE_STATS, - * this procedure increments the global count of freed objects - * (tclObjsFreed). - * - *---------------------------------------------------------------------- - */ - -void -TclFreeObj(objPtr) - register Tcl_Obj *objPtr; /* The object to be freed. */ -{ - register Tcl_ObjType *typePtr = objPtr->typePtr; - -#ifdef TCL_MEM_DEBUG - if ((objPtr)->refCount < -1) { - panic("Reference count for %lx was negative", objPtr); - } -#endif /* TCL_MEM_DEBUG */ - - if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - typePtr->freeIntRepProc(objPtr); - } - Tcl_InvalidateStringRep(objPtr); - - /* - * If debugging Tcl's memory usage, deallocate the object using ckfree. - * Otherwise, deallocate it by adding it onto the list of free - * Tcl_Obj structs we maintain. - */ - - Tcl_MutexLock(&tclObjMutex); -#ifdef TCL_MEM_DEBUG - ckfree((char *) objPtr); -#else - objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; - tclFreeObjList = objPtr; -#endif /* TCL_MEM_DEBUG */ - -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DuplicateObj -- - * - * Create and return a new object that is a duplicate of the argument - * object. - * - * Results: - * The return value is a pointer to a newly created Tcl_Obj. This - * object has reference count 0 and the same type, if any, as the - * source object objPtr. Also: - * 1) If the source object has a valid string rep, we copy it; - * otherwise, the duplicate's string rep is set NULL to mark - * it invalid. - * 2) If the source object has an internal representation (i.e. its - * typePtr is non-NULL), the new object's internal rep is set to - * a copy; otherwise the new internal rep is marked invalid. - * - * Side effects: - * What constitutes "copying" the internal representation depends on - * the type. For example, if the argument object is a list, - * the element objects it points to will not actually be copied but - * will be shared with the duplicate list. That is, the ref counts of - * the element objects will be incremented. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_DuplicateObj(objPtr) - register Tcl_Obj *objPtr; /* The object to duplicate. */ -{ - register Tcl_ObjType *typePtr = objPtr->typePtr; - register Tcl_Obj *dupPtr; - - TclNewObj(dupPtr); - - if (objPtr->bytes == NULL) { - dupPtr->bytes = NULL; - } else if (objPtr->bytes != tclEmptyStringRep) { - int len = objPtr->length; - - dupPtr->bytes = (char *) ckalloc((unsigned) len+1); - if (len > 0) { - memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, - (unsigned) len); - } - dupPtr->bytes[len] = '\0'; - dupPtr->length = len; - } - - if (typePtr != NULL) { - if (typePtr->dupIntRepProc == NULL) { - dupPtr->internalRep = objPtr->internalRep; - dupPtr->typePtr = typePtr; - } else { - (*typePtr->dupIntRepProc)(objPtr, dupPtr); - } - } - return dupPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetString -- - * - * Returns the string representation byte array pointer for an object. - * - * Results: - * Returns a pointer to the string representation of objPtr. The byte - * array referenced by the returned pointer must not be modified by the - * caller. Furthermore, the caller must copy the bytes if they need to - * retain them since the object's string rep can change as a result of - * other operations. - * - * Side effects: - * May call the object's updateStringProc to update the string - * representation from the internal representation. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetString(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ -{ - if (objPtr->bytes != NULL) { - return objPtr->bytes; - } - - if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); - return objPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetStringFromObj -- - * - * Returns the string representation's byte array pointer and length - * for an object. - * - * Results: - * Returns a pointer to the string representation of objPtr. If - * lengthPtr isn't NULL, the length of the string representation is - * stored at *lengthPtr. The byte array referenced by the returned - * pointer must not be modified by the caller. Furthermore, the - * caller must copy the bytes if they need to retain them since the - * object's string rep can change as a result of other operations. - * - * Side effects: - * May call the object's updateStringProc to update the string - * representation from the internal representation. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetStringFromObj(objPtr, lengthPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ - register int *lengthPtr; /* If non-NULL, the location where the - * string rep's byte array length should be - * stored. If NULL, no length is stored. */ -{ - if (objPtr->bytes != NULL) { - if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; - } - return objPtr->bytes; - } - - if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); - if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; - } - return objPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InvalidateStringRep -- - * - * This procedure is called to invalidate an object's string - * representation. - * - * Results: - * None. - * - * Side effects: - * Deallocates the storage for any old string representation, then - * sets the string representation NULL to mark it invalid. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_InvalidateStringRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be freed. */ -{ - if (objPtr->bytes != NULL) { - if (objPtr->bytes != tclEmptyStringRep) { - ckfree((char *) objPtr->bytes); - } - objPtr->bytes = NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewBooleanObj -- - * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new boolean object and - * initializes it from the argument boolean value. A nonzero - * "boolValue" is coerced to 1. - * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewBooleanObj - -Tcl_Obj * -Tcl_NewBooleanObj(boolValue) - register int boolValue; /* Boolean used to initialize new object. */ -{ - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewBooleanObj(boolValue) - register int boolValue; /* Boolean used to initialize new object. */ -{ - register Tcl_Obj *objPtr; - - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewBooleanObj -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the - * same as the Tcl_NewBooleanObj procedure above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the - * result of calling Tcl_NewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewBooleanObj(boolValue, file, line) - register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewBooleanObj(boolValue, file, line) - register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - return Tcl_NewBooleanObj(boolValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetBooleanObj -- - * - * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "boolValue" is coerced to 1. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetBooleanObj(objPtr, boolValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register int boolValue; /* Boolean used to set object's value. */ -{ - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetBooleanObj called with shared object"); - } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; - Tcl_InvalidateStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetBooleanFromObj -- - * - * Attempt to return a boolean from the Tcl object "objPtr". If the - * object is not already a boolean, an attempt will be made to convert - * it to one. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If the object is not already a boolean, the conversion will free - * any old internal representation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get boolean. */ - register int *boolPtr; /* Place to store resulting boolean. */ -{ - register int result; - - result = SetBooleanFromAny(interp, objPtr); - if (result == TCL_OK) { - *boolPtr = (int) objPtr->internalRep.longValue; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SetBooleanFromAny -- - * - * Attempt to generate a boolean internal form for the Tcl object - * "objPtr". - * - * Results: - * The return value is a standard Tcl result. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. - * - * Side effects: - * If no error occurs, an integer 1 or 0 is stored as "objPtr"s - * internal representation and the type of "objPtr" is set to boolean. - * - *---------------------------------------------------------------------- - */ - -static int -SetBooleanFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - register char c; - char lowerCase[10]; - int newBool, length; - register int i; - double dbl; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Copy the string converting its characters to lower case. - */ - - for (i = 0; (i < 9) && (i < length); i++) { - c = string[i]; - /* - * Weed out international characters so we can safely operate - * on single bytes. - */ - - if (c & 0x80) { - goto badBoolean; - } - if (Tcl_UniCharIsUpper(UCHAR(c))) { - c = (char) Tcl_UniCharToLower(UCHAR(c)); - } - lowerCase[i] = c; - } - lowerCase[i] = 0; - - /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. - */ - - c = lowerCase[0]; - if ((c == '0') && (lowerCase[1] == '\0')) { - newBool = 0; - } else if ((c == '1') && (lowerCase[1] == '\0')) { - newBool = 1; - } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 'o') && (length >= 2)) { - if (strncmp(lowerCase, "on", (size_t) length) == 0) { - newBool = 1; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { - newBool = 0; - } else { - goto badBoolean; - } - } else { - /* - * Still might be a string containing the characters representing an - * int or double that wasn't handled above. This would be a string - * like "27" or "1.0" that is non-zero and not "1". Such a string - * whould result in the boolean value true. We try converting to - * double. If that succeeds and the resulting double is non-zero, we - * have a "true". Note that numbers can't have embedded NULLs. - */ - - dbl = strtod(string, &end); - if (end == string) { - goto badBoolean; - } - - /* - * Make sure the string has no garbage after the end of the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end != (string+length)) { - goto badBoolean; - } - newBool = (dbl != 0.0); - } - - /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use that old internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = newBool; - objPtr->typePtr = &tclBooleanType; - return TCL_OK; - - badBoolean: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to a boolean. - */ - - char buf[100]; - sprintf(buf, "expected boolean value but got \"%.50s\"", string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfBoolean -- - * - * Update the string representation for a boolean object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the boolean-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfBoolean(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - char *s = ckalloc((unsigned) 2); - - s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); - s[1] = '\0'; - objPtr->bytes = s; - objPtr->length = 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewDoubleObj -- - * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new double object and - * initializes it from the argument double value. - * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDoubleObj. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewDoubleObj - -Tcl_Obj * -Tcl_NewDoubleObj(dblValue) - register double dblValue; /* Double used to initialize the object. */ -{ - return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewDoubleObj(dblValue) - register double dblValue; /* Double used to initialize the object. */ -{ - register Tcl_Obj *objPtr; - - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewDoubleObj -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new double objects. It is the - * same as the Tcl_NewDoubleObj procedure above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the - * result of calling Tcl_NewDoubleObj. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewDoubleObj(dblValue, file, line) - register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewDoubleObj(dblValue, file, line) - register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - return Tcl_NewDoubleObj(dblValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetDoubleObj -- - * - * Modify an object to be a double object and to have the specified - * double value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetDoubleObj(objPtr, dblValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register double dblValue; /* Double used to set the object's value. */ -{ - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetDoubleObj called with shared object"); - } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; - Tcl_InvalidateStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetDoubleFromObj -- - * - * Attempt to return a double from the Tcl object "objPtr". If the - * object is not already a double, an attempt will be made to convert - * it to one. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If the object is not already a double, the conversion will free - * any old internal representation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a double. */ - register double *dblPtr; /* Place to store resulting double. */ -{ - register int result; - - if (objPtr->typePtr == &tclDoubleType) { - *dblPtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } - - result = SetDoubleFromAny(interp, objPtr); - if (result == TCL_OK) { - *dblPtr = objPtr->internalRep.doubleValue; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SetDoubleFromAny -- - * - * Attempt to generate an double-precision floating point internal form - * for the Tcl object "objPtr". - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If no error occurs, a double is stored as "objPtr"s internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetDoubleFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - double newDouble; - int length; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an double. Numbers can't have embedded - * NULLs. We use an implementation here that doesn't report errors in - * interp if interp is NULL. - */ - - errno = 0; - newDouble = strtod(string, &end); - if (end == string) { - badDouble: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to an int. - */ - - char buf[100]; - sprintf(buf, "expected floating-point number but got \"%.50s\"", - string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } - return TCL_ERROR; - } - if (errno != 0) { - if (interp != NULL) { - TclExprFloatError(interp, newDouble); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badDouble; - } - - /* - * The conversion to double succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.doubleValue = newDouble; - objPtr->typePtr = &tclDoubleType; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfDouble -- - * - * Update the string representation for a double-precision floating - * point object. This must obey the current tcl_precision value for - * double-to-string conversions. Note: This procedure does not free an - * existing old string rep so storage will be lost if this has not - * already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the double-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfDouble(objPtr) - register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ -{ - char buffer[TCL_DOUBLE_SPACE]; - register int len; - - Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, - buffer); - len = strlen(buffer); - - objPtr->bytes = (char *) ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewIntObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj to create a new integer object end up calling the - * debugging procedure Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewIntObj - -Tcl_Obj * -Tcl_NewIntObj(intValue) - register int intValue; /* Int used to initialize the new object. */ -{ - return Tcl_DbNewLongObj((long)intValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewIntObj(intValue) - register int intValue; /* Int used to initialize the new object. */ -{ - register Tcl_Obj *objPtr; - - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (long)intValue; - objPtr->typePtr = &tclIntType; - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetIntObj -- - * - * Modify an object to be an integer and to have the specified integer - * value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetIntObj(objPtr, intValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register int intValue; /* Integer used to set object's value. */ -{ - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetIntObj called with shared object"); - } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = (long) intValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); -} - - - -/* - *---------------------------------------------------------------------- - * Tcl_ParseStringToInts -- - *---------------------------------------------------------------------- - * DESCRIPTION - * Parses a string to both a machine signed integer and a machine - * signed long (and, depending on the platform, these may be the same - * size). All errors, including overflow, are detected. The three - * formats accepted are decimal, octal, and hexadecimal. - * - * This function forms the canonical arbiter of what is and is not - * an integer. This function can be used to parse only, without - * returning any numerical results. - * - * All formats (decimal, octal, hexadecimal) allow whitespace both - * before and after the digits of the number. - * - * All formats (decimal, octal, hexadecimal) allow an arbitrary number - * of unary sign operators before the number (+ and -). The number - * will be negated if the number of "-" operators is odd, and not - * negated if the number is even. The operators are not required to - * be contiguous, and may be separated by whitespace. The operators - * may be separated from the digits by whitespace (this is to be con- - * sistent with current behavior). - * - * A decimal number consists of the following components. - * a)Optional leading whitespace. - * b)An arbitrary number of leading "-" and "+" unary operators, - * which may be separated by whitespace, and may be separated - * from the digits of the number by whitespace. - * c)The digits of the number, which may not begin with "0", and - * must be contiguous. - * d)Optional trailing whitespace. - * - * A decimal number is illegal if it is effectively positive but - * is larger than the maximum positive integer of the size being - * considered. By "effectively" positive, I mean having an even - * number of unary "-" operators (including zero of them). - * - * A decimal number is also illegal if it is effectively negative - * but less than the maximum negative integer of the size being - * considered. - * - * An octal number is just like a decimal number, except that its - * first digit is zero, and no digit may exceed "7". An octal number - * is illegal only if the configuration of 1-bits specified before - * negation exceeds the ability of the machine integer being - * considered to hold them--an octal number is exempt from sign - * considerations. - * - * A hexadecimal number is just like an octal number, except that - * the first two digits must be "0x" or "0X", and the digits in - * the number may be 0-9, A-F, and a-f. Again, a hexadecimal number - * is exempt from sign considerations, and will be declared illegal - * only if the bit pattern before possible negation will not fit in - * the machine integer being considered. - * - * The descriptions of legal and illegal above carry over to long - * integers. A string may represent a valid long integer but an - * invalid integer. In all cases, the criteria for illegality is - * the same. - * - * Negation in all cases is carried out in the two's complement - * fashion (i.e. one's complement plus one). - * - * LEGALITY/ILLEGALITY EXAMPLES - * Below are listed several examples which illustrate what is legal and - * what is illegal, and why. Assume a 32-bit machine integer in - * standard 2's complement configuration. - * - * 4000000000 (illegal) - * Illegal because a positive number is specified which is larger - * than the largest machine positive integer. - * 2147483647 (legal) - * This maps to a legal positive machine integer. - * 2147483648 (illegal) - * This number is larger than the largest positive integer. - * -2147483648 (legal) - * This number is a legal negative integer. - * ----2147483648 (illegal) - * The number is effectively positive, but will not fit into - * a positive integer. - * -----2147483648 (legal) - * The number is effectively negative, and will fit into a negative - * machine integer. - * + - +++ - + - + ---- 0000000000000000 (legal) - * Any number of unary + and - operators may be specified, they - * are not required to be contiguous, and any number of zero digits - * are allowed. - * - * + - +++ - + - + ---- 0000000000000008 (illegal) - * The digit "8" cannot appear in an octal number. - * - * +-+-+---- 0x0000000000000000000000000000000000000000000Ff (legal) - * The only consideration for a hexadecimal number is that the - * 1's in the bit pattern fit into 32 bits. They do. - * - * -0xABCDEF01 (legal) - * The number, before negation, fits into 32 bits. - * - * -0x6ABCDEF01 (illegal) - * The number, before negation, does not fit into 32 bits. - * - * 077777777777 (illegal) - * The octal number contains 33 significant bits, and cannot be - * contained by a machine integer. - * 037777777777 (illegal) - * This octal number contains only 32 significant bits, and - * can be contained in a machine integer. - * - * - * INPUTS - * s - * Pointer to string to accept as input. This pointer may not - * be NULL. - * len - * The maximum number of characters to use from s. If this - * parameter is non-negative, this function will treat s as if - * s[len] is the \0 terminator. (By the way, since a valid integer - * can never be specified with zero characters, zero here will - * always result in unsuccessful parses.) If this parameter is - * negative (commonly "-1"), it indicates to use a zero terminator - * in s. - * *err_result - * This is a bit-packed integer which indicates the result - * of the parsing. Bits are set on failure rather than - * success. If this integer tests 0, then no errors occured. - * The pointer to this integer may be NULL, in which case the - * result is not assigned. - * - * Since the ANSI C spec requires that integers be at least - * 16 bits, we have room for 16 flags here. - * - * The bits defined in this integer are listed below. All bits - * not identified are unused and will always be zero. - * a)0x0001 : The input string was syntactically bad and could - * not be parsed as an integer at all, of any - * size (example: illegal characters). In other - * words, the error was not related to size of the - * integer, but rather it was not well-formed. - * b)0x0002 : Could not be parsed as a signed integer--too - * negative. - * c)0x0004 : Could not be parsed as a signed integer--too - * positive. - * d)0x0008 : Could not be parsed as an unsigned integer-- - * too negative (which means < 0). - * e)0x0010 : Could not be parsed as an unsigned integer-- - * too positive. - * f)0x0020 : Could not be parsed as an integer--too many - * bits specified (applies only to octal and hex - * numbers). - * g)0x0040 : Could not be parsed as a signed long--too negative. - * h)0x0080 : Could not be parsed as a signed long--too positive. - * i)0x0100 : Could not be parsed as an unsigned long--too negative. - * j)0x0200 : Could not be parsed as an unsigned long--too positive. - * k)0x0400 : Could not be parsed as an long--too many - * bits specified (applies only to octal and hex - * numbers). - * - * *int_result - * The result of attempted conversion to an integer. If - * flag (a) or flag (f) is set, this result is undefined. - * If at least one of (b) or (c) are set but neither of - * (d) or (e) are set, this contains the bit pattern of a - * valid unsigned integer. - * of flags (b) through (d) are set but none of flags - * - * - *---------------------------------------------------------------------- - */ - -void Tcl_ParseStringToInts(char *s) - { - - } - - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIntFromObj -- - * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object - * can not be represented by an int, an error message is left in - * the interpreter's result unless "interp" is NULL. - * - * Side effects: - * If the object is not already an int, the conversion will free - * any old internal representation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetIntFromObj(interp, objPtr, intPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a int. */ - register int *intPtr; /* Place to store resulting int. */ -{ - register long l; - int result; - - if (objPtr->typePtr != &tclIntType) { - result = SetIntFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; - } - } - l = objPtr->internalRep.longValue; - if (((long)((int)l)) == l) { - *intPtr = (int)objPtr->internalRep.longValue; - return TCL_OK; - } - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "integer value too large to represent as non-long integer", -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SetIntFromAny -- - * - * Attempt to generate an integer internal form for the Tcl object - * "objPtr". - * - * Results: - * The return value is a standard object Tcl result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If no error occurs, an int is stored as "objPtr"s internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetIntFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *end; - int length; - register char *p; - long newLong; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an int. We use an implementation here - * that doesn't report errors in interp if interp is NULL. Note: use - * strtoul instead of strtol for integer conversions to allow full-size - * unsigned numbers, but don't depend on strtoul to handle sign - * characters; it won't in some implementations. - */ - - errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - newLong = -((long)strtoul(p, &end, 0)); - } else if (*p == '+') { - p++; - newLong = strtoul(p, &end, 0); - } else { - newLong = strtoul(p, &end, 0); - } - if (end == p) { - badInteger: - if (interp != NULL) { - /* - * Must copy string before resetting the result in case a caller - * is trying to convert the interpreter's result to an int. - */ - - char buf[100]; - sprintf(buf, "expected integer but got \"%.50s\"", string); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - if (errno == ERANGE) { - if (interp != NULL) { - char *s = "integer value too large to represent"; - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the int. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badInteger; - } - - /* - * The conversion to int succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = newLong; - objPtr->typePtr = &tclIntType; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInt -- - * - * Update the string representation for an integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the int-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInt(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE]; - register int len; - - len = TclFormatInt(buffer, objPtr->internalRep.longValue); - - objPtr->bytes = ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling - * the debugging procedure Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewLongObj result in a call to one of the two - * Tcl_NewLongObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. - * - * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewLongObj - -Tcl_Obj * -Tcl_NewLongObj(longValue) - register long longValue; /* Long integer used to initialize the - * new object. */ -{ - return Tcl_DbNewLongObj(longValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewLongObj(longValue) - register long longValue; /* Long integer used to initialize the - * new object. */ -{ - register Tcl_Obj *objPtr; - - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or - * long integer objects end up calling the debugging procedure - * Tcl_DbNewLongObj instead. We provide two implementations of - * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do - * memory debugging of the core is independent of whether a client - * requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the checkmem command will report the caller's file name and line - * number when reporting objects that haven't been freed. - * - * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, - * this procedure just returns the result of calling Tcl_NewLongObj. - * - * Results: - * The newly created long integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - return Tcl_NewLongObj(longValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetLongObj -- - * - * Modify an object to be an integer object and to have the specified - * long integer value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetLongObj(objPtr, longValue) - register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - register long longValue; /* Long integer used to initialize the - * object's value. */ -{ - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - - if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetLongObj called with shared object"); - } - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetLongFromObj -- - * - * Attempt to return an long integer from the Tcl object "objPtr". If - * the object is not already an int object, an attempt will be made to - * convert it to one. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If the object is not already an int object, the conversion will free - * any old internal representation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetLongFromObj(interp, objPtr, longPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object from which to get a long. */ - register long *longPtr; /* Place to store resulting long. */ -{ - register int result; - - if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; - return TCL_OK; - } - result = SetIntFromAny(interp, objPtr); - if (result == TCL_OK) { - *longPtr = objPtr->internalRep.longValue; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbIncrRefCount -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. - * - * When TCL_MEM_DEBUG is not defined, this procedure just increments - * the reference count of the object. - * - * Results: - * None. - * - * Side effects: - * The object's ref count is incremented. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are registering a - * reference to. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ -#ifdef TCL_MEM_DEBUG - if (objPtr->refCount == 0x61616161) { - fprintf(stderr, "file = %s, line = %d\n", file, line); - fflush(stderr); - panic("Trying to increment refCount of previously disposed object."); - } -#endif - ++(objPtr)->refCount; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbDecrRefCount -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before decrementing the ref count. - * - * When TCL_MEM_DEBUG is not defined, this procedure just decrements - * the reference count of the object. - * - * Results: - * None. - * - * Side effects: - * The object's ref count is incremented. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DbDecrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are releasing a reference - * to. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ -#ifdef TCL_MEM_DEBUG - if (objPtr->refCount == 0x61616161) { - fprintf(stderr, "file = %s, line = %d\n", file, line); - fflush(stderr); - panic("Trying to decrement refCount of previously disposed object."); - } -#endif - if (--(objPtr)->refCount <= 0) { - TclFreeObj(objPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbIsShared -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It tests whether the object has a ref - * count greater than one. - * - * When TCL_MEM_DEBUG is not defined, this procedure just tests - * if the object has a ref count greater than one. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DbIsShared(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object to test for being shared. */ - char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ -#ifdef TCL_MEM_DEBUG - if (objPtr->refCount == 0x61616161) { - fprintf(stderr, "file = %s, line = %d\n", file, line); - fflush(stderr); - panic("Trying to check whether previously disposed object is shared."); - } -#endif - return ((objPtr)->refCount > 1); -} - -//$Log: tclobj.c,v $ -//Revision 1.3 2001/09/12 18:12:20 dtashley -//Closing projects as I return to school for Ph.D. -// -//Revision 1.2 2001/08/18 07:22:48 dtashley -//Log added in preparation for surgery on integer parsing functionality. -// -/* $History: tclobj.c $ - * - * ***************** Version 1 ***************** - * User: Dtashley Date: 1/02/01 Time: 1:35a - * Created in $/IjuScripter, IjuConsole/Source/Tcl Base - * Initial check-in. - */ - -/* End of TCLOBJ.C */ \ No newline at end of file +/* $Header$ */ +/* + * tclObj.c -- + * + * This file contains Tcl object-related procedures that are used by + * many Tcl commands. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1999 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclobj.c,v 1.3 2001/09/12 18:12:20 dtashley Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Table of all object types. + */ + +static Tcl_HashTable typeTable; +static int typeTableInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(tableMutex) + +/* + * Head of the list of free Tcl_Obj structs we maintain. + */ + +Tcl_Obj *tclFreeObjList = NULL; + +/* + * The object allocator is single threaded. This mutex is referenced + * by the TclNewObj macro, however, so must be visible. + */ + +#ifdef TCL_THREADS +Tcl_Mutex tclObjMutex; +#endif + +/* + * Pointer to a heap-allocated string of length zero that the Tcl core uses + * as the value of an empty string representation for an object. This value + * is shared by all new objects allocated by Tcl_NewObj. + */ + +static char emptyString; +char *tclEmptyStringRep = &emptyString; + +/* + * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed + * (by TclFreeObj). + */ + +#ifdef TCL_COMPILE_STATS +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +#endif /* TCL_COMPILE_STATS */ + +/* + * Prototypes for procedures defined later in this file: + */ + +static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The structures below defines the Tcl object types defined in this file by + * means of procedures that can be invoked by generic object code. See also + * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager + * implementations. + */ + +Tcl_ObjType tclBooleanType = { + "boolean", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfBoolean, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclDoubleType = { + "double", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclIntType = { + "int", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ +}; + +/* + *------------------------------------------------------------------------- + * + * TclInitObjectSubsystem -- + * + * This procedure is invoked to perform once-only initialization of + * the type table. It also registers the object types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined object types "typeTable" with + * builtin object types defined in this file. + * + *------------------------------------------------------------------------- + */ + +void +TclInitObjSubsystem() +{ + Tcl_MutexLock(&tableMutex); + typeTableInitialized = 1; + Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); + Tcl_MutexUnlock(&tableMutex); + + Tcl_RegisterObjType(&tclBooleanType); + Tcl_RegisterObjType(&tclByteArrayType); + Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclIntType); + Tcl_RegisterObjType(&tclStringType); + Tcl_RegisterObjType(&tclListType); + Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclProcBodyType); + +#ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); + tclObjsAlloced = 0; + tclObjsFreed = 0; + Tcl_MutexUnlock(&tclObjMutex); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeCompExecEnv -- + * + * This procedure is called by Tcl_Finalize to clean up the Tcl + * compilation and execution environment so it can later be properly + * reinitialized. + * + * Results: + * None. + * + * Side effects: + * Cleans up the compilation and execution environment + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeCompExecEnv() +{ + Tcl_MutexLock(&tableMutex); + if (typeTableInitialized) { + Tcl_DeleteHashTable(&typeTable); + typeTableInitialized = 0; + } + Tcl_MutexUnlock(&tableMutex); + Tcl_MutexLock(&tclObjMutex); + tclFreeObjList = NULL; + Tcl_MutexUnlock(&tclObjMutex); + + TclFinalizeCompilation(); + TclFinalizeExecution(); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_RegisterObjType -- + * + * This procedure is called to register a new Tcl object type + * in the table of all object types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the Tcl type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ + +void +Tcl_RegisterObjType(typePtr) + Tcl_ObjType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + + /* + * If there's already an object type with the given name, remove it. + */ + Tcl_MutexLock(&tableMutex); + hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendAllObjTypes -- + * + * This procedure appends onto the argument object the name of each + * object type as a list element. This includes the builtin object + * types (e.g. int, list) as well as those added using + * Tcl_NewObj. These names can be used, for example, with + * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType + * structures. + * + * Results: + * The return value is normally TCL_OK; in this case the object + * referenced by objPtr has each type name appended to it. If an + * error occurs, TCL_ERROR is returned and the interpreter's result + * holds an error message. + * + * Side effects: + * If necessary, the object referenced by objPtr is converted into + * a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppendAllObjTypes(interp, objPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the + * name of each registered type is appended + * as a list element. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_ObjType *typePtr; + int result; + + /* + * This code assumes that types names do not contain embedded NULLs. + */ + + Tcl_MutexLock(&tableMutex); + for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + result = Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(typePtr->name, -1)); + if (result == TCL_ERROR) { + Tcl_MutexUnlock(&tableMutex); + return result; + } + } + Tcl_MutexUnlock(&tableMutex); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetObjType -- + * + * This procedure looks up an object type by name. + * + * Results: + * If an object type with name matching "typeName" is found, a pointer + * to its Tcl_ObjType structure is returned; otherwise, NULL is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjType * +Tcl_GetObjType(typeName) + char *typeName; /* Name of Tcl object type to look up. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_ObjType *typePtr; + + Tcl_MutexLock(&tableMutex); + hPtr = Tcl_FindHashEntry(&typeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + Tcl_MutexUnlock(&tableMutex); + return typePtr; + } + Tcl_MutexUnlock(&tableMutex); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertToType -- + * + * Convert the Tcl object "objPtr" to have type "typePtr" if possible. + * + * Results: + * The return value is TCL_OK on success and TCL_ERROR on failure. If + * TCL_ERROR is returned, then the interpreter's result contains an + * error message unless "interp" is NULL. Passing a NULL "interp" + * allows this procedure to be used as a test whether the conversion + * could be done (and in fact was done). + * + * Side effects: + * Any internal representation for the old type is freed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertToType(interp, objPtr, typePtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ + Tcl_ObjType *typePtr; /* The target type. */ +{ + if (objPtr->typePtr == typePtr) { + return TCL_OK; + } + + /* + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal + * form as appropriate for the target type. This frees the old internal + * representation. + */ + + return typePtr->setFromAnyProc(interp, objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote + * the empty string. These objects have a NULL object type and NULL + * string representation byte pointer. Type managers call this routine + * to allocate new objects that they further initialize. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewObj. + * + * Results: + * The result is a newly allocated object that represents the empty + * string. The new object's typePtr is set NULL and its ref count + * is set to 0. + * + * Side effects: + * If compiling with TCL_COMPILE_STATS, this procedure increments + * the global count of allocated objects (tclObjsAlloced). + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewObj + +Tcl_Obj * +Tcl_NewObj() +{ + return Tcl_DbNewObj("unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewObj() +{ + register Tcl_Obj *objPtr; + + /* + * Allocate the object using the list of free Tcl_Obj structs + * we maintain. + */ + + Tcl_MutexLock(&tclObjMutex); + if (tclFreeObjList == NULL) { + TclAllocateFreeObjects(); + } + objPtr = tclFreeObjList; + tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; + + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + tclObjsAlloced++; +#endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the + * empty string. It is the same as the Tcl_NewObj procedure above + * except that it calls Tcl_DbCkalloc directly with the file name and + * line number from its caller. This simplifies debugging since then + * the checkmem command will report the correct file name and line + * number when reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewObj. + * + * Results: + * The result is a newly allocated that represents the empty string. + * The new object's typePtr is set NULL and its ref count is set to 0. + * + * Side effects: + * If compiling with TCL_COMPILE_STATS, this procedure increments + * the global count of allocated objects (tclObjsAlloced). + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewObj(file, line) + register char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + register int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + /* + * If debugging Tcl's memory usage, allocate the object using ckalloc. + * Otherwise, allocate it using the list of free Tcl_Obj structs we + * maintain. + */ + + objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); + tclObjsAlloced++; + Tcl_MutexUnlock(&tclObjMutex); +#endif /* TCL_COMPILE_STATS */ + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewObj(file, line) + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewObj(); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclAllocateFreeObjects -- + * + * Procedure to allocate a number of free Tcl_Objs. This is done using + * a single ckalloc to reduce the overhead for Tcl_Obj allocation. + * + * Assumes mutex is held. + * + * Results: + * None. + * + * Side effects: + * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the + * first of a number of free Tcl_Obj's linked together by their + * internalRep.otherValuePtrs. + * + *---------------------------------------------------------------------- + */ + +#define OBJS_TO_ALLOC_EACH_TIME 100 + +void +TclAllocateFreeObjects() +{ + Tcl_Obj tmp[2]; + size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ + ((int)(&(tmp[1])) - (int)(&(tmp[0]))); + size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); + char *basePtr; + register Tcl_Obj *prevPtr, *objPtr; + register int i; + + basePtr = (char *) ckalloc(bytesToAlloc); + memset(basePtr, 0, bytesToAlloc); + + prevPtr = NULL; + objPtr = (Tcl_Obj *) basePtr; + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { + objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; + prevPtr = objPtr; + objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); + } + tclFreeObjList = prevPtr; +} +#undef OBJS_TO_ALLOC_EACH_TIME + +/* + *---------------------------------------------------------------------- + * + * TclFreeObj -- + * + * This procedure frees the memory associated with the argument + * object. It is called by the tcl.h macro Tcl_DecrRefCount when an + * object's ref count is zero. It is only "public" since it must + * be callable by that macro wherever the macro is used. It should not + * be directly called by clients. + * + * Results: + * None. + * + * Side effects: + * Deallocates the storage for the object's Tcl_Obj structure + * after deallocating the string representation and calling the + * type-specific Tcl_FreeInternalRepProc to deallocate the object's + * internal representation. If compiling with TCL_COMPILE_STATS, + * this procedure increments the global count of freed objects + * (tclObjsFreed). + * + *---------------------------------------------------------------------- + */ + +void +TclFreeObj(objPtr) + register Tcl_Obj *objPtr; /* The object to be freed. */ +{ + register Tcl_ObjType *typePtr = objPtr->typePtr; + +#ifdef TCL_MEM_DEBUG + if ((objPtr)->refCount < -1) { + panic("Reference count for %lx was negative", objPtr); + } +#endif /* TCL_MEM_DEBUG */ + + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(objPtr); + } + Tcl_InvalidateStringRep(objPtr); + + /* + * If debugging Tcl's memory usage, deallocate the object using ckfree. + * Otherwise, deallocate it by adding it onto the list of free + * Tcl_Obj structs we maintain. + */ + + Tcl_MutexLock(&tclObjMutex); +#ifdef TCL_MEM_DEBUG + ckfree((char *) objPtr); +#else + objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; + tclFreeObjList = objPtr; +#endif /* TCL_MEM_DEBUG */ + +#ifdef TCL_COMPILE_STATS + tclObjsFreed++; +#endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DuplicateObj -- + * + * Create and return a new object that is a duplicate of the argument + * object. + * + * Results: + * The return value is a pointer to a newly created Tcl_Obj. This + * object has reference count 0 and the same type, if any, as the + * source object objPtr. Also: + * 1) If the source object has a valid string rep, we copy it; + * otherwise, the duplicate's string rep is set NULL to mark + * it invalid. + * 2) If the source object has an internal representation (i.e. its + * typePtr is non-NULL), the new object's internal rep is set to + * a copy; otherwise the new internal rep is marked invalid. + * + * Side effects: + * What constitutes "copying" the internal representation depends on + * the type. For example, if the argument object is a list, + * the element objects it points to will not actually be copied but + * will be shared with the duplicate list. That is, the ref counts of + * the element objects will be incremented. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_DuplicateObj(objPtr) + register Tcl_Obj *objPtr; /* The object to duplicate. */ +{ + register Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_Obj *dupPtr; + + TclNewObj(dupPtr); + + if (objPtr->bytes == NULL) { + dupPtr->bytes = NULL; + } else if (objPtr->bytes != tclEmptyStringRep) { + int len = objPtr->length; + + dupPtr->bytes = (char *) ckalloc((unsigned) len+1); + if (len > 0) { + memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, + (unsigned) len); + } + dupPtr->bytes[len] = '\0'; + dupPtr->length = len; + } + + if (typePtr != NULL) { + if (typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(objPtr, dupPtr); + } + } + return dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetString -- + * + * Returns the string representation byte array pointer for an object. + * + * Results: + * Returns a pointer to the string representation of objPtr. The byte + * array referenced by the returned pointer must not be modified by the + * caller. Furthermore, the caller must copy the bytes if they need to + * retain them since the object's string rep can change as a result of + * other operations. + * + * Side effects: + * May call the object's updateStringProc to update the string + * representation from the internal representation. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetString(objPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be returned. */ +{ + if (objPtr->bytes != NULL) { + return objPtr->bytes; + } + + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + (*objPtr->typePtr->updateStringProc)(objPtr); + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStringFromObj -- + * + * Returns the string representation's byte array pointer and length + * for an object. + * + * Results: + * Returns a pointer to the string representation of objPtr. If + * lengthPtr isn't NULL, the length of the string representation is + * stored at *lengthPtr. The byte array referenced by the returned + * pointer must not be modified by the caller. Furthermore, the + * caller must copy the bytes if they need to retain them since the + * object's string rep can change as a result of other operations. + * + * Side effects: + * May call the object's updateStringProc to update the string + * representation from the internal representation. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetStringFromObj(objPtr, lengthPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be returned. */ + register int *lengthPtr; /* If non-NULL, the location where the + * string rep's byte array length should be + * stored. If NULL, no length is stored. */ +{ + if (objPtr->bytes != NULL) { + if (lengthPtr != NULL) { + *lengthPtr = objPtr->length; + } + return objPtr->bytes; + } + + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + (*objPtr->typePtr->updateStringProc)(objPtr); + if (lengthPtr != NULL) { + *lengthPtr = objPtr->length; + } + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InvalidateStringRep -- + * + * This procedure is called to invalidate an object's string + * representation. + * + * Results: + * None. + * + * Side effects: + * Deallocates the storage for any old string representation, then + * sets the string representation NULL to mark it invalid. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InvalidateStringRep(objPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be freed. */ +{ + if (objPtr->bytes != NULL) { + if (objPtr->bytes != tclEmptyStringRep) { + ckfree((char *) objPtr->bytes); + } + objPtr->bytes = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewBooleanObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new boolean object and + * initializes it from the argument boolean value. A nonzero + * "boolValue" is coerced to 1. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewBooleanObj + +Tcl_Obj * +Tcl_NewBooleanObj(boolValue) + register int boolValue; /* Boolean used to initialize new object. */ +{ + return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewBooleanObj(boolValue) + register int boolValue; /* Boolean used to initialize new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBooleanObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the + * same as the Tcl_NewBooleanObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewBooleanObj(boolValue, file, line) + register int boolValue; /* Boolean used to initialize new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewBooleanObj(boolValue, file, line) + register int boolValue; /* Boolean used to initialize new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewBooleanObj(boolValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBooleanObj -- + * + * Modify an object to be a boolean object and to have the specified + * boolean value. A nonzero "boolValue" is coerced to 1. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetBooleanObj(objPtr, boolValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register int boolValue; /* Boolean used to set object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetBooleanObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; + Tcl_InvalidateStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBooleanFromObj -- + * + * Attempt to return a boolean from the Tcl object "objPtr". If the + * object is not already a boolean, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a boolean, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get boolean. */ + register int *boolPtr; /* Place to store resulting boolean. */ +{ + register int result; + + result = SetBooleanFromAny(interp, objPtr); + if (result == TCL_OK) { + *boolPtr = (int) objPtr->internalRep.longValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetBooleanFromAny -- + * + * Attempt to generate a boolean internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an integer 1 or 0 is stored as "objPtr"s + * internal representation and the type of "objPtr" is set to boolean. + * + *---------------------------------------------------------------------- + */ + +static int +SetBooleanFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + register char c; + char lowerCase[10]; + int newBool, length; + register int i; + double dbl; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Copy the string converting its characters to lower case. + */ + + for (i = 0; (i < 9) && (i < length); i++) { + c = string[i]; + /* + * Weed out international characters so we can safely operate + * on single bytes. + */ + + if (c & 0x80) { + goto badBoolean; + } + if (Tcl_UniCharIsUpper(UCHAR(c))) { + c = (char) Tcl_UniCharToLower(UCHAR(c)); + } + lowerCase[i] = c; + } + lowerCase[i] = 0; + + /* + * Parse the string as a boolean. We use an implementation here that + * doesn't report errors in interp if interp is NULL. + */ + + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + newBool = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + newBool = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { + newBool = 1; + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + newBool = 0; + } else { + goto badBoolean; + } + } else { + /* + * Still might be a string containing the characters representing an + * int or double that wasn't handled above. This would be a string + * like "27" or "1.0" that is non-zero and not "1". Such a string + * whould result in the boolean value true. We try converting to + * double. If that succeeds and the resulting double is non-zero, we + * have a "true". Note that numbers can't have embedded NULLs. + */ + + dbl = strtod(string, &end); + if (end == string) { + goto badBoolean; + } + + /* + * Make sure the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end != (string+length)) { + goto badBoolean; + } + newBool = (dbl != 0.0); + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * Tcl_GetStringFromObj, to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = newBool; + objPtr->typePtr = &tclBooleanType; + return TCL_OK; + + badBoolean: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to a boolean. + */ + + char buf[100]; + sprintf(buf, "expected boolean value but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfBoolean -- + * + * Update the string representation for a boolean object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the boolean-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfBoolean(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char *s = ckalloc((unsigned) 2); + + s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); + s[1] = '\0'; + objPtr->bytes = s; + objPtr->length = 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewDoubleObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new double object and + * initializes it from the argument double value. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewDoubleObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewDoubleObj + +Tcl_Obj * +Tcl_NewDoubleObj(dblValue) + register double dblValue; /* Double used to initialize the object. */ +{ + return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewDoubleObj(dblValue) + register double dblValue; /* Double used to initialize the object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewDoubleObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new double objects. It is the + * same as the Tcl_NewDoubleObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewDoubleObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewDoubleObj(dblValue, file, line) + register double dblValue; /* Double used to initialize the object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewDoubleObj(dblValue, file, line) + register double dblValue; /* Double used to initialize the object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewDoubleObj(dblValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetDoubleObj -- + * + * Modify an object to be a double object and to have the specified + * double value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetDoubleObj(objPtr, dblValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register double dblValue; /* Double used to set the object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetDoubleObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; + Tcl_InvalidateStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetDoubleFromObj -- + * + * Attempt to return a double from the Tcl object "objPtr". If the + * object is not already a double, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a double, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a double. */ + register double *dblPtr; /* Place to store resulting double. */ +{ + register int result; + + if (objPtr->typePtr == &tclDoubleType) { + *dblPtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + + result = SetDoubleFromAny(interp, objPtr); + if (result == TCL_OK) { + *dblPtr = objPtr->internalRep.doubleValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetDoubleFromAny -- + * + * Attempt to generate an double-precision floating point internal form + * for the Tcl object "objPtr". + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a double is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetDoubleFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + double newDouble; + int length; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an double. Numbers can't have embedded + * NULLs. We use an implementation here that doesn't report errors in + * interp if interp is NULL. + */ + + errno = 0; + newDouble = strtod(string, &end); + if (end == string) { + badDouble: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected floating-point number but got \"%.50s\"", + string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + return TCL_ERROR; + } + if (errno != 0) { + if (interp != NULL) { + TclExprFloatError(interp, newDouble); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badDouble; + } + + /* + * The conversion to double succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.doubleValue = newDouble; + objPtr->typePtr = &tclDoubleType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfDouble -- + * + * Update the string representation for a double-precision floating + * point object. This must obey the current tcl_precision value for + * double-to-string conversions. Note: This procedure does not free an + * existing old string rep so storage will be lost if this has not + * already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the double-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfDouble(objPtr) + register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ +{ + char buffer[TCL_DOUBLE_SPACE]; + register int len; + + Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, + buffer); + len = strlen(buffer); + + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj to create a new integer object end up calling the + * debugging procedure Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewIntObj result in a call to one of the two + * Tcl_NewIntObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewIntObj + +Tcl_Obj * +Tcl_NewIntObj(intValue) + register int intValue; /* Int used to initialize the new object. */ +{ + return Tcl_DbNewLongObj((long)intValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewIntObj(intValue) + register int intValue; /* Int used to initialize the new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (long)intValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetIntObj -- + * + * Modify an object to be an integer and to have the specified integer + * value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetIntObj(objPtr, intValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register int intValue; /* Integer used to set object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetIntObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; + Tcl_InvalidateStringRep(objPtr); +} + + + +/* + *---------------------------------------------------------------------- + * Tcl_ParseStringToInts -- + *---------------------------------------------------------------------- + * DESCRIPTION + * Parses a string to both a machine signed integer and a machine + * signed long (and, depending on the platform, these may be the same + * size). All errors, including overflow, are detected. The three + * formats accepted are decimal, octal, and hexadecimal. + * + * This function forms the canonical arbiter of what is and is not + * an integer. This function can be used to parse only, without + * returning any numerical results. + * + * All formats (decimal, octal, hexadecimal) allow whitespace both + * before and after the digits of the number. + * + * All formats (decimal, octal, hexadecimal) allow an arbitrary number + * of unary sign operators before the number (+ and -). The number + * will be negated if the number of "-" operators is odd, and not + * negated if the number is even. The operators are not required to + * be contiguous, and may be separated by whitespace. The operators + * may be separated from the digits by whitespace (this is to be con- + * sistent with current behavior). + * + * A decimal number consists of the following components. + * a)Optional leading whitespace. + * b)An arbitrary number of leading "-" and "+" unary operators, + * which may be separated by whitespace, and may be separated + * from the digits of the number by whitespace. + * c)The digits of the number, which may not begin with "0", and + * must be contiguous. + * d)Optional trailing whitespace. + * + * A decimal number is illegal if it is effectively positive but + * is larger than the maximum positive integer of the size being + * considered. By "effectively" positive, I mean having an even + * number of unary "-" operators (including zero of them). + * + * A decimal number is also illegal if it is effectively negative + * but less than the maximum negative integer of the size being + * considered. + * + * An octal number is just like a decimal number, except that its + * first digit is zero, and no digit may exceed "7". An octal number + * is illegal only if the configuration of 1-bits specified before + * negation exceeds the ability of the machine integer being + * considered to hold them--an octal number is exempt from sign + * considerations. + * + * A hexadecimal number is just like an octal number, except that + * the first two digits must be "0x" or "0X", and the digits in + * the number may be 0-9, A-F, and a-f. Again, a hexadecimal number + * is exempt from sign considerations, and will be declared illegal + * only if the bit pattern before possible negation will not fit in + * the machine integer being considered. + * + * The descriptions of legal and illegal above carry over to long + * integers. A string may represent a valid long integer but an + * invalid integer. In all cases, the criteria for illegality is + * the same. + * + * Negation in all cases is carried out in the two's complement + * fashion (i.e. one's complement plus one). + * + * LEGALITY/ILLEGALITY EXAMPLES + * Below are listed several examples which illustrate what is legal and + * what is illegal, and why. Assume a 32-bit machine integer in + * standard 2's complement configuration. + * + * 4000000000 (illegal) + * Illegal because a positive number is specified which is larger + * than the largest machine positive integer. + * 2147483647 (legal) + * This maps to a legal positive machine integer. + * 2147483648 (illegal) + * This number is larger than the largest positive integer. + * -2147483648 (legal) + * This number is a legal negative integer. + * ----2147483648 (illegal) + * The number is effectively positive, but will not fit into + * a positive integer. + * -----2147483648 (legal) + * The number is effectively negative, and will fit into a negative + * machine integer. + * + - +++ - + - + ---- 0000000000000000 (legal) + * Any number of unary + and - operators may be specified, they + * are not required to be contiguous, and any number of zero digits + * are allowed. + * + * + - +++ - + - + ---- 0000000000000008 (illegal) + * The digit "8" cannot appear in an octal number. + * + * +-+-+---- 0x0000000000000000000000000000000000000000000Ff (legal) + * The only consideration for a hexadecimal number is that the + * 1's in the bit pattern fit into 32 bits. They do. + * + * -0xABCDEF01 (legal) + * The number, before negation, fits into 32 bits. + * + * -0x6ABCDEF01 (illegal) + * The number, before negation, does not fit into 32 bits. + * + * 077777777777 (illegal) + * The octal number contains 33 significant bits, and cannot be + * contained by a machine integer. + * 037777777777 (illegal) + * This octal number contains only 32 significant bits, and + * can be contained in a machine integer. + * + * + * INPUTS + * s + * Pointer to string to accept as input. This pointer may not + * be NULL. + * len + * The maximum number of characters to use from s. If this + * parameter is non-negative, this function will treat s as if + * s[len] is the \0 terminator. (By the way, since a valid integer + * can never be specified with zero characters, zero here will + * always result in unsuccessful parses.) If this parameter is + * negative (commonly "-1"), it indicates to use a zero terminator + * in s. + * *err_result + * This is a bit-packed integer which indicates the result + * of the parsing. Bits are set on failure rather than + * success. If this integer tests 0, then no errors occured. + * The pointer to this integer may be NULL, in which case the + * result is not assigned. + * + * Since the ANSI C spec requires that integers be at least + * 16 bits, we have room for 16 flags here. + * + * The bits defined in this integer are listed below. All bits + * not identified are unused and will always be zero. + * a)0x0001 : The input string was syntactically bad and could + * not be parsed as an integer at all, of any + * size (example: illegal characters). In other + * words, the error was not related to size of the + * integer, but rather it was not well-formed. + * b)0x0002 : Could not be parsed as a signed integer--too + * negative. + * c)0x0004 : Could not be parsed as a signed integer--too + * positive. + * d)0x0008 : Could not be parsed as an unsigned integer-- + * too negative (which means < 0). + * e)0x0010 : Could not be parsed as an unsigned integer-- + * too positive. + * f)0x0020 : Could not be parsed as an integer--too many + * bits specified (applies only to octal and hex + * numbers). + * g)0x0040 : Could not be parsed as a signed long--too negative. + * h)0x0080 : Could not be parsed as a signed long--too positive. + * i)0x0100 : Could not be parsed as an unsigned long--too negative. + * j)0x0200 : Could not be parsed as an unsigned long--too positive. + * k)0x0400 : Could not be parsed as an long--too many + * bits specified (applies only to octal and hex + * numbers). + * + * *int_result + * The result of attempted conversion to an integer. If + * flag (a) or flag (f) is set, this result is undefined. + * If at least one of (b) or (c) are set but neither of + * (d) or (e) are set, this contains the bit pattern of a + * valid unsigned integer. + * of flags (b) through (d) are set but none of flags + * + * + *---------------------------------------------------------------------- + */ + +void Tcl_ParseStringToInts(char *s) + { + + } + + + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIntFromObj -- + * + * Attempt to return an int from the Tcl object "objPtr". If the object + * is not already an int, an attempt will be made to convert it to one. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion or if the long integer held by the object + * can not be represented by an int, an error message is left in + * the interpreter's result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetIntFromObj(interp, objPtr, intPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a int. */ + register int *intPtr; /* Place to store resulting int. */ +{ + register long l; + int result; + + if (objPtr->typePtr != &tclIntType) { + result = SetIntFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + l = objPtr->internalRep.longValue; + if (((long)((int)l)) == l) { + *intPtr = (int)objPtr->internalRep.longValue; + return TCL_OK; + } + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent as non-long integer", -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SetIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + long newLong; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoul instead of strtol for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoul to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newLong = -((long)strtoul(p, &end, 0)); + } else if (*p == '+') { + p++; + newLong = strtoul(p, &end, 0); + } else { + newLong = strtoul(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = newLong; + objPtr->typePtr = &tclIntType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInt -- + * + * Update the string representation for an integer object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the int-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; + + len = TclFormatInt(buffer, objPtr->internalRep.longValue); + + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewLongObj to create a new long integer object end up calling + * the debugging procedure Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewLongObj result in a call to one of the two + * Tcl_NewLongObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewLongObj + +Tcl_Obj * +Tcl_NewLongObj(longValue) + register long longValue; /* Long integer used to initialize the + * new object. */ +{ + return Tcl_DbNewLongObj(longValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewLongObj(longValue) + register long longValue; /* Long integer used to initialize the + * new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or + * long integer objects end up calling the debugging procedure + * Tcl_DbNewLongObj instead. We provide two implementations of + * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do + * memory debugging of the core is independent of whether a client + * requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, + * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and + * line number from its caller. This simplifies debugging since then + * the checkmem command will report the caller's file name and line + * number when reporting objects that haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this procedure just returns the result of calling Tcl_NewLongObj. + * + * Results: + * The newly created long integer object is returned. This object + * will have an invalid string representation. The returned object has + * ref count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewLongObj(longValue, file, line) + register long longValue; /* Long integer used to initialize the + * new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewLongObj(longValue, file, line) + register long longValue; /* Long integer used to initialize the + * new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewLongObj(longValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetLongObj -- + * + * Modify an object to be an integer object and to have the specified + * long integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetLongObj(objPtr, longValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register long longValue; /* Long integer used to initialize the + * object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetLongObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + Tcl_InvalidateStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetLongFromObj -- + * + * Attempt to return an long integer from the Tcl object "objPtr". If + * the object is not already an int object, an attempt will be made to + * convert it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetLongFromObj(interp, objPtr, longPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a long. */ + register long *longPtr; /* Place to store resulting long. */ +{ + register int result; + + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; + } + result = SetIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *longPtr = objPtr->internalRep.longValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIncrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just increments + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbIncrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are registering a + * reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to increment refCount of previously disposed object."); + } +#endif + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbDecrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before decrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just decrements + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbDecrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are releasing a reference + * to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to decrement refCount of previously disposed object."); + } +#endif + if (--(objPtr)->refCount <= 0) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIsShared -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref + * count greater than one. + * + * When TCL_MEM_DEBUG is not defined, this procedure just tests + * if the object has a ref count greater than one. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbIsShared(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object to test for being shared. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to check whether previously disposed object is shared."); + } +#endif + return ((objPtr)->refCount > 1); +} + +/* End of tclobj.c */