* generic/tclStubInit.c:

* generic/tclObj.c:
* generic/tclInt.h:
* generic/tclHash.c:
* generic/tclDecls.h:
* generic/tcl.h:
* generic/tcl.decls:
* doc/Hash.3: Reapplied patch from Paul Duffin to extend hash tables
to allow custom key types, such as Tcl_Obj *'s, and others.


FossilOrigin-Name: 9ec468f4054cf859e1310e5612ae81b6645c8fdc

1 files changed, 260 insertions, 30 deletions

diff --git a/generic/tclObj.c b/generic/tclObj.c
index acb9270..3d1575f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1,5 +1,5 @@
 /* 
- * tclObj.c --
+ * Obj.c --
  *
  *	This file contains Tcl object-related procedures that are used by
  * 	many Tcl commands.
@@ -10,7 +10,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.16 2000/07/20 20:33:26 ericm Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.17 2000/07/22 01:53:25 ericm Exp $
  */
 
 #include "tclInt.h"
@@ -36,7 +36,7 @@ Tcl_Obj *tclFreeObjList = NULL;
  */
 
 #ifdef TCL_THREADS
-Tcl_Mutex tclObjMutex;
+Tcl_Mutex ObjMutex;
 #endif
 
 /*
@@ -54,9 +54,9 @@ char *tclEmptyStringRep = &emptyString;
  */
 
 #ifdef TCL_COMPILE_STATS
-long tclObjsAlloced = 0;
-long tclObjsFreed = 0;
-long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+long ObjsAlloced = 0;
+long ObjsFreed = 0;
+long ObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
 #endif /* TCL_COMPILE_STATS */
 
 /*
@@ -74,6 +74,20 @@ static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
 static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
 
 /*
+ * Prototypes for the array hash key methods.
+ */
+
+static Tcl_HashEntry *	AllocObjEntry _ANSI_ARGS_((
+			    Tcl_HashTable *tablePtr, VOID *keyPtr));
+static int		CompareObjKeys _ANSI_ARGS_((
+			    VOID *keyPtr, Tcl_HashEntry *hPtr));
+static void		FreeObjEntry _ANSI_ARGS_((
+			    Tcl_HashEntry *hPtr));
+static unsigned int	HashObjKey _ANSI_ARGS_((
+			    Tcl_HashTable *tablePtr,
+			    VOID *keyPtr));
+
+/*
  * 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
@@ -103,6 +117,18 @@ Tcl_ObjType tclIntType = {
     UpdateStringOfInt,			/* updateStringProc */
     SetIntFromAny			/* setFromAnyProc */
 };
+
+/*
+ * The structure below defines the Tcl obj hash key type.
+ */
+Tcl_HashKeyType tclObjHashKeyType = {
+    TCL_HASH_KEY_TYPE_VERSION,		/* version */
+    0,					/* flags */
+    HashObjKey,				/* hashKeyProc */
+    CompareObjKeys,			/* compareKeysProc */
+    AllocObjEntry,			/* allocEntryProc */
+    FreeObjEntry			/* freeEntryProc */
+};
 
 /*
  *-------------------------------------------------------------------------
@@ -141,16 +167,16 @@ TclInitObjSubsystem()
     Tcl_RegisterObjType(&tclProcBodyType);
 
 #ifdef TCL_COMPILE_STATS
-    Tcl_MutexLock(&tclObjMutex);
-    tclObjsAlloced = 0;
-    tclObjsFreed = 0;
+    Tcl_MutexLock(&ObjMutex);
+    ObjsAlloced = 0;
+    ObjsFreed = 0;
     {
 	int i;
 	for (i = 0;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
-	    tclObjsShared[i] = 0;
+	    ObjsShared[i] = 0;
 	}
     }
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexUnlock(&ObjMutex);
 #endif
 }
 
@@ -181,9 +207,9 @@ TclFinalizeCompExecEnv()
         typeTableInitialized = 0;
     }
     Tcl_MutexUnlock(&tableMutex);
-    Tcl_MutexLock(&tclObjMutex);
+    Tcl_MutexLock(&ObjMutex);
     tclFreeObjList = NULL;
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexUnlock(&ObjMutex);
 
     TclFinalizeCompilation();
     TclFinalizeExecution();
@@ -389,7 +415,7 @@ Tcl_ConvertToType(interp, objPtr, typePtr)
  *
  * Side effects:
  *	If compiling with TCL_COMPILE_STATS, this procedure increments
- *	the global count of allocated objects (tclObjsAlloced).
+ *	the global count of allocated objects (ObjsAlloced).
  *
  *----------------------------------------------------------------------
  */
