summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
authorericm <ericm>2000-07-19 22:15:28 (GMT)
committerericm <ericm>2000-07-19 22:15:28 (GMT)
commit36c983a93395d03061b02a8ac82105313991650f (patch)
treeca5b2921b3c60013f2c00545146190946b6ef5e8 /generic/tclObj.c
parent8c6040fe85cad9ab5bb5452596ea1107e155f450 (diff)
downloadtcl-36c983a93395d03061b02a8ac82105313991650f.zip
tcl-36c983a93395d03061b02a8ac82105313991650f.tar.gz
tcl-36c983a93395d03061b02a8ac82105313991650f.tar.bz2
* generic/tclStubInit.c:
* generic/tclObj.c: * generic/tclInt.h: * generic/tclHash.c: * generic/tclDecls.h: * generic/tcl.h: * generic/tcl.decls: * doc/Hash.3: Applied patch from Paul Duffin to extend hash tables to allow custom key types, such as Tcl_Obj *'s, and others.
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c290
1 files changed, 260 insertions, 30 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index ab46fe6..56555e1 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.14 2000/05/26 08:51:45 hobbs Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.15 2000/07/19 22:15:30 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;
+}