Changes in external/tcl/tclObj.c [adeddd8:d7d2da3] in git

File:

• external/tcl/tclObj.c (modified) (26 diffs)

external/tcl/tclObj.c

@@ -36 +36 @@
 
 char *tclEmptyStringRep = NULL;
+
+/*
+ * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
+ * freed (by TclFreeObj).
+ */
+
+#ifdef TCL_COMPILE_STATS
+long tclObjsAlloced = 0;
+long tclObjsFreed = 0;
+#endif /* TCL_COMPILE_STATS */
 
 /*
@@ -407 +417 @@
  * Tcl_NewObj --
  *
- *      This procedure 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.
+ *      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:
@@ -417 +431 @@
  *      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 *
@@ -439 +468 @@
     objPtr->length   = 0;
     objPtr->typePtr  = NULL;
+#ifdef TCL_COMPILE_STATS
+    tclObjsAlloced++;
+#endif /* TCL_COMPILE_STATS */
     return objPtr;
 }
+#endif /* TCL_MEM_DEBUG */
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbNewObj --
+ *
+ *      This procedure is normally called when debugging: i.e., when
+ *      TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
+ *      empty string. It is the same as the Tcl_NewObj procedure above
+ *      except that it calls Tcl_DbCkalloc directly with the file name and
+ *      line number from its caller. This simplifies debugging since then
+ *      the checkmem command will report the correct file name and line
+ *      number when reporting objects that haven't been freed.
+ *
+ *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
+ *      result of calling Tcl_NewObj.
+ *
+ * Results:
+ *      The result is a newly allocated that represents the empty string.
+ *      The new object's typePtr is set NULL and its ref count is set to 0.
+ *
+ * Side effects:
+ *      If compiling with TCL_COMPILE_STATS, this procedure increments
+ *      the global count of allocated objects (tclObjsAlloced).
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+
+Tcl_Obj *
+Tcl_DbNewObj(file, line)
+    register char *file;        /* The name of the source file calling this
+                                 * procedure; used for debugging. */
+    register int line;          /* Line number in the source file; used
+                                 * for debugging. */
+{
+    register Tcl_Obj *objPtr;
+
+    /*
+     * If debugging Tcl's memory usage, allocate the object using ckalloc.
+     * Otherwise, allocate it using the list of free Tcl_Objs we maintain.
+     */
+
+    objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
+    objPtr->refCount = 0;
+    objPtr->bytes    = tclEmptyStringRep;
+    objPtr->length   = 0;
+    objPtr->typePtr  = NULL;
+#ifdef TCL_COMPILE_STATS
+    tclObjsAlloced++;
+#endif /* TCL_COMPILE_STATS */
+    return objPtr;
+}
+
+#else /* if not TCL_MEM_DEBUG */
+
+Tcl_Obj *
+Tcl_DbNewObj(file, line)
+    char *file;                 /* The name of the source file calling this
+                                 * procedure; used for debugging. */
+    int line;                   /* Line number in the source file; used
+                                 * for debugging. */
+{
+    return Tcl_NewObj();
+}
+#endif /* TCL_MEM_DEBUG */
 
 
@@ -508 +609 @@
  *      after deallocating the string representation and calling the
  *      type-specific Tcl_FreeInternalRepProc to deallocate the object's
- *      internal representation.
+ *      internal representation. If compiling with TCL_COMPILE_STATS,
+ *      this procedure increments the global count of freed objects
+ *      (tclObjsFreed).
  *
  *----------------------------------------------------------------------
@@ -519 +622 @@
     register Tcl_ObjType *typePtr = objPtr->typePtr;
     
+#ifdef TCL_MEM_DEBUG
+    if ((objPtr)->refCount < -1) {
+        panic("Reference count for %lx was negative", objPtr);
+    }
+#endif /* TCL_MEM_DEBUG */
+
     Tcl_InvalidateStringRep(objPtr);
     if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
@@ -525 +634 @@
 
     /*
-     * Deallocate the object by adding it onto the list of free
+     * If debugging Tcl's memory usage, deallocate the object using ckfree.
+     * Otherwise, deallocate it by adding it onto the list of free
      * Tcl_Objs we maintain.
      */
     
+#ifdef TCL_MEM_DEBUG
+    ckfree((char *) objPtr);
+#else
     objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
     tclFreeObjList = objPtr;
+#endif /* TCL_MEM_DEBUG */
+
+#ifdef TCL_COMPILE_STATS    
+    tclObjsFreed++;
+#endif /* TCL_COMPILE_STATS */    
 }
 
@@ -676 +794 @@
  * Tcl_NewBooleanObj --
  *
- *      This procedure creates a new boolean object and initializes it from
- *      the argument boolean value. A nonzero "boolValue" is coerced to 1.
+ *      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:
@@ -688 +811 @@
  *----------------------------------------------------------------------
  */
