diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 2141 |
1 files changed, 2141 insertions, 0 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c new file mode 100644 index 0000000..62f892c --- /dev/null +++ b/generic/tclObj.c @@ -0,0 +1,2141 @@ +/* + * tclObj.c -- + * + * This file contains Tcl object-related procedures that are used by + * many Tcl commands. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclObj.c 1.47 97/10/30 13:39:00 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Table of all object types. + */ + +static Tcl_HashTable typeTable; +static int typeTableInitialized = 0; /* 0 means not yet initialized. */ + +/* + * Head of the list of free Tcl_Objs we maintain. + */ + +Tcl_Obj *tclFreeObjList = NULL; + +/* + * Pointer to a heap-allocated string of length zero that the Tcl core uses + * as the value of an empty string representation for an object. This value + * is shared by all new objects allocated by Tcl_NewObj. + */ + +char *tclEmptyStringRep = NULL; + +/* + * Count of the number of Tcl objects every 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 void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FinalizeTypeTable _ANSI_ARGS_((void)); +static void FinalizeFreeObjList _ANSI_ARGS_((void)); +static void InitTypeTable _ANSI_ARGS_((void)); +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 */ + DupBooleanInternalRep, /* dupIntRepProc */ + UpdateStringOfBoolean, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclDoubleType = { + "double", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupDoubleInternalRep, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclIntType = { + "int", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupIntInternalRep, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ +}; + +/* + *-------------------------------------------------------------- + * + * InitTypeTable -- + * + * 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. It also initializes the + * value of tclEmptyStringRep, which points to the heap-allocated + * string of length zero used as the string representation for + * newly-created objects. + * + *-------------------------------------------------------------- + */ + +static void +InitTypeTable() +{ + typeTableInitialized = 1; + + Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); + Tcl_RegisterObjType(&tclBooleanType); + Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclIntType); + Tcl_RegisterObjType(&tclStringType); + Tcl_RegisterObjType(&tclListType); + Tcl_RegisterObjType(&tclByteCodeType); + + tclEmptyStringRep = (char *) ckalloc((unsigned) 1); + tclEmptyStringRep[0] = '\0'; +} + +/* + *---------------------------------------------------------------------- + * + * FinalizeTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of Tcl + * object types. + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of object types, "typeTable". + * Then sets "typeTableInitialized" to 0 so that the Tcl type system + * will be properly reinitialized if Tcl is restarted. Also deallocates + * the storage for tclEmptyStringRep. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeTypeTable() +{ + if (typeTableInitialized) { + Tcl_DeleteHashTable(&typeTable); + ckfree(tclEmptyStringRep); + typeTableInitialized = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * FinalizeFreeObjList -- + * + * Resets the free object list so it can later be reinitialized. + * + * Results: + * None. + * + * Side effects: + * Resets the value of tclFreeObjList. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeFreeObjList() +{ + tclFreeObjList = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeCompExecEnv -- + * + * Clean up the compiler execution environment so it can later be + * properly reinitialized. + * + * Results: + * None. + * + * Side effects: + * Cleans up the execution environment + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeCompExecEnv() +{ + FinalizeTypeTable(); + FinalizeFreeObjList(); + TclFinalizeExecEnv(); +} + +/* + *-------------------------------------------------------------- + * + * 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 (!typeTableInitialized) { + InitTypeTable(); + } + + /* + * If there's already an object type with the given name, remove it. + */ + + 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_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_CreateObjType. 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; + + if (!typeTableInitialized) { + InitTypeTable(); + } + + /* + * This code assumes that types names do not contain embedded NULLs. + */ + + 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) { + return result; + } + } + 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; + + if (!typeTableInitialized) { + InitTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&typeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + return typePtr; + } + 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_Objs we maintain. + */ + + 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 */ + 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_Objs 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 + tclObjsAlloced++; +#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. + * + * 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 */ + + Tcl_InvalidateStringRep(objPtr); + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(objPtr); + } + + /* + * If debugging Tcl's memory usage, deallocate the object using ckfree. + * Otherwise, deallocate it by adding it onto the list of free + * Tcl_Objs we maintain. + */ + +#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_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) { + typePtr->dupIntRepProc(objPtr, dupPtr); + } + return dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + } + + 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"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * DupBooleanInternalRep -- + * + * Initialize the internal representation of a boolean Tcl_Obj to a + * copy of the internal representation of an existing boolean object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the boolean (an integer) + * corresponding to "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupBooleanInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; + copyPtr->typePtr = &tclBooleanType; +} + +/* + *---------------------------------------------------------------------- + * + * 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 = TclGetStringFromObj(objPtr, &length); + + /* + * Copy the string converting its characters to lower case. + */ + + for (i = 0; (i < 9) && (i < length); i++) { + c = string[i]; + if (isupper(UCHAR(c))) { + c = (char) tolower(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))) { + 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"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * DupDoubleInternalRep -- + * + * Initialize the internal representation of a double Tcl_Obj to a + * copy of the internal representation of an existing double object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the double precision floating + * point number corresponding to "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupDoubleInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue; + copyPtr->typePtr = &tclDoubleType; +} + +/* + *---------------------------------------------------------------------- + * + * 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 = TclGetStringFromObj(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))) { + 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"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * DupIntInternalRep -- + * + * Initialize the internal representation of an int Tcl_Obj to a + * copy of the internal representation of an existing int object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the integer corresponding to + * "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupIntInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; + copyPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * 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 = TclGetStringFromObj(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++) { + /* 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); + } + 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))) { + 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_DOUBLE_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"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * 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 adding 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 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_DbDecrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding 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. 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 decrements + * the reference count of the object and throws it away if the count + * is 0 or less. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbIsShared(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding 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 check whether previously disposed object is shared."); + } +#endif + return ((objPtr)->refCount > 1); +} |