@@ -415,7 +441,7 @@ Tcl_NewObj()
      * we maintain.
      */
 
-    Tcl_MutexLock(&tclObjMutex);
+    Tcl_MutexLock(&ObjMutex);
     if (tclFreeObjList == NULL) {
 	TclAllocateFreeObjects();
     }
@@ -427,9 +453,9 @@ Tcl_NewObj()
     objPtr->length   = 0;
     objPtr->typePtr  = NULL;
 #ifdef TCL_COMPILE_STATS
-    tclObjsAlloced++;
+    ObjsAlloced++;
 #endif /* TCL_COMPILE_STATS */
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexUnlock(&ObjMutex);
     return objPtr;
 }
 #endif /* TCL_MEM_DEBUG */
@@ -456,7 +482,7 @@ Tcl_NewObj()
  *
  * Side effects:
  *	If compiling with TCL_COMPILE_STATS, this procedure increments
- *	the global count of allocated objects (tclObjsAlloced).
+ *	the global count of allocated objects (ObjsAlloced).
  *
  *----------------------------------------------------------------------
  */
@@ -484,9 +510,9 @@ Tcl_DbNewObj(file, line)
     objPtr->length   = 0;
     objPtr->typePtr  = NULL;
 #ifdef TCL_COMPILE_STATS
-    Tcl_MutexLock(&tclObjMutex);
-    tclObjsAlloced++;
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexLock(&ObjMutex);
+    ObjsAlloced++;
+    Tcl_MutexUnlock(&ObjMutex);
 #endif /* TCL_COMPILE_STATS */
     return objPtr;
 }
@@ -572,7 +598,7 @@ TclAllocateFreeObjects()
  *	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).
+ *	(ObjsFreed).
  *
  *----------------------------------------------------------------------
  */
@@ -600,7 +626,7 @@ TclFreeObj(objPtr)
      * Tcl_Obj structs we maintain.
      */
 
-    Tcl_MutexLock(&tclObjMutex);
+    Tcl_MutexLock(&ObjMutex);
 #ifdef TCL_MEM_DEBUG
     ckfree((char *) objPtr);
 #else
@@ -609,9 +635,9 @@ TclFreeObj(objPtr)
 #endif /* TCL_MEM_DEBUG */
 
 #ifdef TCL_COMPILE_STATS