+
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewBooleanObj
 
 Tcl_Obj *
@@ -693 +819 @@
     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;
 
@@ -702 +837 @@
     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 */
 
 
@@ -981 +1178 @@
  * Tcl_NewDoubleObj --
  *
- *      This procedure creates a new double object and initializes it from
- *      the argument double value.
+ *      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:
@@ -993 +1194 @@
  *----------------------------------------------------------------------
  */
+
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewDoubleObj
 
 Tcl_Obj *
@@ -998 +1202 @@
     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;
 
@@ -1007 +1220 @@
     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 */
 
 
@@ -1256 +1531 @@
  * Tcl_NewIntObj --
  *
- *      Calls to Tcl_NewIntObj result in a call to one of the two
+ *      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 
@@ -1276 +1556 @@
  */
 
+#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;
 
@@ -1289 +1581 @@
     return objPtr;
 }
+#endif /* if TCL_MEM_DEBUG */
 
 
@@ -1563 +1856 @@
  * Tcl_NewLongObj --
  *
- *      Calls to Tcl_NewLongObj result in a call to one of the two
+ *      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 
@@ -1583 +1881 @@
  */
 
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewLongObj
+
 Tcl_Obj *
 Tcl_NewLongObj(longValue)
@@ -1588 +1889 @@
                                  * 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;
 
@@ -1597 +1908 @@
     return objPtr;
 }
+#endif /* if TCL_MEM_DEBUG */
 
 
@@ -1604 +1916 @@
  * Tcl_DbNewLongObj --
  *
- *      This procedure just returns the result of calling Tcl_NewLongObj.
+ *      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:
@@ -1616 +1943 @@
  *----------------------------------------------------------------------
  */
+
+#ifdef TCL_MEM_DEBUG
 
 Tcl_Obj *
@@ -1626 +1955 @@
                                  * 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 */
 
 
@@ -1709 +2060 @@
     return result;
 }
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIncrRefCount --
+ *
+ *      This procedure is normally called when debugging: i.e., when
+ *      TCL_MEM_DEBUG is defined. This checks to see whether or not
+ *      the memory has been freed before incrementing the ref count.
+ *
+ *      When TCL_MEM_DEBUG is not defined, this procedure just increments
+ *      the reference count of the object.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbIncrRefCount(objPtr, file, line)
+    register Tcl_Obj *objPtr;   /* The object we are adding a reference to. */
+    char *file;                 /* The name of the source file calling this
+                                 * procedure; used for debugging. */
+    int line;                   /* Line number in the source file; used
+                                 * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+    if (objPtr->refCount == 0x61616161) {
+        fprintf(stderr, "file = %s, line = %d\n", file, line);
+        fflush(stderr);
+        panic("Trying to increment refCount of previously disposed object.");
+    }
+#endif
+    ++(objPtr)->refCount;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbDecrRefCount --
+ *
+ *      This procedure is normally called when debugging: i.e., when
+ *      TCL_MEM_DEBUG is defined. This checks to see whether or not
+ *      the memory has been freed before incrementing the ref count.
+ *
+ *      When TCL_MEM_DEBUG is not defined, this procedure just increments
+ *      the reference count of the object.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbDecrRefCount(objPtr, file, line)
+    register Tcl_Obj *objPtr;   /* The object we are adding a reference to. */
+    char *file;                 /* The name of the source file calling this
+                                 * procedure; used for debugging. */
+    int line;                   /* Line number in the source file; used
+                                 * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+    if (objPtr->refCount == 0x61616161) {
+        fprintf(stderr, "file = %s, line = %d\n", file, line);
+        fflush(stderr);
+        panic("Trying to decrement refCount of previously disposed object.");
+    }
+#endif
+    if (--(objPtr)->refCount <= 0) {
+        TclFreeObj(objPtr);
+    }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIsShared --
+ *
+ *      This procedure is normally called when debugging: i.e., when
+ *      TCL_MEM_DEBUG is defined. This checks to see whether or not
+ *      the memory has been freed before incrementing the ref count.
+ *
+ *      When TCL_MEM_DEBUG is not defined, this procedure just decrements
+ *      the reference count of the object and throws it away if the count
+ *      is 0 or less.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DbIsShared(objPtr, file, line)
+    register Tcl_Obj *objPtr;   /* The object we are adding a reference to. */
+    char *file;                 /* The name of the source file calling this
+                                 * procedure; used for debugging. */
+    int line;                   /* Line number in the source file; used
+                                 * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+    if (objPtr->refCount == 0x61616161) {
+        fprintf(stderr, "file = %s, line = %d\n", file, line);
+        fflush(stderr);
+        panic("Trying to check whether previously disposed object is shared.");
+    }
+#endif
+    return ((objPtr)->refCount > 1);
+}