diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/DictObj.3 | 16 | ||||
| -rw-r--r-- | doc/dict.n | 31 | ||||
| -rw-r--r-- | generic/tcl.h | 5 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 477 | ||||
| -rw-r--r-- | generic/tclInt.h | 10 | ||||
| -rw-r--r-- | generic/tclObj.c | 37 | ||||
| -rw-r--r-- | tests/init.test | 4 | ||||
| -rw-r--r-- | tests/ioCmd.test | 57 | ||||
| -rw-r--r-- | tests/string.test | 6 |
10 files changed, 416 insertions, 237 deletions
@@ -1,4 +1,12 @@ -2007-11-20 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> +2007-11-20 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclDictObj.c: Changed the underlying implementation of the + hash table used in dictionaries to additionally keep all entries in + the hash table in a linked list, which is only ever added to at the + end. This makes iteration over all entries in the dictionary in + key insertion order a trivial operation, and so cleans up a great deal + of complexity relating to dictionary representation and stability of + iteration order. * generic/tclConfig.c (QueryConfigObjCmd): Correct usage of Tcl_WrongNumArgs. diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 20d3514..4e72a1c 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: DictObj.3,v 1.9 2007/06/29 22:37:27 dkf Exp $ +'\" RCS: @(#) $Id: DictObj.3,v 1.10 2007/11/20 20:43:11 dkf Exp $ '\" .so man.macros .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" @@ -99,9 +99,14 @@ sub-dictionaries of the main dictionary object passed to them. .SH DESCRIPTION .PP Tcl dictionary objects have an internal representation that supports -efficient mapping from keys to values and which does not guarantee any -particular ordering of keys within the dictionary (the underlying -basic data-structure is a hash table created with \fBTcl_InitObjHashTable\fR). +efficient mapping from keys to values and which guarantees that the +particular ordering of keys within the dictionary remains the same +modulo any keys being deleted (which removes them from the order) or +added (which adds them to the end of the order). If reinterpreted as a +list, the values at the even-valued indices in the list will be the +keys of the dictionary, and each will be followed (in the odd-valued +index) bu the value associated with that key. +.PP The procedures described in this man page are used to create, modify, index, and iterate over dictionary objects from C code. .PP @@ -190,7 +195,7 @@ keys must exist and have dictionaries as their values. .SH EXAMPLE Using the dictionary iteration interface to search determine if there is a key that maps to itself: - +.PP .CS Tcl_DictSearch search; Tcl_Obj *key, *value; @@ -225,7 +230,6 @@ for (; done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!done)); return TCL_OK; .CE - .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable .SH KEYWORDS @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: dict.n,v 1.15 2007/10/29 01:42:18 dkf Exp $ +'\" RCS: @(#) $Id: dict.n,v 1.16 2007/11/20 20:43:11 dkf Exp $ '\" .so man.macros .TH dict n 8.5 Tcl "Tcl Built-In Commands" @@ -60,7 +60,8 @@ argument after the rule selection word is a two-element list. If the \fIscript\fR returns with a condition of \fBTCL_BREAK\fR, no further key/value pairs are considered for inclusion in the resulting dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false -result. The order in which the key/value pairs are tested is undefined. +result. The key/value pairs are tested in the order in which the keys +were inserted into the dictionary. .TP \fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern\fR The value rule only matches those key/value pairs whose values match @@ -78,7 +79,8 @@ body generates a \fBTCL_BREAK\fR result, no further pairs from the dictionary will be iterated over and the \fBdict for\fR command will terminate successfully immediately. If any evaluation of the body generates a \fBTCL_CONTINUE\fR result, this shall be treated exactly like a -normal \fBTCL_OK\fR result. The order of iteration is undefined. +normal \fBTCL_OK\fR result. The order of iteration is the order in +which the keys were inserted into the dictionary. .TP \fBdict get \fIdictionaryValue \fR?\fIkey ...\fR? Given a dictionary value (first argument) and a key (second argument), @@ -120,11 +122,8 @@ string produced by \fBTcl_HashStats\fR, similar to \fBarray info\fR. \fBdict keys \fIdictionaryValue \fR?\fIglobPattern\fR? Return a list of all keys in the given dictionary value. If a pattern is supplied, only those keys that match it (according to the rules of -\fBstring match\fR) will be returned. The returned keys will be in an -arbitrary implementation-specific order, though where no pattern is -supplied the \fIi\fR'th key returned by \fBdict keys\fR will be the key for -the \fIi\fR'th value returned by \fBdict values\fR applied to the same -dictionary value. +\fBstring match\fR) will be returned. The returned keys will be in the +order that they were inserted into the dictionary. .TP \fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR? This appends the given items to the list value that the given key maps @@ -194,10 +193,8 @@ contents only happen when \fIbody\fR terminates. Return a list of all values in the given dictionary value. If a pattern is supplied, only those values that match it (according to the rules of \fBstring match\fR) will be returned. The returned values -will be in an arbitrary implementation-specific order, though where no -pattern is supplied the \fIi\fR'th key returned by \fBdict keys\fR will be -the key for the \fIi\fR'th value returned by \fBdict values\fR applied to -the same dictionary value. +will be in the order of that the keys associated with those values +were inserted into the dictionary. .TP \fBdict with \fIdictionaryVariable \fR?\fIkey ...\fR? \fIbody\fR Execute the Tcl script in \fIbody\fR with the value for each key in @@ -215,15 +212,15 @@ dictionaries no longer exists. The result of \fBdict with\fR is traces; changes to the \fIdictionaryVariable\fR's contents only happen when \fIbody\fR terminates. .SH "DICTIONARY VALUES" -Dictionaries are values that contain an efficient (but \fInot\fR -order-preserving) mapping from arbitrary keys to arbitrary values. +Dictionaries are values that contain an efficient, order-preserving +mapping from arbitrary keys to arbitrary values. They have a textual format that is exactly that of any list with an even number of elements, with each mapping in the dictionary being -represented as two items in the list. When a command takes a +represented as two items in the list. When a command takes a dictionary and produces a new dictionary based on it (either returning it or writing it back into the variable that the starting dictionary -was read from) there is \fIno\fR guarantee that the new dictionary -will have the same ordering of keys. +was read from) the new dictionary will have the same order of keys, +modulo any deleted keys and with new keys added on to the end. .SH EXAMPLES Constructing and using nested dictionaries: .CS diff --git a/generic/tcl.h b/generic/tcl.h index f9fdb1f..db919dc 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.244 2007/11/19 18:14:48 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.245 2007/11/20 20:43:11 dkf Exp $ */ #ifndef _TCL @@ -1264,7 +1264,8 @@ typedef struct Tcl_HashSearch { */ typedef struct { - Tcl_HashSearch search; /* Search struct for underlying hash table. */ + void *next; /* Search position for underlying hash + * table. */ int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f2d6807..1a81260 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.52 2007/11/19 11:17:24 dkf Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.53 2007/11/20 20:43:11 dkf Exp $ */ #include "tclInt.h" @@ -26,48 +26,65 @@ struct Dict; static void DeleteDict(struct Dict *dict); static int DictAppendCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictCreateCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictExistsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictFilterCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictForCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictGetCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictIncrCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictInfoCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictKeysCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictLappendCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictMergeCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictRemoveCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictReplaceCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictSetCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictSizeCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictUnsetCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictValuesCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictUpdateCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static int DictWithCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv); + int objc, Tcl_Obj *const *objv); static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeDictInternalRep(Tcl_Obj *dictPtr); static void InvalidateDictChain(Tcl_Obj *dictObj); static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDict(Tcl_Obj *dictPtr); +static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr); +static inline void InitChainTable(struct Dict *dict); +static inline void DeleteChainTable(struct Dict *dict); +static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, + Tcl_Obj *keyPtr, int *newPtr); +static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); + +/* + * Internal representation of the entries in the hash table that backs a + * dictionary. + */ + +typedef struct ChainEntry { + Tcl_HashEntry entry; + struct ChainEntry *prevPtr; + struct ChainEntry *nextPtr; +} ChainEntry; /* * Internal representation of a dictionary. @@ -86,6 +103,14 @@ static void UpdateStringOfDict(Tcl_Obj *dictPtr); typedef struct Dict { Tcl_HashTable table; /* Object hash table to store mapping in. */ + ChainEntry *entryChainHead; /* Linked list of all entries in the + * dictionary. Used for doing traversal of the + * entries in the order that they are + * created. */ + ChainEntry *entryChainTail; /* Other end of linked list of all entries in + * the dictionary. Used for doing traversal of + * the entries in the order that they are + * created. */ int epoch; /* Epoch counter */ int refcount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the @@ -105,6 +130,153 @@ Tcl_ObjType tclDictType = { UpdateStringOfDict, /* updateStringProc */ SetDictFromAny /* setFromAnyProc */ }; + +/* + * The type of the specially adapted version of the Tcl_Obj*-containing hash + * table defined in the tclObj.c code. This version differs in that it + * allocates a bit more space in each hash entry in order to hold the pointers + * used to keep the hash entries in a linked list. + */ + +static Tcl_HashKeyType chainHashType = { + TCL_HASH_KEY_TYPE_VERSION, + 0, + TclHashObjKey, + TclCompareObjKeys, + AllocChainEntry, + TclFreeObjEntry +}; + +/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/ + +/* + *---------------------------------------------------------------------- + * + * AllocChainEntry -- + * + * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key, and + * which has a bit of extra space afterwards for storing pointers to the + * rest of the chain of entries (the extra pointers are left NULL). + * + * Results: + * The return value is a pointer to the created entry. + * + * Side effects: + * Increments the reference count on the object. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +AllocChainEntry( + Tcl_HashTable *tablePtr, + void *keyPtr) +{ + Tcl_Obj *objPtr = keyPtr; + ChainEntry *cPtr; + + cPtr = (ChainEntry *) ckalloc(sizeof(ChainEntry)); + cPtr->entry.key.oneWordValue = (char *) objPtr; + Tcl_IncrRefCount(objPtr); + cPtr->entry.clientData = NULL; + cPtr->prevPtr = cPtr->nextPtr = NULL; + + return &cPtr->entry; +} + +/* + * Helper functions that disguise most of the details relating to how the + * linked list of hash entries is managed. In particular, these manage the + * creation of the table and initializing of the chain, the deletion of the + * table and chain, the adding of an entry to the chain, and the removal of an + * entry from the chain. + */ + +static inline void +InitChainTable( + Dict *dict) +{ + Tcl_InitCustomHashTable(&dict->table, TCL_CUSTOM_PTR_KEYS, + &chainHashType); + dict->entryChainHead = dict->entryChainTail = NULL; +} + +static inline void +DeleteChainTable( + Dict *dict) +{ + ChainEntry *cPtr; + + for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + + TclDecrRefCount(valuePtr); + } + Tcl_DeleteHashTable(&dict->table); +} + +static inline Tcl_HashEntry * +CreateChainEntry( + Dict *dict, + Tcl_Obj *keyPtr, + int *newPtr) +{ + ChainEntry *cPtr = (ChainEntry *) + Tcl_CreateHashEntry(&dict->table, (char *) keyPtr, newPtr); + + /* + * If this is a new entry in the hash table, stitch it into the chain. + */ + + if (*newPtr) { + cPtr->nextPtr = NULL; + if (dict->entryChainHead == NULL) { + cPtr->prevPtr = NULL; + dict->entryChainHead = cPtr; + dict->entryChainTail = cPtr; + } else { + cPtr->prevPtr = dict->entryChainTail; + dict->entryChainTail->nextPtr = cPtr; + dict->entryChainTail = cPtr; + } + } + + return &cPtr->entry; +} + +static inline int +DeleteChainEntry( + Dict *dict, + Tcl_Obj *keyPtr) +{ + ChainEntry *cPtr = (ChainEntry *) + Tcl_FindHashEntry(&dict->table, (char *) keyPtr); + + if (cPtr == NULL) { + return 0; + } else { + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + TclDecrRefCount(valuePtr); + } + + /* + * Unstitch from the chain. + */ + + if (cPtr->nextPtr) { + cPtr->nextPtr->prevPtr = cPtr->prevPtr; + } else { + dict->entryChainTail = cPtr->prevPtr; + } + if (cPtr->prevPtr) { + cPtr->prevPtr->nextPtr = cPtr->nextPtr; + } else { + dict->entryChainHead = cPtr->nextPtr; + } + + Tcl_DeleteHashEntry(&cPtr->entry); + return 1; +} /* *---------------------------------------------------------------------- @@ -133,29 +305,33 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = (Dict *) srcPtr->internalRep.otherValuePtr; + Dict *oldDict = srcPtr->internalRep.otherValuePtr; Dict *newDict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - Tcl_Obj *keyPtr, *valuePtr; - int isNew; + ChainEntry *cPtr; /* * Copy values across from the old hash table. */ - Tcl_InitObjHashTable(&newDict->table); - for (hPtr=Tcl_FirstHashEntry(&oldDict->table,&search); hPtr!=NULL; - hPtr=Tcl_NextHashEntry(&search)) { - keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&oldDict->table, hPtr); - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - newHPtr = Tcl_CreateHashEntry(&newDict->table, (char *)keyPtr, &isNew); - Tcl_SetHashValue(newHPtr, (ClientData)valuePtr); + + InitChainTable(newDict); + for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { + void *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry); + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + int n; + Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n); + + /* + * Fill in the contents. + */ + + Tcl_SetHashValue(hPtr, (ClientData) valuePtr); Tcl_IncrRefCount(valuePtr); } /* * Initialise other fields. */ + newDict->epoch = 0; newDict->chain = NULL; newDict->refcount = 1; @@ -163,7 +339,8 @@ DupDictInternalRep( /* * Store in the object. */ - copyPtr->internalRep.otherValuePtr = (void *) newDict; + + copyPtr->internalRep.otherValuePtr = newDict; copyPtr->typePtr = &tclDictType; } @@ -189,7 +366,7 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; + Dict *dict = dictPtr->internalRep.otherValuePtr; --dict->refcount; if (dict->refcount <= 0) { @@ -223,22 +400,7 @@ static void DeleteDict( Dict *dict) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_Obj *valuePtr; - - /* - * Delete the values ourselves, because hashes know nothing about their - * contents (but do know about the key type, so that doesn't need explicit - * attention.) - */ - - for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); hPtr!=NULL; - hPtr=Tcl_NextHashEntry(&search)) { - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - TclDecrRefCount(valuePtr); - } - Tcl_DeleteHashTable(&dict->table); + DeleteChainTable(dict); ckfree((char *) dict); } @@ -270,9 +432,8 @@ UpdateStringOfDict( { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; - Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + Dict *dict = dictPtr->internalRep.otherValuePtr; + ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int numElems, i, length; char *elem, *dst; @@ -294,19 +455,18 @@ UpdateStringOfDict( flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); } dictPtr->length = 1; - for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; i<numElems ; - i+=2,hPtr=Tcl_NextHashEntry(&search)) { + for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* - * Assume that hPtr is never NULL since we know the number of array + * Assume that cPtr is never NULL since we know the number of array * elements already. */ - keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); + keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dictPtr->length += Tcl_ScanCountedElement(elem, length, &flagPtr[i]) + 1; - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dictPtr->length += Tcl_ScanCountedElement(elem, length, &flagPtr[i+1]) + 1; @@ -318,15 +478,14 @@ UpdateStringOfDict( dictPtr->bytes = ckalloc((unsigned) dictPtr->length); dst = dictPtr->bytes; - for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; i<numElems ; - i+=2,hPtr=Tcl_NextHashEntry(&search)) { - keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); + for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { + keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) ); + flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); *(dst++) = ' '; - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i+1] | TCL_DONT_QUOTE_HASH); @@ -369,14 +528,13 @@ SetDictFromAny( Tcl_Obj *objPtr) { char *string, *s; - CONST char *elemStart, *nextElem; + const char *elemStart, *nextElem; int lenRemain, length, elemSize, hasBrace, result, isNew; char *limit; /* Points just after string's last byte. */ - register CONST char *p; + register const char *p; register Tcl_Obj *keyPtr, *valuePtr; Dict *dict; Tcl_HashEntry *hPtr; - Tcl_HashSearch search; /* * Since lists and dictionaries have very closely-related string @@ -411,20 +569,22 @@ SetDictFromAny( /* * Build the hash of key/value pairs. */ + dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + InitChainTable(dict); for (i=0 ; i<objc ; i+=2) { /* * Store key and value in the hash table we're building. */ - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)objv[i], &isNew); + hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { - Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + TclDecrRefCount(discardedValue); } - Tcl_SetHashValue(hPtr, (ClientData) objv[i+1]); - Tcl_IncrRefCount(objv[i+1]); /* since hash now holds ref to it */ + Tcl_SetHashValue(hPtr, objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } /* @@ -447,7 +607,7 @@ SetDictFromAny( */ dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + InitChainTable(dict); for (p = string, lenRemain = length; lenRemain > 0; p = nextElem, lenRemain = (limit - nextElem)) { @@ -514,17 +674,18 @@ SetDictFromAny( * Store key and value in the hash table we're building. */ - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); + hPtr = CreateChainEntry(dict, keyPtr, &isNew); if (!isNew) { - Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + TclDecrRefCount(keyPtr); TclDecrRefCount(discardedValue); } - Tcl_SetHashValue(hPtr, (ClientData) valuePtr); + Tcl_SetHashValue(hPtr, valuePtr); Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - installHash: + installHash: /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular @@ -535,24 +696,19 @@ SetDictFromAny( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.otherValuePtr = (void *) dict; + objPtr->internalRep.otherValuePtr = dict; objPtr->typePtr = &tclDictType; return TCL_OK; - missingKey: + missingKey: if (interp != NULL) { Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); } TclDecrRefCount(keyPtr); result = TCL_ERROR; - errorExit: - for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - TclDecrRefCount(valuePtr); - } - Tcl_DeleteHashTable(&dict->table); + errorExit: + DeleteChainTable(dict); ckfree((char *) dict); return result; } @@ -594,7 +750,7 @@ TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, - Tcl_Obj *CONST keyv[], + Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; @@ -605,7 +761,7 @@ TclTraceDictPath( return NULL; } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.otherValuePtr; if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -616,6 +772,7 @@ TclTraceDictPath( if (hPtr == NULL) { int isNew; /* Dummy */ + if (flags & DICT_PATH_EXISTS) { return DICT_PATH_NON_EXISTENT; } @@ -633,12 +790,13 @@ TclTraceDictPath( /* * The next line should always set isNew to 1. */ - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[i], &isNew); + + hPtr = CreateChainEntry(dict, keyv[i], &isNew); tmpObj = Tcl_NewDictObj(); Tcl_IncrRefCount(tmpObj); - Tcl_SetHashValue(hPtr, (ClientData) tmpObj); + Tcl_SetHashValue(hPtr, tmpObj); } else { - tmpObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + tmpObj = Tcl_GetHashValue(hPtr); if (tmpObj->typePtr != &tclDictType) { if (SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; @@ -646,7 +804,7 @@ TclTraceDictPath( } } - newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.otherValuePtr; if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -654,7 +812,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, (ClientData) tmpObj); dict->epoch++; - newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.otherValuePtr; } newDict->chain = dictPtr; @@ -689,7 +847,7 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = (Dict *) dictObj->internalRep.otherValuePtr; + Dict *dict = dictObj->internalRep.otherValuePtr; do { Tcl_InvalidateStringRep(dictObj); @@ -699,7 +857,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - dict = (Dict *) dictObj->internalRep.otherValuePtr; + dict = dictObj->internalRep.otherValuePtr; } while (dict != NULL); } @@ -739,6 +897,7 @@ Tcl_DictObjPut( if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { return result; } @@ -747,11 +906,12 @@ Tcl_DictObjPut( if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); + dict = dictPtr->internalRep.otherValuePtr; + hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { - Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); @@ -796,12 +956,12 @@ Tcl_DictObjGet( } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyPtr); + dict = dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_FindHashEntry(&dict->table, (char *) keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(hPtr); } return TCL_OK; } @@ -832,7 +992,6 @@ Tcl_DictObjRemove( Tcl_Obj *keyPtr) { Dict *dict; - Tcl_HashEntry *hPtr; if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); @@ -848,13 +1007,8 @@ Tcl_DictObjRemove( if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyPtr); - if (hPtr != NULL) { - Tcl_Obj *valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - - TclDecrRefCount(valuePtr); - Tcl_DeleteHashEntry(hPtr); + dict = dictPtr->internalRep.otherValuePtr; + if (DeleteChainEntry(dict, keyPtr)) { dict->epoch++; } return TCL_OK; @@ -893,7 +1047,7 @@ Tcl_DictObjSize( } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.otherValuePtr; *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -938,30 +1092,33 @@ Tcl_DictObjFirst( * otherwise. */ { Dict *dict; - Tcl_HashEntry *hPtr; + ChainEntry *cPtr; if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { return result; } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_FirstHashEntry(&dict->table, &searchPtr->search); - if (hPtr == NULL) { + dict = dictPtr->internalRep.otherValuePtr; + cPtr = dict->entryChainHead; + if (cPtr == NULL) { searchPtr->epoch = -1; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; + searchPtr->next = cPtr->nextPtr; dict->refcount++; if (keyPtrPtr != NULL) { - *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); + *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, + &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } return TCL_OK; @@ -1004,7 +1161,7 @@ Tcl_DictObjNext( * values in the dictionary, or a 0 * otherwise. */ { - Tcl_HashEntry *hPtr; + ChainEntry *cPtr; /* * If the searh is done; we do no work. @@ -1024,20 +1181,21 @@ Tcl_DictObjNext( Tcl_Panic("concurrent dictionary modification and search"); } - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { + cPtr = searchPtr->next; + if (cPtr == NULL) { Tcl_DictObjDone(searchPtr); *donePtr = 1; return; } + searchPtr->next = cPtr->nextPtr; *donePtr = 0; if (keyPtrPtr != NULL) { *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey( - &((Dict *)searchPtr->dictionaryPtr)->table, hPtr); + &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } @@ -1101,7 +1259,7 @@ Tcl_DictObjPutKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, - Tcl_Obj *CONST keyv[], + Tcl_Obj *const keyv[], Tcl_Obj *valuePtr) { Dict *dict; @@ -1120,11 +1278,11 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew); + dict = dictPtr->internalRep.otherValuePtr; + hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { - Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); @@ -1160,10 +1318,9 @@ Tcl_DictObjRemoveKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, - Tcl_Obj *CONST keyv[]) + Tcl_Obj *const keyv[]) { Dict *dict; - Tcl_HashEntry *hPtr; if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList"); @@ -1177,13 +1334,8 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]); - if (hPtr != NULL) { - Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - TclDecrRefCount(oldValuePtr); - Tcl_DeleteHashEntry(hPtr); - } + dict = dictPtr->internalRep.otherValuePtr; + DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } @@ -1224,11 +1376,11 @@ Tcl_NewDictObj(void) TclNewObj(dictPtr); Tcl_InvalidateStringRep(dictPtr); dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (void *) dict; + dictPtr->internalRep.otherValuePtr = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1263,7 +1415,7 @@ Tcl_NewDictObj(void) Tcl_Obj * Tcl_DbNewDictObj( - CONST char *file, + const char *file, int line) { #ifdef TCL_MEM_DEBUG @@ -1273,11 +1425,11 @@ Tcl_DbNewDictObj( TclDbNewObj(dictPtr, file, line); Tcl_InvalidateStringRep(dictPtr); dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (void *) dict; + dictPtr->internalRep.otherValuePtr = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1309,7 +1461,7 @@ static int DictCreateCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictObj; int i; @@ -1358,7 +1510,7 @@ static int DictGetCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr = NULL; int result; @@ -1448,7 +1600,7 @@ static int DictReplaceCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; int i, result; @@ -1499,7 +1651,7 @@ static int DictRemoveCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; int i, result; @@ -1550,7 +1702,7 @@ static int DictMergeCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *targetObj, *keyObj, *valueObj; int allocatedDict = 0; @@ -1635,7 +1787,7 @@ static int DictKeysCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *listPtr; char *pattern = NULL; @@ -1716,7 +1868,7 @@ static int DictValuesCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *valuePtr, *listPtr; Tcl_DictSearch search; @@ -1772,7 +1924,7 @@ static int DictSizeCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { int result, size; @@ -1809,7 +1961,7 @@ static int DictExistsCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr; int result; @@ -1858,7 +2010,7 @@ static int DictInfoCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; Dict *dict; @@ -1875,12 +2027,13 @@ DictInfoCmd( return result; } } - dict = (Dict *)dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.otherValuePtr; + /* * This next cast is actually OK. */ - Tcl_SetResult(interp, (char *)Tcl_HashStats(&dict->table), TCL_DYNAMIC); + Tcl_SetResult(interp, (char *) Tcl_HashStats(&dict->table), TCL_DYNAMIC); return TCL_OK; } @@ -1906,7 +2059,7 @@ static int DictIncrCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { int code = TCL_OK; Tcl_Obj *dictPtr, *valuePtr = NULL; @@ -2018,7 +2171,7 @@ static int DictLappendCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0, allocatedValue = 0; @@ -2104,7 +2257,7 @@ static int DictAppendCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0; @@ -2175,7 +2328,7 @@ static int DictForCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Interp* iPtr = (Interp*) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; @@ -2299,7 +2452,7 @@ static int DictSetCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; @@ -2358,7 +2511,7 @@ static int DictUnsetCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; @@ -2416,10 +2569,10 @@ static int DictFilterCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Interp* iPtr = (Interp*) interp; - static CONST char *filters[] = { + static const char *filters[] = { "key", "script", "value", NULL }; enum FilterTypes { @@ -2675,7 +2828,7 @@ static int DictUpdateCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *objPtr; int i, result, dummy; @@ -2801,7 +2954,7 @@ static int DictWithCmd( Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { Interp* iPtr = (Interp*) interp; Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr; @@ -2988,9 +3141,9 @@ Tcl_DictObjCmd( /*ignored*/ ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { - static CONST char *subcommands[] = { + static const char *subcommands[] = { "append", "create", "exists", "filter", "for", "get", "incr", "info", "keys", "lappend", "merge", "remove", "replace", "set", "size", "unset", diff --git a/generic/tclInt.h b/generic/tclInt.h index b40786c..479232b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.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: tclInt.h,v 1.348 2007/11/18 21:59:25 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.349 2007/11/20 20:43:12 dkf Exp $ */ #ifndef _TCLINT @@ -3195,6 +3195,14 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, int flags, int leaveErrMsg, int index); /* + * So tclObj.c and tclDictObj.c can share these implementations. + */ + +MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); +MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); +MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. diff --git a/generic/tclObj.c b/generic/tclObj.c index f44f3af..91b3f35 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -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: tclObj.c,v 1.137 2007/11/11 19:32:16 msofer Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.138 2007/11/20 20:43:12 dkf Exp $ */ #include "tclInt.h" @@ -188,9 +188,6 @@ static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); -static int CompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static void FreeObjEntry(Tcl_HashEntry *hPtr); -static unsigned int HashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the CommandName object type. @@ -258,12 +255,12 @@ Tcl_ObjType tclBignumType = { */ Tcl_HashKeyType tclObjHashKeyType = { - TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ - HashObjKey, /* hashKeyProc */ - CompareObjKeys, /* compareKeysProc */ - AllocObjEntry, /* allocEntryProc */ - FreeObjEntry /* freeEntryProc */ + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + TclHashObjKey, /* hashKeyProc */ + TclCompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + TclFreeObjEntry /* freeEntryProc */ }; /* @@ -3325,14 +3322,14 @@ AllocObjEntry( hPtr->key.oneWordValue = (char *) objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; - + return hPtr; } /* *---------------------------------------------------------------------- * - * CompareObjKeys -- + * TclCompareObjKeys -- * * Compares two Tcl_Obj * keys. * @@ -3346,8 +3343,8 @@ AllocObjEntry( *---------------------------------------------------------------------- */ -static int -CompareObjKeys( +int +TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { @@ -3395,7 +3392,7 @@ CompareObjKeys( /* *---------------------------------------------------------------------- * - * FreeObjEntry -- + * TclFreeObjEntry -- * * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. * @@ -3408,8 +3405,8 @@ CompareObjKeys( *---------------------------------------------------------------------- */ -static void -FreeObjEntry( +void +TclFreeObjEntry( Tcl_HashEntry *hPtr) /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; @@ -3421,7 +3418,7 @@ FreeObjEntry( /* *---------------------------------------------------------------------- * - * HashObjKey -- + * TclHashObjKey -- * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. @@ -3436,8 +3433,8 @@ FreeObjEntry( *---------------------------------------------------------------------- */ -static unsigned int -HashObjKey( +unsigned int +TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { diff --git a/tests/init.test b/tests/init.test index 520a731..c5907d8 100644 --- a/tests/init.test +++ b/tests/init.test @@ -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: init.test,v 1.16 2007/09/07 15:51:26 dgp Exp $ +# RCS: @(#) $Id: init.test,v 1.17 2007/11/20 20:43:13 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -207,7 +207,7 @@ test init-5.0 {return options passed through ::unknown} -setup { list $code $foo $bar $code2 $foo2 $bar2 } -cleanup { unset ::auto_index(::xxx) -} -result {2 xxx {-code 1 -level 1 -errorcode NONE} 2 xxx {-code 1 -level 1 -errorcode NONE}} +} -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}} cleanupTests } ;# End of [interp eval $testInterp] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 9d39de9..baf7ae3 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -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: ioCmd.test,v 1.32 2007/11/19 14:22:26 dkf Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.33 2007/11/20 20:43:13 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -761,6 +761,10 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g proc note {item} {global res; lappend res $item; return} proc track {} {upvar args item; note $item; return} proc notes {items} {foreach i $items {note $i}} +# This forces the return options to be in the order that the test expects! +proc noteOpts opts {global res; lappend res [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! +} $opts]; return} # Helper command, canned result for 'initialize' method. # Gets the optional methods as arguments. Use return features @@ -858,13 +862,15 @@ test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} -test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { +test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -setup { set res {} +} -body { proc foo {args} {track; oninit; return -level 5 -code 777 BANG} note [set c [chan create {r w} foo]] - note [catch {close $c} msg opt]; note $msg; note $opt + note [catch {close $c} msg opt]; note $msg; noteOpts $opt + return $res +} -cleanup { rename foo {} - set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### @@ -960,7 +966,7 @@ test iocmd-23.8 {chan read, level is squashed} -match glob -body { return -level 55 -code 777 BOOM! } set c [chan create {r w} foo] - note [catch {read $c 2} msg opt]; note $msg; note $opt + note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1100,7 +1106,7 @@ test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] note $msg - note $opt + noteOpts $opt close $c rename foo {} set res @@ -1218,7 +1224,7 @@ test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { return -level 55 -code 777 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg opt]; note $msg; note $opt + note [catch {fconfigure $c} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1302,7 +1308,7 @@ test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body return -level 55 -code 444 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg opt]; note $msg; note $opt + note [catch {fconfigure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1375,7 +1381,7 @@ test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body return -level 77 -code 333 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg opt]; note $msg; note $opt + note [catch {fconfigure $c -rc-foo} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1433,7 +1439,7 @@ test iocmd-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} set c [chan create {r w} foo] - note [catch {tell $c} msg opt]; note $msg; note $opt + note [catch {tell $c} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1514,7 +1520,7 @@ test iocmd-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} set c [chan create {r w} foo] - note [catch {seek $c 0 start} msg opt]; note $msg; note $opt + note [catch {seek $c 0 start} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1650,14 +1656,16 @@ test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} -test iocmd-29.10 {chan blocking, level is ignored} -match glob -body { +test iocmd-29.10 {chan blocking, level is ignored} -match glob -setup { set res {} +} -body { proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg opt]; note $msg; note $opt + note [catch {fconfigure $c -blocking 0} msg opt]; note $msg; noteOpts $opt catch {close $c} + return $res +} -cleanup { rename foo {} - set res } -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} @@ -1840,6 +1848,9 @@ proc inthread {chan script args} { testthread send $tid { proc note {item} {global notes; lappend notes $item} proc notes {} {global notes; return $notes} + proc noteOpts opts {global notes; lappend notes [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! + } $opts]} } testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) @@ -1960,7 +1971,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match proc foo {args} {track; oninit; return -level 5 -code 777 BANG} note [set c [chan create {r w} foo]] notes [inthread $c { - note [catch {close $c} msg opt]; note $msg; note $opt + note [catch {close $c} msg opt]; note $msg; noteOpts $opt notes } c] rename foo {} @@ -2087,7 +2098,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [catch {read $c 2} msg opt]; note $msg; note $opt + note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt close $c notes } c] @@ -2273,7 +2284,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -2436,7 +2447,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod notes [inthread $c { note [catch {fconfigure $c} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -2551,7 +2562,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -2652,7 +2663,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -2740,7 +2751,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { notes [inthread $c { note [catch {tell $c} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -2866,7 +2877,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { notes [inthread $c { note [catch {seek $c 0 start} msg opt] note $msg - note $opt + noteOpts $opt close $c notes } c] @@ -3070,7 +3081,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg opt] note $msg - note $opt + noteOpts $opt catch {close $c} notes } c] diff --git a/tests/string.test b/tests/string.test index f6c4954..e421738 100644 --- a/tests/string.test +++ b/tests/string.test @@ -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: string.test,v 1.66 2007/11/01 11:11:45 dkf Exp $ +# RCS: @(#) $Id: string.test,v 1.67 2007/11/20 20:43:13 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -821,10 +821,10 @@ test string-10.18 {string map, empty argument} { test string-10.19 {string map, empty arguments} { string map -nocase {{} abc f bar {} def} foo } baroo -test string-10.20 {string map, dictionaries can alter map ordering} { +test string-10.20 {string map, dictionaries don't alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] -} {YYY XY 2 XY} +} {XY XY 2 XY} test string-10.21 {string map, ABR checks} { string map {longstring foob} long } long |