/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclobj.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclobj.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sf_code/esrgpcpj/shared/tcl_base/tclobj.c revision 25 by dashley, Sat Oct 8 06:43:03 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclobj.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $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 */  
1    /* $Header$ */
2    /*
3     * tclObj.c --
4     *
5     *      This file contains Tcl object-related procedures that are used by
6     *      many Tcl commands.
7     *
8     * Copyright (c) 1995-1997 Sun Microsystems, Inc.
9     * Copyright (c) 1999 by Scriptics Corporation.
10     *
11     * See the file "license.terms" for information on usage and redistribution
12     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13     *
14     * RCS: @(#) $Id: tclobj.c,v 1.3 2001/09/12 18:12:20 dtashley Exp $
15     */
16    
17    #include "tclInt.h"
18    #include "tclPort.h"
19    
20    /*
21     * Table of all object types.
22     */
23    
24    static Tcl_HashTable typeTable;
25    static int typeTableInitialized = 0;    /* 0 means not yet initialized. */
26    TCL_DECLARE_MUTEX(tableMutex)
27    
28    /*
29     * Head of the list of free Tcl_Obj structs we maintain.
30     */
31    
32    Tcl_Obj *tclFreeObjList = NULL;
33    
34    /*
35     * The object allocator is single threaded.  This mutex is referenced
36     * by the TclNewObj macro, however, so must be visible.
37     */
38    
39    #ifdef TCL_THREADS
40    Tcl_Mutex tclObjMutex;
41    #endif
42    
43    /*
44     * Pointer to a heap-allocated string of length zero that the Tcl core uses
45     * as the value of an empty string representation for an object. This value
46     * is shared by all new objects allocated by Tcl_NewObj.
47     */
48    
49    static char emptyString;
50    char *tclEmptyStringRep = &emptyString;
51    
52    /*
53     * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed
54     * (by TclFreeObj).
55     */
56    
57    #ifdef TCL_COMPILE_STATS
58    long tclObjsAlloced = 0;
59    long tclObjsFreed = 0;
60    #endif /* TCL_COMPILE_STATS */
61    
62    /*
63     * Prototypes for procedures defined later in this file:
64     */
65    
66    static int              SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
67                                Tcl_Obj *objPtr));
68    static int              SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
69                                Tcl_Obj *objPtr));
70    static int              SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
71                                Tcl_Obj *objPtr));
72    static void             UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
73    static void             UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
74    static void             UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
75    
76    /*
77     * The structures below defines the Tcl object types defined in this file by
78     * means of procedures that can be invoked by generic object code. See also
79     * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
80     * implementations.
81     */
82    
83    Tcl_ObjType tclBooleanType = {
84        "boolean",                          /* name */
85        (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
86        (Tcl_DupInternalRepProc *) NULL,    /* dupIntRepProc */
87        UpdateStringOfBoolean,              /* updateStringProc */
88        SetBooleanFromAny                   /* setFromAnyProc */
89    };
90    
91    Tcl_ObjType tclDoubleType = {
92        "double",                           /* name */
93        (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
94        (Tcl_DupInternalRepProc *) NULL,    /* dupIntRepProc */
95        UpdateStringOfDouble,               /* updateStringProc */
96        SetDoubleFromAny                    /* setFromAnyProc */
97    };
98    
99    Tcl_ObjType tclIntType = {
100        "int",                              /* name */
101        (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
102        (Tcl_DupInternalRepProc *) NULL,    /* dupIntRepProc */
103        UpdateStringOfInt,                  /* updateStringProc */
104        SetIntFromAny                       /* setFromAnyProc */
105    };
106    
107    /*
108     *-------------------------------------------------------------------------
109     *
110     * TclInitObjectSubsystem --
111     *
112     *      This procedure is invoked to perform once-only initialization of
113     *      the type table. It also registers the object types defined in
114     *      this file.
115     *
116     * Results:
117     *      None.
118     *
119     * Side effects:
120     *      Initializes the table of defined object types "typeTable" with
121     *      builtin object types defined in this file.  
122     *
123     *-------------------------------------------------------------------------
124     */
125    
126    void
127    TclInitObjSubsystem()
128    {
129        Tcl_MutexLock(&tableMutex);
130        typeTableInitialized = 1;
131        Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
132        Tcl_MutexUnlock(&tableMutex);
133    
134        Tcl_RegisterObjType(&tclBooleanType);
135        Tcl_RegisterObjType(&tclByteArrayType);
136        Tcl_RegisterObjType(&tclDoubleType);
137        Tcl_RegisterObjType(&tclIntType);
138        Tcl_RegisterObjType(&tclStringType);
139        Tcl_RegisterObjType(&tclListType);
140        Tcl_RegisterObjType(&tclByteCodeType);
141        Tcl_RegisterObjType(&tclProcBodyType);
142    
143    #ifdef TCL_COMPILE_STATS
144        Tcl_MutexLock(&tclObjMutex);
145        tclObjsAlloced = 0;
146        tclObjsFreed = 0;
147        Tcl_MutexUnlock(&tclObjMutex);
148    #endif
149    }
150    
151    /*
152     *----------------------------------------------------------------------
153     *
154     * TclFinalizeCompExecEnv --
155     *
156     *      This procedure is called by Tcl_Finalize to clean up the Tcl
157     *      compilation and execution environment so it can later be properly
158     *      reinitialized.
159     *
160     * Results:
161     *      None.
162     *
163     * Side effects:
164     *      Cleans up the compilation and execution environment
165     *
166     *----------------------------------------------------------------------
167     */
168    
169    void
170    TclFinalizeCompExecEnv()
171    {
172        Tcl_MutexLock(&tableMutex);
173        if (typeTableInitialized) {
174            Tcl_DeleteHashTable(&typeTable);
175            typeTableInitialized = 0;
176        }
177        Tcl_MutexUnlock(&tableMutex);
178        Tcl_MutexLock(&tclObjMutex);
179        tclFreeObjList = NULL;
180        Tcl_MutexUnlock(&tclObjMutex);
181    
182        TclFinalizeCompilation();
183        TclFinalizeExecution();
184    }
185    
186    /*
187     *--------------------------------------------------------------
188     *
189     * Tcl_RegisterObjType --
190     *
191     *      This procedure is called to register a new Tcl object type
192     *      in the table of all object types supported by Tcl.
193     *
194     * Results:
195     *      None.
196     *
197     * Side effects:
198     *      The type is registered in the Tcl type table. If there was already
199     *      a type with the same name as in typePtr, it is replaced with the
200     *      new type.
201     *
202     *--------------------------------------------------------------
203     */
204    
205    void
206    Tcl_RegisterObjType(typePtr)
207        Tcl_ObjType *typePtr;       /* Information about object type;
208                                     * storage must be statically
209                                     * allocated (must live forever). */
210    {
211        register Tcl_HashEntry *hPtr;
212        int new;
213    
214        /*
215         * If there's already an object type with the given name, remove it.
216         */
217        Tcl_MutexLock(&tableMutex);
218        hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
219        if (hPtr != (Tcl_HashEntry *) NULL) {
220            Tcl_DeleteHashEntry(hPtr);
221        }
222    
223        /*
224         * Now insert the new object type.
225         */
226    
227        hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
228        if (new) {
229            Tcl_SetHashValue(hPtr, typePtr);
230        }
231        Tcl_MutexUnlock(&tableMutex);
232    }
233    
234    /*
235     *----------------------------------------------------------------------
236     *
237     * Tcl_AppendAllObjTypes --
238     *
239     *      This procedure appends onto the argument object the name of each
240     *      object type as a list element. This includes the builtin object
241     *      types (e.g. int, list) as well as those added using
242     *      Tcl_NewObj. These names can be used, for example, with
243     *      Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
244     *      structures.
245     *
246     * Results:
247     *      The return value is normally TCL_OK; in this case the object
248     *      referenced by objPtr has each type name appended to it. If an
249     *      error occurs, TCL_ERROR is returned and the interpreter's result
250     *      holds an error message.
251     *
252     * Side effects:
253     *      If necessary, the object referenced by objPtr is converted into
254     *      a list object.
255     *
256     *----------------------------------------------------------------------
257     */
258    
259    int
260    Tcl_AppendAllObjTypes(interp, objPtr)
261        Tcl_Interp *interp;         /* Interpreter used for error reporting. */
262        Tcl_Obj *objPtr;            /* Points to the Tcl object onto which the
263                                     * name of each registered type is appended
264                                     * as a list element. */
265    {
266        register Tcl_HashEntry *hPtr;
267        Tcl_HashSearch search;
268        Tcl_ObjType *typePtr;
269        int result;
270    
271        /*
272         * This code assumes that types names do not contain embedded NULLs.
273         */
274    
275        Tcl_MutexLock(&tableMutex);
276        for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
277                hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
278            typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
279            result = Tcl_ListObjAppendElement(interp, objPtr,
280                    Tcl_NewStringObj(typePtr->name, -1));
281            if (result == TCL_ERROR) {
282                Tcl_MutexUnlock(&tableMutex);
283                return result;
284            }
285        }
286        Tcl_MutexUnlock(&tableMutex);
287        return TCL_OK;
288    }
289    
290    /*
291     *----------------------------------------------------------------------
292     *
293     * Tcl_GetObjType --
294     *
295     *      This procedure looks up an object type by name.
296     *
297     * Results:
298     *      If an object type with name matching "typeName" is found, a pointer
299     *      to its Tcl_ObjType structure is returned; otherwise, NULL is
300     *      returned.
301     *
302     * Side effects:
303     *      None.
304     *
305     *----------------------------------------------------------------------
306     */
307    
308    Tcl_ObjType *
309    Tcl_GetObjType(typeName)
310        char *typeName;             /* Name of Tcl object type to look up. */
311    {
312        register Tcl_HashEntry *hPtr;
313        Tcl_ObjType *typePtr;
314    
315        Tcl_MutexLock(&tableMutex);
316        hPtr = Tcl_FindHashEntry(&typeTable, typeName);
317        if (hPtr != (Tcl_HashEntry *) NULL) {
318            typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
319            Tcl_MutexUnlock(&tableMutex);
320            return typePtr;
321        }
322        Tcl_MutexUnlock(&tableMutex);
323        return NULL;
324    }
325    
326    /*
327     *----------------------------------------------------------------------
328     *
329     * Tcl_ConvertToType --
330     *
331     *      Convert the Tcl object "objPtr" to have type "typePtr" if possible.
332     *
333     * Results:
334     *      The return value is TCL_OK on success and TCL_ERROR on failure. If
335     *      TCL_ERROR is returned, then the interpreter's result contains an
336     *      error message unless "interp" is NULL. Passing a NULL "interp"
337     *      allows this procedure to be used as a test whether the conversion
338     *      could be done (and in fact was done).
339     *
340     * Side effects:
341     *      Any internal representation for the old type is freed.
342     *
343     *----------------------------------------------------------------------
344     */
345    
346    int
347    Tcl_ConvertToType(interp, objPtr, typePtr)
348        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
349        Tcl_Obj *objPtr;            /* The object to convert. */
350        Tcl_ObjType *typePtr;       /* The target type. */
351    {
352        if (objPtr->typePtr == typePtr) {
353            return TCL_OK;
354        }
355    
356        /*
357         * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
358         * form as appropriate for the target type. This frees the old internal
359         * representation.
360         */
361    
362        return typePtr->setFromAnyProc(interp, objPtr);
363    }
364    
365    /*
366     *----------------------------------------------------------------------
367     *
368     * Tcl_NewObj --
369     *
370     *      This procedure is normally called when not debugging: i.e., when
371     *      TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
372     *      the empty string. These objects have a NULL object type and NULL
373     *      string representation byte pointer. Type managers call this routine
374     *      to allocate new objects that they further initialize.
375     *
376     *      When TCL_MEM_DEBUG is defined, this procedure just returns the
377     *      result of calling the debugging version Tcl_DbNewObj.
378     *
379     * Results:
380     *      The result is a newly allocated object that represents the empty
381     *      string. The new object's typePtr is set NULL and its ref count
382     *      is set to 0.
383     *
384     * Side effects:
385     *      If compiling with TCL_COMPILE_STATS, this procedure increments
386     *      the global count of allocated objects (tclObjsAlloced).
387     *
388     *----------------------------------------------------------------------
389     */
390    
391    #ifdef TCL_MEM_DEBUG
392    #undef Tcl_NewObj
393    
394    Tcl_Obj *
395    Tcl_NewObj()
396    {
397        return Tcl_DbNewObj("unknown", 0);
398    }
399    
400    #else /* if not TCL_MEM_DEBUG */
401    
402    Tcl_Obj *
403    Tcl_NewObj()
404    {
405        register Tcl_Obj *objPtr;
406    
407        /*
408         * Allocate the object using the list of free Tcl_Obj structs
409         * we maintain.
410         */
411    
412        Tcl_MutexLock(&tclObjMutex);
413        if (tclFreeObjList == NULL) {
414            TclAllocateFreeObjects();
415        }
416        objPtr = tclFreeObjList;
417        tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
418        
419        objPtr->refCount = 0;
420        objPtr->bytes    = tclEmptyStringRep;
421        objPtr->length   = 0;
422        objPtr->typePtr  = NULL;
423    #ifdef TCL_COMPILE_STATS
424        tclObjsAlloced++;
425    #endif /* TCL_COMPILE_STATS */
426        Tcl_MutexUnlock(&tclObjMutex);
427        return objPtr;
428    }
429    #endif /* TCL_MEM_DEBUG */
430    
431    /*
432     *----------------------------------------------------------------------
433     *
434     * Tcl_DbNewObj --
435     *
436     *      This procedure is normally called when debugging: i.e., when
437     *      TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
438     *      empty string. It is the same as the Tcl_NewObj procedure above
439     *      except that it calls Tcl_DbCkalloc directly with the file name and
440     *      line number from its caller. This simplifies debugging since then
441     *      the checkmem command will report the correct file name and line
442     *      number when reporting objects that haven't been freed.
443     *
444     *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
445     *      result of calling Tcl_NewObj.
446     *
447     * Results:
448     *      The result is a newly allocated that represents the empty string.
449     *      The new object's typePtr is set NULL and its ref count is set to 0.
450     *
451     * Side effects:
452     *      If compiling with TCL_COMPILE_STATS, this procedure increments
453     *      the global count of allocated objects (tclObjsAlloced).
454     *
455     *----------------------------------------------------------------------
456     */
457    
458    #ifdef TCL_MEM_DEBUG
459    
460    Tcl_Obj *
461    Tcl_DbNewObj(file, line)
462        register char *file;        /* The name of the source file calling this
463                                     * procedure; used for debugging. */
464        register int line;          /* Line number in the source file; used
465                                     * for debugging. */
466    {
467        register Tcl_Obj *objPtr;
468    
469        /*
470         * If debugging Tcl's memory usage, allocate the object using ckalloc.
471         * Otherwise, allocate it using the list of free Tcl_Obj structs we
472         * maintain.
473         */
474    
475        objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
476        objPtr->refCount = 0;
477        objPtr->bytes    = tclEmptyStringRep;
478        objPtr->length   = 0;
479        objPtr->typePtr  = NULL;
480    #ifdef TCL_COMPILE_STATS
481        Tcl_MutexLock(&tclObjMutex);
482        tclObjsAlloced++;
483        Tcl_MutexUnlock(&tclObjMutex);
484    #endif /* TCL_COMPILE_STATS */
485        return objPtr;
486    }
487    
488    #else /* if not TCL_MEM_DEBUG */
489    
490    Tcl_Obj *
491    Tcl_DbNewObj(file, line)
492        char *file;                 /* The name of the source file calling this
493                                     * procedure; used for debugging. */
494        int line;                   /* Line number in the source file; used
495                                     * for debugging. */
496    {
497        return Tcl_NewObj();
498    }
499    #endif /* TCL_MEM_DEBUG */
500    
501    /*
502     *----------------------------------------------------------------------
503     *
504     * TclAllocateFreeObjects --
505     *
506     *      Procedure to allocate a number of free Tcl_Objs. This is done using
507     *      a single ckalloc to reduce the overhead for Tcl_Obj allocation.
508     *
509     *      Assumes mutex is held.
510     *
511     * Results:
512     *      None.
513     *
514     * Side effects:
515     *      tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
516     *      first of a number of free Tcl_Obj's linked together by their
517     *      internalRep.otherValuePtrs.
518     *
519     *----------------------------------------------------------------------
520     */
521    
522    #define OBJS_TO_ALLOC_EACH_TIME 100
523    
524    void
525    TclAllocateFreeObjects()
526    {
527        Tcl_Obj tmp[2];
528        size_t objSizePlusPadding = /* NB: this assumes byte addressing. */
529            ((int)(&(tmp[1])) - (int)(&(tmp[0])));
530        size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
531        char *basePtr;
532        register Tcl_Obj *prevPtr, *objPtr;
533        register int i;
534    
535        basePtr = (char *) ckalloc(bytesToAlloc);
536        memset(basePtr, 0, bytesToAlloc);
537    
538        prevPtr = NULL;
539        objPtr = (Tcl_Obj *) basePtr;
540        for (i = 0;  i < OBJS_TO_ALLOC_EACH_TIME;  i++) {
541            objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
542            prevPtr = objPtr;
543            objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
544        }
545        tclFreeObjList = prevPtr;
546    }
547    #undef OBJS_TO_ALLOC_EACH_TIME
548    
549    /*
550     *----------------------------------------------------------------------
551     *
552     * TclFreeObj --
553     *
554     *      This procedure frees the memory associated with the argument
555     *      object. It is called by the tcl.h macro Tcl_DecrRefCount when an
556     *      object's ref count is zero. It is only "public" since it must
557     *      be callable by that macro wherever the macro is used. It should not
558     *      be directly called by clients.
559     *
560     * Results:
561     *      None.
562     *
563     * Side effects:
564     *      Deallocates the storage for the object's Tcl_Obj structure
565     *      after deallocating the string representation and calling the
566     *      type-specific Tcl_FreeInternalRepProc to deallocate the object's
567     *      internal representation. If compiling with TCL_COMPILE_STATS,
568     *      this procedure increments the global count of freed objects
569     *      (tclObjsFreed).
570     *
571     *----------------------------------------------------------------------
572     */
573    
574    void
575    TclFreeObj(objPtr)
576        register Tcl_Obj *objPtr;   /* The object to be freed. */
577    {
578        register Tcl_ObjType *typePtr = objPtr->typePtr;
579        
580    #ifdef TCL_MEM_DEBUG
581        if ((objPtr)->refCount < -1) {
582            panic("Reference count for %lx was negative", objPtr);
583        }
584    #endif /* TCL_MEM_DEBUG */
585    
586        if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
587            typePtr->freeIntRepProc(objPtr);
588        }
589        Tcl_InvalidateStringRep(objPtr);
590    
591        /*
592         * If debugging Tcl's memory usage, deallocate the object using ckfree.
593         * Otherwise, deallocate it by adding it onto the list of free
594         * Tcl_Obj structs we maintain.
595         */
596    
597        Tcl_MutexLock(&tclObjMutex);
598    #ifdef TCL_MEM_DEBUG
599        ckfree((char *) objPtr);
600    #else
601        objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
602        tclFreeObjList = objPtr;
603    #endif /* TCL_MEM_DEBUG */
604    
605    #ifdef TCL_COMPILE_STATS
606        tclObjsFreed++;
607    #endif /* TCL_COMPILE_STATS */
608        Tcl_MutexUnlock(&tclObjMutex);
609    }
610    
611    /*
612     *----------------------------------------------------------------------
613     *
614     * Tcl_DuplicateObj --
615     *
616     *      Create and return a new object that is a duplicate of the argument
617     *      object.
618     *
619     * Results:
620     *      The return value is a pointer to a newly created Tcl_Obj. This
621     *      object has reference count 0 and the same type, if any, as the
622     *      source object objPtr. Also:
623     *        1) If the source object has a valid string rep, we copy it;
624     *           otherwise, the duplicate's string rep is set NULL to mark
625     *           it invalid.
626     *        2) If the source object has an internal representation (i.e. its
627     *           typePtr is non-NULL), the new object's internal rep is set to
628     *           a copy; otherwise the new internal rep is marked invalid.
629     *
630     * Side effects:
631     *      What constitutes "copying" the internal representation depends on
632     *      the type. For example, if the argument object is a list,
633     *      the element objects it points to will not actually be copied but
634     *      will be shared with the duplicate list. That is, the ref counts of
635     *      the element objects will be incremented.
636     *
637     *----------------------------------------------------------------------
638     */
639    
640    Tcl_Obj *
641    Tcl_DuplicateObj(objPtr)
642        register Tcl_Obj *objPtr;           /* The object to duplicate. */
643    {
644        register Tcl_ObjType *typePtr = objPtr->typePtr;
645        register Tcl_Obj *dupPtr;
646    
647        TclNewObj(dupPtr);
648    
649        if (objPtr->bytes == NULL) {
650            dupPtr->bytes = NULL;
651        } else if (objPtr->bytes != tclEmptyStringRep) {
652            int len = objPtr->length;
653            
654            dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
655            if (len > 0) {
656                memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
657                       (unsigned) len);
658            }
659            dupPtr->bytes[len] = '\0';
660            dupPtr->length = len;
661        }
662        
663        if (typePtr != NULL) {
664            if (typePtr->dupIntRepProc == NULL) {
665                dupPtr->internalRep = objPtr->internalRep;
666                dupPtr->typePtr = typePtr;
667            } else {
668                (*typePtr->dupIntRepProc)(objPtr, dupPtr);
669            }
670        }
671        return dupPtr;
672    }
673    
674    /*
675     *----------------------------------------------------------------------
676     *
677     * Tcl_GetString --
678     *
679     *      Returns the string representation byte array pointer for an object.
680     *
681     * Results:
682     *      Returns a pointer to the string representation of objPtr. The byte
683     *      array referenced by the returned pointer must not be modified by the
684     *      caller. Furthermore, the caller must copy the bytes if they need to
685     *      retain them since the object's string rep can change as a result of
686     *      other operations.
687     *
688     * Side effects:
689     *      May call the object's updateStringProc to update the string
690     *      representation from the internal representation.
691     *
692     *----------------------------------------------------------------------
693     */
694    
695    char *
696    Tcl_GetString(objPtr)
697        register Tcl_Obj *objPtr;   /* Object whose string rep byte pointer
698                                     * should be returned. */
699    {
700        if (objPtr->bytes != NULL) {
701            return objPtr->bytes;
702        }
703    
704        if (objPtr->typePtr->updateStringProc == NULL) {
705            panic("UpdateStringProc should not be invoked for type %s",
706                    objPtr->typePtr->name);
707        }
708        (*objPtr->typePtr->updateStringProc)(objPtr);
709        return objPtr->bytes;
710    }
711    
712    /*
713     *----------------------------------------------------------------------
714     *
715     * Tcl_GetStringFromObj --
716     *
717     *      Returns the string representation's byte array pointer and length
718     *      for an object.
719     *
720     * Results:
721     *      Returns a pointer to the string representation of objPtr. If
722     *      lengthPtr isn't NULL, the length of the string representation is
723     *      stored at *lengthPtr. The byte array referenced by the returned
724     *      pointer must not be modified by the caller. Furthermore, the
725     *      caller must copy the bytes if they need to retain them since the
726     *      object's string rep can change as a result of other operations.
727     *
728     * Side effects:
729     *      May call the object's updateStringProc to update the string
730     *      representation from the internal representation.
731     *
732     *----------------------------------------------------------------------
733     */
734    
735    char *
736    Tcl_GetStringFromObj(objPtr, lengthPtr)
737        register Tcl_Obj *objPtr;   /* Object whose string rep byte pointer
738                                     * should be returned. */
739        register int *lengthPtr;    /* If non-NULL, the location where the
740                                     * string rep's byte array length should be
741                                     * stored. If NULL, no length is stored. */
742    {
743        if (objPtr->bytes != NULL) {
744            if (lengthPtr != NULL) {
745                *lengthPtr = objPtr->length;
746            }
747            return objPtr->bytes;
748        }
749    
750        if (objPtr->typePtr->updateStringProc == NULL) {
751            panic("UpdateStringProc should not be invoked for type %s",
752                    objPtr->typePtr->name);
753        }
754        (*objPtr->typePtr->updateStringProc)(objPtr);
755        if (lengthPtr != NULL) {
756            *lengthPtr = objPtr->length;
757        }
758        return objPtr->bytes;
759    }
760    
761    /*
762     *----------------------------------------------------------------------
763     *
764     * Tcl_InvalidateStringRep --
765     *
766     *      This procedure is called to invalidate an object's string
767     *      representation.
768     *
769     * Results:
770     *      None.
771     *
772     * Side effects:
773     *      Deallocates the storage for any old string representation, then
774     *      sets the string representation NULL to mark it invalid.
775     *
776     *----------------------------------------------------------------------
777     */
778    
779    void
780    Tcl_InvalidateStringRep(objPtr)
781         register Tcl_Obj *objPtr;  /* Object whose string rep byte pointer
782                                     * should be freed. */
783    {
784        if (objPtr->bytes != NULL) {
785            if (objPtr->bytes != tclEmptyStringRep) {
786                ckfree((char *) objPtr->bytes);
787            }
788            objPtr->bytes = NULL;
789        }
790    }
791    
792    /*
793     *----------------------------------------------------------------------
794     *
795     * Tcl_NewBooleanObj --
796     *
797     *      This procedure is normally called when not debugging: i.e., when
798     *      TCL_MEM_DEBUG is not defined. It creates a new boolean object and
799     *      initializes it from the argument boolean value. A nonzero
800     *      "boolValue" is coerced to 1.
801     *
802     *      When TCL_MEM_DEBUG is defined, this procedure just returns the
803     *      result of calling the debugging version Tcl_DbNewBooleanObj.
804     *
805     * Results:
806     *      The newly created object is returned. This object will have an
807     *      invalid string representation. The returned object has ref count 0.
808     *
809     * Side effects:
810     *      None.
811     *
812     *----------------------------------------------------------------------
813     */
814    
815    #ifdef TCL_MEM_DEBUG
816    #undef Tcl_NewBooleanObj
817    
818    Tcl_Obj *
819    Tcl_NewBooleanObj(boolValue)
820        register int boolValue;     /* Boolean used to initialize new object. */
821    {
822        return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
823    }
824    
825    #else /* if not TCL_MEM_DEBUG */
826    
827    Tcl_Obj *
828    Tcl_NewBooleanObj(boolValue)
829        register int boolValue;     /* Boolean used to initialize new object. */
830    {
831        register Tcl_Obj *objPtr;
832    
833        TclNewObj(objPtr);
834        objPtr->bytes = NULL;
835        
836        objPtr->internalRep.longValue = (boolValue? 1 : 0);
837        objPtr->typePtr = &tclBooleanType;
838        return objPtr;
839    }
840    #endif /* TCL_MEM_DEBUG */
841    
842    /*
843     *----------------------------------------------------------------------
844     *
845     * Tcl_DbNewBooleanObj --
846     *
847     *      This procedure is normally called when debugging: i.e., when
848     *      TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
849     *      same as the Tcl_NewBooleanObj procedure above except that it calls
850     *      Tcl_DbCkalloc directly with the file name and line number from its
851     *      caller. This simplifies debugging since then the checkmem command
852     *      will report the correct file name and line number when reporting
853     *      objects that haven't been freed.
854     *
855     *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
856     *      result of calling Tcl_NewBooleanObj.
857     *
858     * Results:
859     *      The newly created object is returned. This object will have an
860     *      invalid string representation. The returned object has ref count 0.
861     *
862     * Side effects:
863     *      None.
864     *
865     *----------------------------------------------------------------------
866     */
867    
868    #ifdef TCL_MEM_DEBUG
869    
870    Tcl_Obj *
871    Tcl_DbNewBooleanObj(boolValue, file, line)
872        register int boolValue;     /* Boolean used to initialize new object. */
873        char *file;                 /* The name of the source file calling this
874                                     * procedure; used for debugging. */
875        int line;                   /* Line number in the source file; used
876                                     * for debugging. */
877    {
878        register Tcl_Obj *objPtr;
879    
880        TclDbNewObj(objPtr, file, line);
881        objPtr->bytes = NULL;
882        
883        objPtr->internalRep.longValue = (boolValue? 1 : 0);
884        objPtr->typePtr = &tclBooleanType;
885        return objPtr;
886    }
887    
888    #else /* if not TCL_MEM_DEBUG */
889    
890    Tcl_Obj *
891    Tcl_DbNewBooleanObj(boolValue, file, line)
892        register int boolValue;     /* Boolean used to initialize new object. */
893        char *file;                 /* The name of the source file calling this
894                                     * procedure; used for debugging. */
895        int line;                   /* Line number in the source file; used
896                                     * for debugging. */
897    {
898        return Tcl_NewBooleanObj(boolValue);
899    }
900    #endif /* TCL_MEM_DEBUG */
901    
902    /*
903     *----------------------------------------------------------------------
904     *
905     * Tcl_SetBooleanObj --
906     *
907     *      Modify an object to be a boolean object and to have the specified
908     *      boolean value. A nonzero "boolValue" is coerced to 1.
909     *
910     * Results:
911     *      None.
912     *
913     * Side effects:
914     *      The object's old string rep, if any, is freed. Also, any old
915     *      internal rep is freed.
916     *
917     *----------------------------------------------------------------------
918     */
919    
920    void
921    Tcl_SetBooleanObj(objPtr, boolValue)
922        register Tcl_Obj *objPtr;   /* Object whose internal rep to init. */
923        register int boolValue;     /* Boolean used to set object's value. */
924    {
925        register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
926    
927        if (Tcl_IsShared(objPtr)) {
928            panic("Tcl_SetBooleanObj called with shared object");
929        }
930        
931        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
932            oldTypePtr->freeIntRepProc(objPtr);
933        }
934        
935        objPtr->internalRep.longValue = (boolValue? 1 : 0);
936        objPtr->typePtr = &tclBooleanType;
937        Tcl_InvalidateStringRep(objPtr);
938    }
939    
940    /*
941     *----------------------------------------------------------------------
942     *
943     * Tcl_GetBooleanFromObj --
944     *
945     *      Attempt to return a boolean from the Tcl object "objPtr". If the
946     *      object is not already a boolean, an attempt will be made to convert
947     *      it to one.
948     *
949     * Results:
950     *      The return value is a standard Tcl object result. If an error occurs
951     *      during conversion, an error message is left in the interpreter's
952     *      result unless "interp" is NULL.
953     *
954     * Side effects:
955     *      If the object is not already a boolean, the conversion will free
956     *      any old internal representation.
957     *
958     *----------------------------------------------------------------------
959     */
960    
961    int
962    Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
963        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
964        register Tcl_Obj *objPtr;   /* The object from which to get boolean. */
965        register int *boolPtr;      /* Place to store resulting boolean. */
966    {
967        register int result;
968    
969        result = SetBooleanFromAny(interp, objPtr);
970        if (result == TCL_OK) {
971            *boolPtr = (int) objPtr->internalRep.longValue;
972        }
973        return result;
974    }
975    
976    /*
977     *----------------------------------------------------------------------
978     *
979     * SetBooleanFromAny --
980     *
981     *      Attempt to generate a boolean internal form for the Tcl object
982     *      "objPtr".
983     *
984     * Results:
985     *      The return value is a standard Tcl result. If an error occurs during
986     *      conversion, an error message is left in the interpreter's result
987     *      unless "interp" is NULL.
988     *
989     * Side effects:
990     *      If no error occurs, an integer 1 or 0 is stored as "objPtr"s
991     *      internal representation and the type of "objPtr" is set to boolean.
992     *
993     *----------------------------------------------------------------------
994     */
995    
996    static int
997    SetBooleanFromAny(interp, objPtr)
998        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
999        register Tcl_Obj *objPtr;   /* The object to convert. */
1000    {
1001        Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1002        char *string, *end;
1003        register char c;
1004        char lowerCase[10];
1005        int newBool, length;
1006        register int i;
1007        double dbl;
1008    
1009        /*
1010         * Get the string representation. Make it up-to-date if necessary.
1011         */
1012    
1013        string = Tcl_GetStringFromObj(objPtr, &length);
1014    
1015        /*
1016         * Copy the string converting its characters to lower case.
1017         */
1018    
1019        for (i = 0;  (i < 9) && (i < length);  i++) {
1020            c = string[i];
1021            /*
1022             * Weed out international characters so we can safely operate
1023             * on single bytes.
1024             */
1025    
1026            if (c & 0x80) {
1027                goto badBoolean;
1028            }
1029            if (Tcl_UniCharIsUpper(UCHAR(c))) {
1030                c = (char) Tcl_UniCharToLower(UCHAR(c));
1031            }
1032            lowerCase[i] = c;
1033        }
1034        lowerCase[i] = 0;
1035    
1036        /*
1037         * Parse the string as a boolean. We use an implementation here that
1038         * doesn't report errors in interp if interp is NULL.
1039         */
1040    
1041        c = lowerCase[0];
1042        if ((c == '0') && (lowerCase[1] == '\0')) {
1043            newBool = 0;
1044        } else if ((c == '1') && (lowerCase[1] == '\0')) {
1045            newBool = 1;
1046        } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
1047            newBool = 1;
1048        } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
1049            newBool = 0;
1050        } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
1051            newBool = 1;
1052        } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
1053            newBool = 0;
1054        } else if ((c == 'o') && (length >= 2)) {
1055            if (strncmp(lowerCase, "on", (size_t) length) == 0) {
1056                newBool = 1;
1057            } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
1058                newBool = 0;
1059            } else {
1060                goto badBoolean;
1061            }
1062        } else {
1063            /*
1064             * Still might be a string containing the characters representing an
1065             * int or double that wasn't handled above. This would be a string
1066             * like "27" or "1.0" that is non-zero and not "1". Such a string
1067             * whould result in the boolean value true. We try converting to
1068             * double. If that succeeds and the resulting double is non-zero, we
1069             * have a "true". Note that numbers can't have embedded NULLs.
1070             */
1071    
1072            dbl = strtod(string, &end);
1073            if (end == string) {
1074                goto badBoolean;
1075            }
1076    
1077            /*
1078             * Make sure the string has no garbage after the end of the double.
1079             */
1080            
1081            while ((end < (string+length))
1082                    && isspace(UCHAR(*end))) { /* INTL: ISO only */
1083                end++;
1084            }
1085            if (end != (string+length)) {
1086                goto badBoolean;
1087            }
1088            newBool = (dbl != 0.0);
1089        }
1090    
1091        /*
1092         * Free the old internalRep before setting the new one. We do this as
1093         * late as possible to allow the conversion code, in particular
1094         * Tcl_GetStringFromObj, to use that old internalRep.
1095         */
1096    
1097        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1098            oldTypePtr->freeIntRepProc(objPtr);
1099        }
1100    
1101        objPtr->internalRep.longValue = newBool;
1102        objPtr->typePtr = &tclBooleanType;
1103        return TCL_OK;
1104    
1105        badBoolean:
1106        if (interp != NULL) {
1107            /*
1108             * Must copy string before resetting the result in case a caller
1109             * is trying to convert the interpreter's result to a boolean.
1110             */
1111            
1112            char buf[100];
1113            sprintf(buf, "expected boolean value but got \"%.50s\"", string);
1114            Tcl_ResetResult(interp);
1115            Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1116        }
1117        return TCL_ERROR;
1118    }
1119    
1120    /*
1121     *----------------------------------------------------------------------
1122     *
1123     * UpdateStringOfBoolean --
1124     *
1125     *      Update the string representation for a boolean object.
1126     *      Note: This procedure does not free an existing old string rep
1127     *      so storage will be lost if this has not already been done.
1128     *
1129     * Results:
1130     *      None.
1131     *
1132     * Side effects:
1133     *      The object's string is set to a valid string that results from
1134     *      the boolean-to-string conversion.
1135     *
1136     *----------------------------------------------------------------------
1137     */
1138    
1139    static void
1140    UpdateStringOfBoolean(objPtr)
1141        register Tcl_Obj *objPtr;   /* Int object whose string rep to update. */
1142    {
1143        char *s = ckalloc((unsigned) 2);
1144        
1145        s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
1146        s[1] = '\0';
1147        objPtr->bytes = s;
1148        objPtr->length = 1;
1149    }
1150    
1151    /*
1152     *----------------------------------------------------------------------
1153     *
1154     * Tcl_NewDoubleObj --
1155     *
1156     *      This procedure is normally called when not debugging: i.e., when
1157     *      TCL_MEM_DEBUG is not defined. It creates a new double object and
1158     *      initializes it from the argument double value.
1159     *
1160     *      When TCL_MEM_DEBUG is defined, this procedure just returns the
1161     *      result of calling the debugging version Tcl_DbNewDoubleObj.
1162     *
1163     * Results:
1164     *      The newly created object is returned. This object will have an
1165     *      invalid string representation. The returned object has ref count 0.
1166     *
1167     * Side effects:
1168     *      None.
1169     *
1170     *----------------------------------------------------------------------
1171     */
1172    
1173    #ifdef TCL_MEM_DEBUG
1174    #undef Tcl_NewDoubleObj
1175    
1176    Tcl_Obj *
1177    Tcl_NewDoubleObj(dblValue)
1178        register double dblValue;   /* Double used to initialize the object. */
1179    {
1180        return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
1181    }
1182    
1183    #else /* if not TCL_MEM_DEBUG */
1184    
1185    Tcl_Obj *
1186    Tcl_NewDoubleObj(dblValue)
1187        register double dblValue;   /* Double used to initialize the object. */
1188    {
1189        register Tcl_Obj *objPtr;
1190    
1191        TclNewObj(objPtr);
1192        objPtr->bytes = NULL;
1193        
1194        objPtr->internalRep.doubleValue = dblValue;
1195        objPtr->typePtr = &tclDoubleType;
1196        return objPtr;
1197    }
1198    #endif /* if TCL_MEM_DEBUG */
1199    
1200    /*
1201     *----------------------------------------------------------------------
1202     *
1203     * Tcl_DbNewDoubleObj --
1204     *
1205     *      This procedure is normally called when debugging: i.e., when
1206     *      TCL_MEM_DEBUG is defined. It creates new double objects. It is the
1207     *      same as the Tcl_NewDoubleObj procedure above except that it calls
1208     *      Tcl_DbCkalloc directly with the file name and line number from its
1209     *      caller. This simplifies debugging since then the checkmem command
1210     *      will report the correct file name and line number when reporting
1211     *      objects that haven't been freed.
1212     *
1213     *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
1214     *      result of calling Tcl_NewDoubleObj.
1215     *
1216     * Results:
1217     *      The newly created object is returned. This object will have an
1218     *      invalid string representation. The returned object has ref count 0.
1219     *
1220     * Side effects:
1221     *      None.
1222     *
1223     *----------------------------------------------------------------------
1224     */
1225    
1226    #ifdef TCL_MEM_DEBUG
1227    
1228    Tcl_Obj *
1229    Tcl_DbNewDoubleObj(dblValue, file, line)
1230        register double dblValue;   /* Double used to initialize the object. */
1231        char *file;                 /* The name of the source file calling this
1232                                     * procedure; used for debugging. */
1233        int line;                   /* Line number in the source file; used
1234                                     * for debugging. */
1235    {
1236        register Tcl_Obj *objPtr;
1237    
1238        TclDbNewObj(objPtr, file, line);
1239        objPtr->bytes = NULL;
1240        
1241        objPtr->internalRep.doubleValue = dblValue;
1242        objPtr->typePtr = &tclDoubleType;
1243        return objPtr;
1244    }
1245    
1246    #else /* if not TCL_MEM_DEBUG */
1247    
1248    Tcl_Obj *
1249    Tcl_DbNewDoubleObj(dblValue, file, line)
1250        register double dblValue;   /* Double used to initialize the object. */
1251        char *file;                 /* The name of the source file calling this
1252                                     * procedure; used for debugging. */
1253        int line;                   /* Line number in the source file; used
1254                                     * for debugging. */
1255    {
1256        return Tcl_NewDoubleObj(dblValue);
1257    }
1258    #endif /* TCL_MEM_DEBUG */
1259    
1260    /*
1261     *----------------------------------------------------------------------
1262     *
1263     * Tcl_SetDoubleObj --
1264     *
1265     *      Modify an object to be a double object and to have the specified
1266     *      double value.
1267     *
1268     * Results:
1269     *      None.
1270     *
1271     * Side effects:
1272     *      The object's old string rep, if any, is freed. Also, any old
1273     *      internal rep is freed.
1274     *
1275     *----------------------------------------------------------------------
1276     */
1277    
1278    void
1279    Tcl_SetDoubleObj(objPtr, dblValue)
1280        register Tcl_Obj *objPtr;   /* Object whose internal rep to init. */
1281        register double dblValue;   /* Double used to set the object's value. */
1282    {
1283        register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1284    
1285        if (Tcl_IsShared(objPtr)) {
1286            panic("Tcl_SetDoubleObj called with shared object");
1287        }
1288    
1289        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1290            oldTypePtr->freeIntRepProc(objPtr);
1291        }
1292        
1293        objPtr->internalRep.doubleValue = dblValue;
1294        objPtr->typePtr = &tclDoubleType;
1295        Tcl_InvalidateStringRep(objPtr);
1296    }
1297    
1298    /*
1299     *----------------------------------------------------------------------
1300     *
1301     * Tcl_GetDoubleFromObj --
1302     *
1303     *      Attempt to return a double from the Tcl object "objPtr". If the
1304     *      object is not already a double, an attempt will be made to convert
1305     *      it to one.
1306     *
1307     * Results:
1308     *      The return value is a standard Tcl object result. If an error occurs
1309     *      during conversion, an error message is left in the interpreter's
1310     *      result unless "interp" is NULL.
1311     *
1312     * Side effects:
1313     *      If the object is not already a double, the conversion will free
1314     *      any old internal representation.
1315     *
1316     *----------------------------------------------------------------------
1317     */
1318    
1319    int
1320    Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
1321        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
1322        register Tcl_Obj *objPtr;   /* The object from which to get a double. */
1323        register double *dblPtr;    /* Place to store resulting double. */
1324    {
1325        register int result;
1326        
1327        if (objPtr->typePtr == &tclDoubleType) {
1328            *dblPtr = objPtr->internalRep.doubleValue;
1329            return TCL_OK;
1330        }
1331    
1332        result = SetDoubleFromAny(interp, objPtr);
1333        if (result == TCL_OK) {
1334            *dblPtr = objPtr->internalRep.doubleValue;
1335        }
1336        return result;
1337    }
1338    
1339    /*
1340     *----------------------------------------------------------------------
1341     *
1342     * SetDoubleFromAny --
1343     *
1344     *      Attempt to generate an double-precision floating point internal form
1345     *      for the Tcl object "objPtr".
1346     *
1347     * Results:
1348     *      The return value is a standard Tcl object result. If an error occurs
1349     *      during conversion, an error message is left in the interpreter's
1350     *      result unless "interp" is NULL.
1351     *
1352     * Side effects:
1353     *      If no error occurs, a double is stored as "objPtr"s internal
1354     *      representation.
1355     *
1356     *----------------------------------------------------------------------
1357     */
1358    
1359    static int
1360    SetDoubleFromAny(interp, objPtr)
1361        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
1362        register Tcl_Obj *objPtr;   /* The object to convert. */
1363    {
1364        Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1365        char *string, *end;
1366        double newDouble;
1367        int length;
1368    
1369        /*
1370         * Get the string representation. Make it up-to-date if necessary.
1371         */
1372    
1373        string = Tcl_GetStringFromObj(objPtr, &length);
1374    
1375        /*
1376         * Now parse "objPtr"s string as an double. Numbers can't have embedded
1377         * NULLs. We use an implementation here that doesn't report errors in
1378         * interp if interp is NULL.
1379         */
1380    
1381        errno = 0;
1382        newDouble = strtod(string, &end);
1383        if (end == string) {
1384            badDouble:
1385            if (interp != NULL) {
1386                /*
1387                 * Must copy string before resetting the result in case a caller
1388                 * is trying to convert the interpreter's result to an int.
1389                 */
1390                
1391                char buf[100];
1392                sprintf(buf, "expected floating-point number but got \"%.50s\"",
1393                        string);
1394                Tcl_ResetResult(interp);
1395                Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1396            }
1397            return TCL_ERROR;
1398        }
1399        if (errno != 0) {
1400            if (interp != NULL) {
1401                TclExprFloatError(interp, newDouble);
1402            }
1403            return TCL_ERROR;
1404        }
1405    
1406        /*
1407         * Make sure that the string has no garbage after the end of the double.
1408         */
1409        
1410        while ((end < (string+length))
1411                && isspace(UCHAR(*end))) { /* INTL: ISO space. */
1412            end++;
1413        }
1414        if (end != (string+length)) {
1415            goto badDouble;
1416        }
1417        
1418        /*
1419         * The conversion to double succeeded. Free the old internalRep before
1420         * setting the new one. We do this as late as possible to allow the
1421         * conversion code, in particular Tcl_GetStringFromObj, to use that old
1422         * internalRep.
1423         */
1424        
1425        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1426            oldTypePtr->freeIntRepProc(objPtr);
1427        }
1428    
1429        objPtr->internalRep.doubleValue = newDouble;
1430        objPtr->typePtr = &tclDoubleType;
1431        return TCL_OK;
1432    }
1433    
1434    /*
1435     *----------------------------------------------------------------------
1436     *
1437     * UpdateStringOfDouble --
1438     *
1439     *      Update the string representation for a double-precision floating
1440     *      point object. This must obey the current tcl_precision value for
1441     *      double-to-string conversions. Note: This procedure does not free an
1442     *      existing old string rep so storage will be lost if this has not
1443     *      already been done.
1444     *
1445     * Results:
1446     *      None.
1447     *
1448     * Side effects:
1449     *      The object's string is set to a valid string that results from
1450     *      the double-to-string conversion.
1451     *
1452     *----------------------------------------------------------------------
1453     */
1454    
1455    static void
1456    UpdateStringOfDouble(objPtr)
1457        register Tcl_Obj *objPtr;   /* Double obj with string rep to update. */
1458    {
1459        char buffer[TCL_DOUBLE_SPACE];
1460        register int len;
1461        
1462        Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
1463                buffer);
1464        len = strlen(buffer);
1465        
1466        objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
1467        strcpy(objPtr->bytes, buffer);
1468        objPtr->length = len;
1469    }
1470    
1471    /*
1472     *----------------------------------------------------------------------
1473     *
1474     * Tcl_NewIntObj --
1475     *
1476     *      If a client is compiled with TCL_MEM_DEBUG defined, calls to
1477     *      Tcl_NewIntObj to create a new integer object end up calling the
1478     *      debugging procedure Tcl_DbNewLongObj instead.
1479     *
1480     *      Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
1481     *      calls to Tcl_NewIntObj result in a call to one of the two
1482     *      Tcl_NewIntObj implementations below. We provide two implementations
1483     *      so that the Tcl core can be compiled to do memory debugging of the
1484     *      core even if a client does not request it for itself.
1485     *
1486     *      Integer and long integer objects share the same "integer" type
1487     *      implementation. We store all integers as longs and Tcl_GetIntFromObj
1488     *      checks whether the current value of the long can be represented by
1489     *      an int.
1490     *
1491     * Results:
1492     *      The newly created object is returned. This object will have an
1493     *      invalid string representation. The returned object has ref count 0.
1494     *
1495     * Side effects:
1496     *      None.
1497     *
1498     *----------------------------------------------------------------------
1499     */
1500    
1501    #ifdef TCL_MEM_DEBUG
1502    #undef Tcl_NewIntObj
1503    
1504    Tcl_Obj *
1505    Tcl_NewIntObj(intValue)
1506        register int intValue;      /* Int used to initialize the new object. */
1507    {
1508        return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
1509    }
1510    
1511    #else /* if not TCL_MEM_DEBUG */
1512    
1513    Tcl_Obj *
1514    Tcl_NewIntObj(intValue)
1515        register int intValue;      /* Int used to initialize the new object. */
1516    {
1517        register Tcl_Obj *objPtr;
1518    
1519        TclNewObj(objPtr);
1520        objPtr->bytes = NULL;
1521        
1522        objPtr->internalRep.longValue = (long)intValue;
1523        objPtr->typePtr = &tclIntType;
1524        return objPtr;
1525    }
1526    #endif /* if TCL_MEM_DEBUG */
1527    
1528    /*
1529     *----------------------------------------------------------------------
1530     *
1531     * Tcl_SetIntObj --
1532     *
1533     *      Modify an object to be an integer and to have the specified integer
1534     *      value.
1535     *
1536     * Results:
1537     *      None.
1538     *
1539     * Side effects:
1540     *      The object's old string rep, if any, is freed. Also, any old
1541     *      internal rep is freed.
1542     *
1543     *----------------------------------------------------------------------
1544     */
1545    
1546    void
1547    Tcl_SetIntObj(objPtr, intValue)
1548        register Tcl_Obj *objPtr;   /* Object whose internal rep to init. */
1549        register int intValue;      /* Integer used to set object's value. */
1550    {
1551        register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1552    
1553        if (Tcl_IsShared(objPtr)) {
1554            panic("Tcl_SetIntObj called with shared object");
1555        }
1556        
1557        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1558            oldTypePtr->freeIntRepProc(objPtr);
1559        }
1560        
1561        objPtr->internalRep.longValue = (long) intValue;
1562        objPtr->typePtr = &tclIntType;
1563        Tcl_InvalidateStringRep(objPtr);
1564    }
1565    
1566    
1567    
1568    /*
1569     *----------------------------------------------------------------------
1570     * Tcl_ParseStringToInts --
1571     *----------------------------------------------------------------------
1572     * DESCRIPTION
1573     *         Parses a string to both a machine signed integer and a machine  
1574     *         signed long (and, depending on the platform, these may be the same
1575     *    size).  All errors, including overflow, are detected.  The three
1576     *         formats accepted are decimal, octal, and hexadecimal.        
1577     *
1578     *    This function forms the canonical arbiter of what is and is not
1579     *    an integer.  This function can be used to parse only, without
1580     *    returning any numerical results.
1581     *
1582     *    All formats (decimal, octal, hexadecimal) allow whitespace both
1583     *    before and after the digits of the number.
1584     *
1585     *    All formats (decimal, octal, hexadecimal) allow an arbitrary number
1586     *    of unary sign operators before the number (+ and -).  The number
1587     *    will be negated if the number of "-" operators is odd, and not
1588     *    negated if the number is even.  The operators are not required to
1589     *    be contiguous, and may be separated by whitespace.  The operators
1590     *    may be separated from the digits by whitespace (this is to be con-
1591     *    sistent with current behavior).
1592     *
1593     *    A decimal number consists of the following components.
1594     *       a)Optional leading whitespace.
1595     *       b)An arbitrary number of leading "-" and "+" unary operators,
1596     *         which may be separated by whitespace, and may be separated
1597     *         from the digits of the number by whitespace.
1598     *       c)The digits of the number, which may not begin with "0", and
1599     *         must be contiguous.
1600     *       d)Optional trailing whitespace.
1601     *
1602     *    A decimal number is illegal if it is effectively positive but
1603     *    is larger than the maximum positive integer of the size being
1604     *    considered.  By "effectively" positive, I mean having an even
1605     *    number of unary "-" operators (including zero of them).
1606     *
1607     *    A decimal number is also illegal if it is effectively negative
1608     *    but less than the maximum negative integer of the size being
1609     *    considered.
1610     *
1611     *    An octal number is just like a decimal number, except that its
1612     *    first digit is zero, and no digit may exceed "7".  An octal number
1613     *    is illegal only if the configuration of 1-bits specified before
1614     *    negation exceeds the ability of the machine integer being
1615     *    considered to hold them--an octal number is exempt from sign
1616     *    considerations.
1617     *
1618     *    A hexadecimal number is just like an octal number, except that
1619     *    the first two digits must be "0x" or "0X", and the digits in
1620     *    the number may be 0-9, A-F, and a-f.  Again, a hexadecimal number
1621     *    is exempt from sign considerations, and will be declared illegal
1622     *    only if the bit pattern before possible negation will not fit in
1623     *    the machine integer being considered.
1624     *
1625     *    The descriptions of legal and illegal above carry over to long
1626     *    integers.  A string may represent a valid long integer but an
1627     *    invalid integer.  In all cases, the criteria for illegality is
1628     *    the same.
1629     *
1630     *    Negation in all cases is carried out in the two's complement
1631     *    fashion (i.e. one's complement plus one).
1632     *
1633     * LEGALITY/ILLEGALITY EXAMPLES
1634     *    Below are listed several examples which illustrate what is legal and
1635     *    what is illegal, and why.  Assume a 32-bit machine integer in
1636     *    standard 2's complement configuration.
1637     *
1638     *    4000000000 (illegal)
1639     *       Illegal because a positive number is specified which is larger
1640     *       than the largest machine positive integer.
1641     *    2147483647 (legal)
1642     *       This maps to a legal positive machine integer.
1643     *    2147483648 (illegal)
1644     *       This number is larger than the largest positive integer.
1645     *    -2147483648 (legal)
1646     *       This number is a legal negative integer.
1647     *    ----2147483648 (illegal)
1648     *       The number is effectively positive, but will not fit into
1649     *       a positive integer.
1650     *    -----2147483648 (legal)
1651     *       The number is effectively negative, and will fit into a negative
1652     *       machine integer.
1653     *    + - +++ - + - + ---- 0000000000000000 (legal)
1654     *       Any number of unary + and - operators may be specified, they
1655     *       are not required to be contiguous, and any number of zero digits
1656     *       are allowed.
1657     *    
1658     *    + - +++ - + - + ---- 0000000000000008 (illegal)
1659     *       The digit "8" cannot appear in an octal number.
1660     *
1661     *    +-+-+---- 0x0000000000000000000000000000000000000000000Ff (legal)
1662     *       The only consideration for a hexadecimal number is that the
1663     *       1's in the bit pattern fit into 32 bits.  They do.
1664     *
1665     *    -0xABCDEF01 (legal)
1666     *       The number, before negation, fits into 32 bits.
1667     *
1668     *    -0x6ABCDEF01 (illegal)
1669     *       The number, before negation, does not fit into 32 bits.
1670     *
1671     *    077777777777 (illegal)
1672     *       The octal number contains 33 significant bits, and cannot be
1673     *       contained by a machine integer.
1674     *    037777777777 (illegal)
1675     *       This octal number contains only 32 significant bits, and
1676     *       can be contained in a machine integer.
1677     *
1678     *
1679     * INPUTS
1680     *    s
1681     *       Pointer to string to accept as input.  This pointer may not
1682     *       be NULL.
1683     *    len
1684     *       The maximum number of characters to use from s.  If this
1685     *       parameter is non-negative, this function will treat s as if
1686     *       s[len] is the \0 terminator.  (By the way, since a valid integer
1687     *       can never be specified with zero characters, zero here will
1688     *       always result in unsuccessful parses.)  If this parameter is
1689     *       negative (commonly "-1"), it indicates to use a zero terminator
1690     *       in s.
1691     *    *err_result
1692     *       This is a bit-packed integer which indicates the result
1693     *       of the parsing.  Bits are set on failure rather than
1694     *       success.  If this integer tests 0, then no errors occured.
1695     *       The pointer to this integer may be NULL, in which case the
1696     *       result is not assigned.
1697     *    
1698     *       Since the ANSI C spec requires that integers be at least
1699     *       16 bits, we have room for 16 flags here.
1700     *
1701     *       The bits defined in this integer are listed below.  All bits
1702     *       not identified are unused and will always be zero.
1703     *          a)0x0001 :  The input string was syntactically bad and could
1704     *                      not be parsed as an integer at all, of any
1705     *                      size (example:  illegal characters).  In other
1706     *                      words, the error was not related to size of the
1707     *                      integer, but rather it was not well-formed.
1708     *          b)0x0002 :  Could not be parsed as a signed integer--too
1709     *                      negative.
1710     *          c)0x0004 :  Could not be parsed as a signed integer--too
1711     *                      positive.
1712     *          d)0x0008 :  Could not be parsed as an unsigned integer--
1713     *                      too negative (which means < 0).
1714     *          e)0x0010 :  Could not be parsed as an unsigned integer--
1715     *                      too positive.
1716     *          f)0x0020 :  Could not be parsed as an integer--too many
1717     *                      bits specified (applies only to octal and hex
1718     *                      numbers).
1719     *          g)0x0040 :  Could not be parsed as a signed long--too negative.
1720     *          h)0x0080 :  Could not be parsed as a signed long--too positive.
1721     *          i)0x0100 :  Could not be parsed as an unsigned long--too negative.
1722     *          j)0x0200 :  Could not be parsed as an unsigned long--too positive.
1723     *          k)0x0400 :  Could not be parsed as an long--too many
1724     *                      bits specified (applies only to octal and hex
1725     *                      numbers).
1726     *
1727     *    *int_result
1728     *       The result of attempted conversion to an integer.  If
1729     *       flag (a) or flag (f) is set, this result is undefined.  
1730     *       If at least one of (b) or (c) are set but neither of
1731     *       (d) or (e) are set, this contains the bit pattern of a
1732     *       valid unsigned integer.
1733     *       of flags (b) through (d) are set but none of flags
1734     *      
1735     *
1736     *----------------------------------------------------------------------
1737     */
1738    
1739    void Tcl_ParseStringToInts(char *s)
1740       {
1741    
1742       }
1743    
1744    
1745    
1746    /*
1747     *----------------------------------------------------------------------
1748     *
1749     * Tcl_GetIntFromObj --
1750     *
1751     *      Attempt to return an int from the Tcl object "objPtr". If the object
1752     *      is not already an int, an attempt will be made to convert it to one.
1753     *
1754     *      Integer and long integer objects share the same "integer" type
1755     *      implementation. We store all integers as longs and Tcl_GetIntFromObj
1756     *      checks whether the current value of the long can be represented by
1757     *      an int.
1758     *
1759     * Results:
1760     *      The return value is a standard Tcl object result. If an error occurs
1761     *      during conversion or if the long integer held by the object
1762     *      can not be represented by an int, an error message is left in
1763     *      the interpreter's result unless "interp" is NULL.
1764     *
1765     * Side effects:
1766     *      If the object is not already an int, the conversion will free
1767     *      any old internal representation.
1768     *
1769     *----------------------------------------------------------------------
1770     */
1771    
1772    int
1773    Tcl_GetIntFromObj(interp, objPtr, intPtr)
1774        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
1775        register Tcl_Obj *objPtr;   /* The object from which to get a int. */
1776        register int *intPtr;       /* Place to store resulting int. */
1777    {
1778        register long l;
1779        int result;
1780        
1781        if (objPtr->typePtr != &tclIntType) {
1782            result = SetIntFromAny(interp, objPtr);
1783            if (result != TCL_OK) {
1784                return result;
1785            }
1786        }
1787        l = objPtr->internalRep.longValue;
1788        if (((long)((int)l)) == l) {
1789            *intPtr = (int)objPtr->internalRep.longValue;
1790            return TCL_OK;
1791        }
1792        if (interp != NULL) {
1793            Tcl_ResetResult(interp);
1794            Tcl_AppendToObj(Tcl_GetObjResult(interp),
1795                    "integer value too large to represent as non-long integer", -1);
1796        }
1797        return TCL_ERROR;
1798    }
1799    
1800    /*
1801     *----------------------------------------------------------------------
1802     *
1803     * SetIntFromAny --
1804     *
1805     *      Attempt to generate an integer internal form for the Tcl object
1806     *      "objPtr".
1807     *
1808     * Results:
1809     *      The return value is a standard object Tcl result. If an error occurs
1810     *      during conversion, an error message is left in the interpreter's
1811     *      result unless "interp" is NULL.
1812     *
1813     * Side effects:
1814     *      If no error occurs, an int is stored as "objPtr"s internal
1815     *      representation.
1816     *
1817     *----------------------------------------------------------------------
1818     */
1819    
1820    static int
1821    SetIntFromAny(interp, objPtr)
1822        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
1823        register Tcl_Obj *objPtr;   /* The object to convert. */
1824    {
1825        Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1826        char *string, *end;
1827        int length;
1828        register char *p;
1829        long newLong;
1830    
1831        /*
1832         * Get the string representation. Make it up-to-date if necessary.
1833         */
1834    
1835        string = Tcl_GetStringFromObj(objPtr, &length);
1836    
1837        /*
1838         * Now parse "objPtr"s string as an int. We use an implementation here
1839         * that doesn't report errors in interp if interp is NULL. Note: use
1840         * strtoul instead of strtol for integer conversions to allow full-size
1841         * unsigned numbers, but don't depend on strtoul to handle sign
1842         * characters; it won't in some implementations.
1843         */
1844    
1845        errno = 0;
1846        for (p = string;  isspace(UCHAR(*p));  p++) { /* INTL: ISO space. */
1847            /* Empty loop body. */
1848        }
1849        if (*p == '-') {
1850            p++;
1851            newLong = -((long)strtoul(p, &end, 0));
1852        } else if (*p == '+') {
1853            p++;
1854            newLong = strtoul(p, &end, 0);
1855        } else {
1856            newLong = strtoul(p, &end, 0);
1857        }
1858        if (end == p) {
1859            badInteger:
1860            if (interp != NULL) {
1861                /*
1862                 * Must copy string before resetting the result in case a caller
1863                 * is trying to convert the interpreter's result to an int.
1864                 */
1865                
1866                char buf[100];
1867                sprintf(buf, "expected integer but got \"%.50s\"", string);
1868                Tcl_ResetResult(interp);
1869                Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1870                TclCheckBadOctal(interp, string);
1871            }
1872            return TCL_ERROR;
1873        }
1874        if (errno == ERANGE) {
1875            if (interp != NULL) {
1876                char *s = "integer value too large to represent";
1877                Tcl_ResetResult(interp);
1878                Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1879                Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
1880            }
1881            return TCL_ERROR;
1882        }
1883    
1884        /*
1885         * Make sure that the string has no garbage after the end of the int.
1886         */
1887        
1888        while ((end < (string+length))
1889                && isspace(UCHAR(*end))) { /* INTL: ISO space. */
1890            end++;
1891        }
1892        if (end != (string+length)) {
1893            goto badInteger;
1894        }
1895    
1896        /*
1897         * The conversion to int succeeded. Free the old internalRep before
1898         * setting the new one. We do this as late as possible to allow the
1899         * conversion code, in particular Tcl_GetStringFromObj, to use that old
1900         * internalRep.
1901         */
1902    
1903        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1904            oldTypePtr->freeIntRepProc(objPtr);
1905        }
1906        
1907        objPtr->internalRep.longValue = newLong;
1908        objPtr->typePtr = &tclIntType;
1909        return TCL_OK;
1910    }
1911    
1912    /*
1913     *----------------------------------------------------------------------
1914     *
1915     * UpdateStringOfInt --
1916     *
1917     *      Update the string representation for an integer object.
1918     *      Note: This procedure does not free an existing old string rep
1919     *      so storage will be lost if this has not already been done.
1920     *
1921     * Results:
1922     *      None.
1923     *
1924     * Side effects:
1925     *      The object's string is set to a valid string that results from
1926     *      the int-to-string conversion.
1927     *
1928     *----------------------------------------------------------------------
1929     */
1930    
1931    static void
1932    UpdateStringOfInt(objPtr)
1933        register Tcl_Obj *objPtr;   /* Int object whose string rep to update. */
1934    {
1935        char buffer[TCL_INTEGER_SPACE];
1936        register int len;
1937        
1938        len = TclFormatInt(buffer, objPtr->internalRep.longValue);
1939        
1940        objPtr->bytes = ckalloc((unsigned) len + 1);
1941        strcpy(objPtr->bytes, buffer);
1942        objPtr->length = len;
1943    }
1944    
1945    /*
1946     *----------------------------------------------------------------------
1947     *
1948     * Tcl_NewLongObj --
1949     *
1950     *      If a client is compiled with TCL_MEM_DEBUG defined, calls to
1951     *      Tcl_NewLongObj to create a new long integer object end up calling
1952     *      the debugging procedure Tcl_DbNewLongObj instead.
1953     *
1954     *      Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
1955     *      calls to Tcl_NewLongObj result in a call to one of the two
1956     *      Tcl_NewLongObj implementations below. We provide two implementations
1957     *      so that the Tcl core can be compiled to do memory debugging of the
1958     *      core even if a client does not request it for itself.
1959     *
1960     *      Integer and long integer objects share the same "integer" type
1961     *      implementation. We store all integers as longs and Tcl_GetIntFromObj
1962     *      checks whether the current value of the long can be represented by
1963     *      an int.
1964     *
1965     * Results:
1966     *      The newly created object is returned. This object will have an
1967     *      invalid string representation. The returned object has ref count 0.
1968     *
1969     * Side effects:
1970     *      None.
1971     *
1972     *----------------------------------------------------------------------
1973     */
1974    
1975    #ifdef TCL_MEM_DEBUG
1976    #undef Tcl_NewLongObj
1977    
1978    Tcl_Obj *
1979    Tcl_NewLongObj(longValue)
1980        register long longValue;    /* Long integer used to initialize the
1981                                     * new object. */
1982    {
1983        return Tcl_DbNewLongObj(longValue, "unknown", 0);
1984    }
1985    
1986    #else /* if not TCL_MEM_DEBUG */
1987    
1988    Tcl_Obj *
1989    Tcl_NewLongObj(longValue)
1990        register long longValue;    /* Long integer used to initialize the
1991                                     * new object. */
1992    {
1993        register Tcl_Obj *objPtr;
1994    
1995        TclNewObj(objPtr);
1996        objPtr->bytes = NULL;
1997        
1998        objPtr->internalRep.longValue = longValue;
1999        objPtr->typePtr = &tclIntType;
2000        return objPtr;
2001    }
2002    #endif /* if TCL_MEM_DEBUG */
2003    
2004    /*
2005     *----------------------------------------------------------------------
2006     *
2007     * Tcl_DbNewLongObj --
2008     *
2009     *      If a client is compiled with TCL_MEM_DEBUG defined, calls to
2010     *      Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
2011     *      long integer objects end up calling the debugging procedure
2012     *      Tcl_DbNewLongObj instead. We provide two implementations of
2013     *      Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
2014     *      memory debugging of the core is independent of whether a client
2015     *      requests debugging for itself.
2016     *
2017     *      When the core is compiled with TCL_MEM_DEBUG defined,
2018     *      Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
2019     *      line number from its caller. This simplifies debugging since then
2020     *      the checkmem command will report the caller's file name and line
2021     *      number when reporting objects that haven't been freed.
2022     *
2023     *      Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
2024     *      this procedure just returns the result of calling Tcl_NewLongObj.
2025     *
2026     * Results:
2027     *      The newly created long integer object is returned. This object
2028     *      will have an invalid string representation. The returned object has
2029     *      ref count 0.
2030     *
2031     * Side effects:
2032     *      Allocates memory.
2033     *
2034     *----------------------------------------------------------------------
2035     */
2036    
2037    #ifdef TCL_MEM_DEBUG
2038    
2039    Tcl_Obj *
2040    Tcl_DbNewLongObj(longValue, file, line)
2041        register long longValue;    /* Long integer used to initialize the
2042                                     * new object. */
2043        char *file;                 /* The name of the source file calling this
2044                                     * procedure; used for debugging. */
2045        int line;                   /* Line number in the source file; used
2046                                     * for debugging. */
2047    {
2048        register Tcl_Obj *objPtr;
2049    
2050        TclDbNewObj(objPtr, file, line);
2051        objPtr->bytes = NULL;
2052        
2053        objPtr->internalRep.longValue = longValue;
2054        objPtr->typePtr = &tclIntType;
2055        return objPtr;
2056    }
2057    
2058    #else /* if not TCL_MEM_DEBUG */
2059    
2060    Tcl_Obj *
2061    Tcl_DbNewLongObj(longValue, file, line)
2062        register long longValue;    /* Long integer used to initialize the
2063                                     * new object. */
2064        char *file;                 /* The name of the source file calling this
2065                                     * procedure; used for debugging. */
2066        int line;                   /* Line number in the source file; used
2067                                     * for debugging. */
2068    {
2069        return Tcl_NewLongObj(longValue);
2070    }
2071    #endif /* TCL_MEM_DEBUG */
2072    
2073    /*
2074     *----------------------------------------------------------------------
2075     *
2076     * Tcl_SetLongObj --
2077     *
2078     *      Modify an object to be an integer object and to have the specified
2079     *      long integer value.
2080     *
2081     * Results:
2082     *      None.
2083     *
2084     * Side effects:
2085     *      The object's old string rep, if any, is freed. Also, any old
2086     *      internal rep is freed.
2087     *
2088     *----------------------------------------------------------------------
2089     */
2090    
2091    void
2092    Tcl_SetLongObj(objPtr, longValue)
2093        register Tcl_Obj *objPtr;   /* Object whose internal rep to init. */
2094        register long longValue;    /* Long integer used to initialize the
2095                                     * object's value. */
2096    {
2097        register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
2098    
2099        if (Tcl_IsShared(objPtr)) {
2100            panic("Tcl_SetLongObj called with shared object");
2101        }
2102    
2103        if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
2104            oldTypePtr->freeIntRepProc(objPtr);
2105        }
2106        
2107        objPtr->internalRep.longValue = longValue;
2108        objPtr->typePtr = &tclIntType;
2109        Tcl_InvalidateStringRep(objPtr);
2110    }
2111    
2112    /*
2113     *----------------------------------------------------------------------
2114     *
2115     * Tcl_GetLongFromObj --
2116     *
2117     *      Attempt to return an long integer from the Tcl object "objPtr". If
2118     *      the object is not already an int object, an attempt will be made to
2119     *      convert it to one.
2120     *
2121     * Results:
2122     *      The return value is a standard Tcl object result. If an error occurs
2123     *      during conversion, an error message is left in the interpreter's
2124     *      result unless "interp" is NULL.
2125     *
2126     * Side effects:
2127     *      If the object is not already an int object, the conversion will free
2128     *      any old internal representation.
2129     *
2130     *----------------------------------------------------------------------
2131     */
2132    
2133    int
2134    Tcl_GetLongFromObj(interp, objPtr, longPtr)
2135        Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
2136        register Tcl_Obj *objPtr;   /* The object from which to get a long. */
2137        register long *longPtr;     /* Place to store resulting long. */
2138    {
2139        register int result;
2140        
2141        if (objPtr->typePtr == &tclIntType) {
2142            *longPtr = objPtr->internalRep.longValue;
2143            return TCL_OK;
2144        }
2145        result = SetIntFromAny(interp, objPtr);
2146        if (result == TCL_OK) {
2147            *longPtr = objPtr->internalRep.longValue;
2148        }
2149        return result;
2150    }
2151    
2152    /*
2153     *----------------------------------------------------------------------
2154     *
2155     * Tcl_DbIncrRefCount --
2156     *
2157     *      This procedure is normally called when debugging: i.e., when
2158     *      TCL_MEM_DEBUG is defined. This checks to see whether or not
2159     *      the memory has been freed before incrementing the ref count.
2160     *
2161     *      When TCL_MEM_DEBUG is not defined, this procedure just increments
2162     *      the reference count of the object.
2163     *
2164     * Results:
2165     *      None.
2166     *
2167     * Side effects:
2168     *      The object's ref count is incremented.
2169     *
2170     *----------------------------------------------------------------------
2171     */
2172    
2173    void
2174    Tcl_DbIncrRefCount(objPtr, file, line)
2175        register Tcl_Obj *objPtr;   /* The object we are registering a
2176                                     * reference to. */
2177        char *file;                 /* The name of the source file calling this
2178                                     * procedure; used for debugging. */
2179        int line;                   /* Line number in the source file; used
2180                                     * for debugging. */
2181    {
2182    #ifdef TCL_MEM_DEBUG
2183        if (objPtr->refCount == 0x61616161) {
2184            fprintf(stderr, "file = %s, line = %d\n", file, line);
2185            fflush(stderr);
2186            panic("Trying to increment refCount of previously disposed object.");
2187        }
2188    #endif
2189        ++(objPtr)->refCount;
2190    }
2191    
2192    /*
2193     *----------------------------------------------------------------------
2194     *
2195     * Tcl_DbDecrRefCount --
2196     *
2197     *      This procedure is normally called when debugging: i.e., when
2198     *      TCL_MEM_DEBUG is defined. This checks to see whether or not
2199     *      the memory has been freed before decrementing the ref count.
2200     *
2201     *      When TCL_MEM_DEBUG is not defined, this procedure just decrements
2202     *      the reference count of the object.
2203     *
2204     * Results:
2205     *      None.
2206     *
2207     * Side effects:
2208     *      The object's ref count is incremented.
2209     *
2210     *----------------------------------------------------------------------
2211     */
2212    
2213    void
2214    Tcl_DbDecrRefCount(objPtr, file, line)
2215        register Tcl_Obj *objPtr;   /* The object we are releasing a reference
2216                                     * to. */
2217        char *file;                 /* The name of the source file calling this
2218                                     * procedure; used for debugging. */
2219        int line;                   /* Line number in the source file; used
2220                                     * for debugging. */
2221    {
2222    #ifdef TCL_MEM_DEBUG
2223        if (objPtr->refCount == 0x61616161) {
2224            fprintf(stderr, "file = %s, line = %d\n", file, line);
2225            fflush(stderr);
2226            panic("Trying to decrement refCount of previously disposed object.");
2227        }
2228    #endif
2229        if (--(objPtr)->refCount <= 0) {
2230            TclFreeObj(objPtr);
2231        }
2232    }
2233    
2234    /*
2235     *----------------------------------------------------------------------
2236     *
2237     * Tcl_DbIsShared --
2238     *
2239     *      This procedure is normally called when debugging: i.e., when
2240     *      TCL_MEM_DEBUG is defined. It tests whether the object has a ref
2241     *      count greater than one.
2242     *
2243     *      When TCL_MEM_DEBUG is not defined, this procedure just tests
2244     *      if the object has a ref count greater than one.
2245     *
2246     * Results:
2247     *      None.
2248     *
2249     * Side effects:
2250     *      None.
2251     *
2252     *----------------------------------------------------------------------
2253     */
2254    
2255    int
2256    Tcl_DbIsShared(objPtr, file, line)
2257        register Tcl_Obj *objPtr;   /* The object to test for being shared. */
2258        char *file;                 /* The name of the source file calling this
2259                                     * procedure; used for debugging. */
2260        int line;                   /* Line number in the source file; used
2261                                     * for debugging. */
2262    {
2263    #ifdef TCL_MEM_DEBUG
2264        if (objPtr->refCount == 0x61616161) {
2265            fprintf(stderr, "file = %s, line = %d\n", file, line);
2266            fflush(stderr);
2267            panic("Trying to check whether previously disposed object is shared.");
2268        }
2269    #endif
2270        return ((objPtr)->refCount > 1);
2271    }
2272    
2273    /* End of tclobj.c */
Legend:
Removed from v.25  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25