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

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

Parent Directory | Revision Log | View Patch Patch

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

 Legend:



Removed from v.66
 


changed lines


 
Added in v.71
 Legend:



Removed from v.66
 


changed lines


 
Added in v.71
-Removed from v.66
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25