diff options
author | dkf <dkf@noemail.net> | 2003-11-14 23:21:01 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2003-11-14 23:21:01 (GMT) |
commit | 9f78e2a35c3d2d4ca1343853831d5d304d57aa4b (patch) | |
tree | 2b42c119e735fa5a23d1e4521793e39cf223ad8f /generic | |
parent | 00a7377d38b2b19d74436a38c27c41d7763a6798 (diff) | |
download | tcl-9f78e2a35c3d2d4ca1343853831d5d304d57aa4b.zip tcl-9f78e2a35c3d2d4ca1343853831d5d304d57aa4b.tar.gz tcl-9f78e2a35c3d2d4ca1343853831d5d304d57aa4b.tar.bz2 |
TIP#138 implementation plus extra test stuff [Patch 731356]
FossilOrigin-Name: eef4eada83b9f6b1d21308d4c32a856bddd65f69
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.h | 7 | ||||
-rw-r--r-- | generic/tclHash.c | 71 | ||||
-rw-r--r-- | generic/tclTest.c | 83 |
3 files changed, 142 insertions, 19 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index 7a9a7dd..8ac310e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.167 2003/11/14 20:44:44 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.168 2003/11/14 23:21:02 dkf Exp $ */ #ifndef _TCL @@ -1169,8 +1169,13 @@ struct Tcl_HashEntry { * hash table will attempt to rectify this by * randomising the bits and then using the upper * N bits as the index into the table. + * TCL_HASH_KEY_SYSTEM_HASH: + * If this flag is set then all memory internally + * allocated for the hash table that is not for an + * entry will use the system heap. */ #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 +#define TCL_HASH_KEY_SYSTEM_HASH 0x2 /* * Structure definition for the methods associated with a hash table diff --git a/generic/tclHash.c b/generic/tclHash.c index 9d63ffc..483f684 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -10,10 +10,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.13 2003/06/24 19:56:12 dkf Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.14 2003/11/14 23:21:02 dkf Exp $ */ #include "tclInt.h" +#include "tclPort.h" /* * Prevent macros from clashing with function definitions. @@ -626,8 +627,12 @@ Tcl_DeleteHashTable(tablePtr) */ if (tablePtr->buckets != tablePtr->staticBuckets) { + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { + TclpSysFree((char *) tablePtr->buckets); + } else { ckfree((char *) tablePtr->buckets); } + } /* * Arrange for panics if the table is used again without @@ -745,6 +750,26 @@ Tcl_HashStats(tablePtr) double average, tmp; register Tcl_HashEntry *hPtr; char *result, *p; + Tcl_HashKeyType *typePtr; + +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; + if (typePtr == NULL) { + Tcl_Panic("called Tcl_HashStats on deleted table"); + return NULL; + } +#endif /* * Compute a histogram of bucket usage. @@ -774,8 +799,11 @@ Tcl_HashStats(tablePtr) /* * Print out the histogram and a few other pieces of information. */ - + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { + result = (char *) TclpSysAlloc((unsigned) ((NUM_COUNTERS*60) + 300), 0); + } else { result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + } sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); @@ -1122,6 +1150,21 @@ RebuildTable(tablePtr) Tcl_HashKeyType *typePtr; VOID *key; +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; +#endif + oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1131,8 +1174,13 @@ RebuildTable(tablePtr) */ tablePtr->numBuckets *= 4; + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { + tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); + } else { tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { *newChainPtr = NULL; @@ -1141,21 +1189,6 @@ RebuildTable(tablePtr) tablePtr->downShift -= 2; tablePtr->mask = (tablePtr->mask << 2) + 3; -#if TCL_PRESERVE_BINARY_COMPATABILITY - if (tablePtr->keyType == TCL_STRING_KEYS) { - typePtr = &tclStringHashKeyType; - } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { - typePtr = &tclOneWordHashKeyType; - } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS - || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { - typePtr = tablePtr->typePtr; - } else { - typePtr = &tclArrayHashKeyType; - } -#else - typePtr = tablePtr->typePtr; -#endif - /* * Rehash all of the existing entries into the new bucket array. */ @@ -1200,6 +1233,10 @@ RebuildTable(tablePtr) */ if (oldBuckets != tablePtr->staticBuckets) { + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { + TclpSysFree((char *) oldBuckets); + } else { ckfree((char *) oldBuckets); + } } } diff --git a/generic/tclTest.c b/generic/tclTest.c index c9ff8cb..bfc0481 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.70 2003/11/14 20:44:45 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.71 2003/11/14 23:21:02 dkf Exp $ */ #define TCL_TEST @@ -423,6 +423,9 @@ static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr)); static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestHashSystemHashCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -620,6 +623,9 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testhashsystemhash", + TestHashSystemHashCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, @@ -6449,3 +6455,78 @@ TestNumUtfCharsCmd(clientData, interp, objc, objv) } return TCL_OK; } + +/* + * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag + */ +static int +TestHashSystemHashCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + static const Tcl_HashKeyType hkType = { + TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH, + NULL, NULL, NULL, NULL + }; + Tcl_HashTable hash; + Tcl_HashEntry *hPtr; + int i, isNew, limit = 100; + + if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) { + return TCL_ERROR; + } + + Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType); + + if (hash.numEntries != 0) { + Tcl_AppendResult(interp, "non-zero initial size", NULL); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + + for (i=0 ; i<limit ; i++) { + hPtr = Tcl_CreateHashEntry(&hash, (char *)i, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + Tcl_SetHashValue(hPtr, (ClientData) (i+42)); + } + + if (hash.numEntries != limit) { + Tcl_AppendResult(interp, "unexpected maximal size", NULL); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + + for (i=0 ; i<limit ; i++) { + hPtr = Tcl_FindHashEntry(&hash, (char *)i); + if (hPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + if ((int)(Tcl_GetHashValue(hPtr)) != i+42) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + Tcl_DeleteHashEntry(hPtr); + } + + if (hash.numEntries != 0) { + Tcl_AppendResult(interp, "non-zero final size", NULL); + Tcl_DeleteHashTable(&hash); + return TCL_ERROR; + } + + Tcl_DeleteHashTable(&hash); + Tcl_AppendResult(interp, "OK", NULL); + return TCL_OK; +} |