From fc6f85c9ef2f8830384506911104a590ac45baa1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 4 Aug 2005 15:55:05 +0000
Subject:         * generic/tclObj.c:     Simplified routines that manage the
 typeTable.

---
 ChangeLog        |  4 ++++
 generic/tclObj.c | 59 ++++++++++++++++++++++----------------------------------
 2 files changed, 27 insertions(+), 36 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ffbadcc..42b83b0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2005-08-04  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclObj.c:	Simplified routines that manage the typeTable.
+
 2005-08-03  Don Porter  <dgp@users.sourceforge.net>
 
         * generic/tclCompExpr.c:        Untangled some dependencies in the
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 8a58b7c..f817a71 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,7 +12,7 @@
  * 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.89 2005/08/03 22:25:11 dgp Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.90 2005/08/04 15:55:12 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -463,27 +463,10 @@ Tcl_RegisterObjType(typePtr)
 				 * 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_SetHashValue(
+	    Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
     Tcl_MutexUnlock(&tableMutex);
 }
 
@@ -520,23 +503,27 @@ Tcl_AppendAllObjTypes(interp, objPtr)
 {
     register Tcl_HashEntry *hPtr;
     Tcl_HashSearch search;
-    Tcl_ObjType *typePtr;
-    int result;
+    int result, objc;
+    Tcl_Obj **objv;
+
+    /* 
+     * Get the test for a valid list out of the way first.
+     */
+
+    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+	return TCL_ERROR;
+    }
 
     /*
-     * This code assumes that types names do not contain embedded NULLs.
+     * Type names are NUL-terminated, not counted strings.
+     * This code relies on that.
      */
 
     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_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
     }
     Tcl_MutexUnlock(&tableMutex);
     return TCL_OK;
@@ -564,17 +551,15 @@ Tcl_GetObjType(typeName)
     CONST char *typeName;	/* Name of Tcl object type to look up. */
 {
     register Tcl_HashEntry *hPtr;
-    Tcl_ObjType *typePtr;
+    Tcl_ObjType *typePtr = NULL;
 
     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;
+    return typePtr;
 }
 
 /*
@@ -819,7 +804,9 @@ TclAllocateFreeObjects()
      * This has been noted by Purify to be a potential leak.  The problem is
      * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
      * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
-     * freeing the memory.  These never do get freed properly.
+     * freeing the memory.  TclFinalizeObjects() does not ckfree() this memory,
+     * but leaves it to Tcl's memory subsystem finalization to release it.
+     * Purify apparently can't figure that out, and fires a false alarm.
      */
 
     basePtr = (char *) ckalloc(bytesToAlloc);
@@ -1144,7 +1131,7 @@ Tcl_InvalidateStringRep(objPtr)
  * 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
+ *	TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
  *	initializes it from the argument boolean value. A nonzero "boolValue"
  *	is coerced to 1.
  *
-- 
cgit v0.12