-    tclObjsFreed++;
+    ObjsFreed++;
 #endif /* TCL_COMPILE_STATS */
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexUnlock(&ObjMutex);
 }
 
 /*
@@ -2086,15 +2112,219 @@ Tcl_DbIsShared(objPtr, file, line)
     }
 #endif
 #ifdef TCL_COMPILE_STATS
-    Tcl_MutexLock(&tclObjMutex);
+    Tcl_MutexLock(&ObjMutex);
     if ((objPtr)->refCount <= 1) {
-	tclObjsShared[1]++;
+	ObjsShared[1]++;
     } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
-	tclObjsShared[(objPtr)->refCount]++;
+	ObjsShared[(objPtr)->refCount]++;
     } else {
-	tclObjsShared[0]++;
+	ObjsShared[0]++;
     }
-    Tcl_MutexUnlock(&tclObjMutex);
+    Tcl_MutexUnlock(&ObjMutex);
 #endif
     return ((objPtr)->refCount > 1);
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitObjHashTable --
+ *
+ *	Given storage for a hash table, set up the fields to prepare
+ *	the hash table for use, the keys are Tcl_Obj *.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
+ *	Tcl_CreateHashEntry.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_InitObjHashTable(tablePtr)
+    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which
+					 * is supplied by the caller. */
+{
+    Tcl_InitHashTableEx (tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AllocObjEntry --
+ *
+ *	Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
+ *
+ * Results:
+ *	The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ *	Increments the reference count on the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+AllocObjEntry(tablePtr, keyPtr)
+    Tcl_HashTable *tablePtr;	/* Hash table. */
+    VOID *keyPtr;		/* Key to store in the hash table entry. */
+{
+    Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+    Tcl_HashEntry *hPtr;
+
+    hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
+    hPtr->key.oneWordValue = (char *) objPtr;
+    Tcl_IncrRefCount (objPtr);
+
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompareObjKeys --
+ *
+ *	Compares two Tcl_Obj * keys.
+ *
+ * Results:
+ *	The return value is 0 if they are different and 1 if they are
+ *	the same.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompareObjKeys(keyPtr, hPtr)
+    VOID *keyPtr;		/* New key to compare. */
+    Tcl_HashEntry *hPtr;		/* Existing key to compare. */
+{
+    Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+    Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
+    register CONST char *p1, *p2;
+    register int l1, l2;
+
+    /*
+     * If the object pointers are the same then they match.
+     */
+    if (objPtr1 == objPtr2) {
+	return 1;
+    }
+
+    /*
+     * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
+     * in a register.
+     */
+    p1 = Tcl_GetString (objPtr1);
+    l1 = objPtr1->length;
+    p2 = Tcl_GetString (objPtr2);
+    l2 = objPtr2->length;
+    
+    /*
+     * Only compare if the string representations are of the same length.
+     */
+    if (l1 == l2) {
+	for (;; p1++, p2++, l1--) {
+	    if (*p1 != *p2) {
+		break;
+	    }
+	    if (l1 == 0) {
+		return 1;
+	    }
+	}
+    }
+
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeObjEntry --
+ *
+ *	Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
+ *
+ * Results:
+ *	The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ *	Decrements the reference count of the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeObjEntry(hPtr)
+    Tcl_HashEntry *hPtr;	/* Hash entry to free. */
+{
+    Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
+
+    Tcl_DecrRefCount (objPtr);
+    ckfree ((char *) hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HashObjKey --
+ *
+ *	Compute a one-word summary of the string representation of the
+ *	Tcl_Obj, which can be used to generate a hash index.
+ *
+ * Results:
+ *	The return value is a one-word summary of the information in
+ *	the string representation of the Tcl_Obj.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+HashObjKey(tablePtr, keyPtr)
+    Tcl_HashTable *tablePtr;	/* Hash table. */
+    VOID *keyPtr;		/* Key from which to compute hash value. */
+{
+    Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+    register CONST char *string;
+    register int length;
+    register unsigned int result;
+    register int c;
+
+    string = Tcl_GetString (objPtr);
+    length = objPtr->length;
+    
+    /*
+     * I tried a zillion different hash functions and asked many other
+     * people for advice.  Many people had their own favorite functions,
+     * all different, but no-one had much idea why they were good ones.
+     * I chose the one below (multiply by 9 and add new character)
+     * because of the following reasons:
+     *
+     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
+     *    and multiplying by 9 is just about as good.
+     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
+     *    character's bits hang around in the low-order bits of the
+     *    hash value for ever, plus they spread fairly rapidly up to
+     *    the high-order bits to fill out the hash value.  This seems
+     *    works well both for decimal and non-decimal strings.
+     */
+
+    result = 0;
+    while (length) {
+	c = *string;
+	string++;
+	length--;
+	if (length == 0) {
+	    break;
+	}
+	result += (result<<3) + c;
+    }
+    return result;
+}