diff options
Diffstat (limited to 'generic/tclDictObj.c')
| -rw-r--r-- | generic/tclDictObj.c | 3080 |
1 files changed, 1852 insertions, 1228 deletions
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 1e428a1..e31d708 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1,18 +1,17 @@ -/* +/* * tclDictObj.c -- * - * This file contains procedures that implement the Tcl dict object - * type and its accessor command. - * - * Copyright (c) 2002 by Donal K. Fellows. + * This file contains functions that implement the Tcl dict object type + * and its accessor command. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * Copyright (c) 2002-2010 by Donal K. Fellows. * - * RCS: @(#) $Id: tclDictObj.c,v 1.33 2005/07/21 21:49:05 dkf Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tommath.h" /* * Forward declaration. @@ -20,142 +19,375 @@ struct Dict; /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: + */ + +static void DeleteDict(struct Dict *dict); +static int DictAppendCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictCreateCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictMergeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictRemoveCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictReplaceCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictSetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictSizeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictUnsetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictUpdateCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictValuesCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictWithCmd(ClientData dummy, Tcl_Interp *interp, + 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); +static int FinalizeDictUpdate(ClientData data[], + Tcl_Interp *interp, int result); +static int FinalizeDictWith(ClientData data[], + Tcl_Interp *interp, int result); +static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictForLoopCallback(ClientData data[], + Tcl_Interp *interp, int result); +static int DictMapLoopCallback(ClientData data[], + Tcl_Interp *interp, int result); + +/* + * Table of dict subcommand names and implementations. */ -static void DeleteDict _ANSI_ARGS_((struct Dict *dict)); -static int DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictCreateCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictExistsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictFilterCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictForCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictGetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictInfoCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictKeysCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictMergeCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictRemoveCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictReplaceCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictSizeCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictUnsetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictValuesCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictUpdateCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictWithCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); -static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj)); -static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr)); +static const EnsembleImplMap implementationMap[] = { + {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, + {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, + {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, + {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, + {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, + {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, + {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, + {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, + {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, + {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, + {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, + {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, + {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, + {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, + {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, + {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, + {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, + {NULL, NULL, NULL, NULL, NULL, 0} +}; + +/* + * 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. * - * The internal representation of a dictionary object is a hash table - * (with Tcl_Objs for both keys and values), a reference count and - * epoch number for detecting concurrent modifications of the - * dictionary, and a pointer to the parent object (used when - * invalidating string reps of pathed dictionary trees) which is NULL - * in normal use. The fact that hash tables know (with appropriate - * initialisation) already about objects makes key management /so/ + * The internal representation of a dictionary object is a hash table (with + * Tcl_Objs for both keys and values), a reference count and epoch number for + * detecting concurrent modifications of the dictionary, and a pointer to the + * parent object (used when invalidating string reps of pathed dictionary + * trees) which is NULL in normal use. The fact that hash tables know (with + * appropriate initialisation) already about objects makes key management /so/ * much easier! * - * Reference counts are used to enable safe iteration across hashes - * while allowing the type of the containing object to be modified. + * Reference counts are used to enable safe iteration across hashes while + * allowing the type of the containing object to be modified. */ typedef struct Dict { - Tcl_HashTable table; - int epoch; - int refcount; - Tcl_Obj *chain; + 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 + * string representations of updated nested + * dictionaries. */ } Dict; /* * The structure below defines the dictionary object type by means of - * procedures that can be invoked by generic object code. + * functions that can be invoked by generic object code. */ -Tcl_ObjType tclDictType = { +const Tcl_ObjType tclDictType = { "dict", FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ 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. + * + * Note that this type of hash table is *only* suitable for direct use in + * *this* file. Everything else should use the dict iterator API. + */ + +static const Tcl_HashKeyType chainHashType = { + TCL_HASH_KEY_TYPE_VERSION, + 0, + TclHashObjKey, + TclCompareObjKeys, + AllocChainEntry, + TclFreeObjEntry +}; + +/* + * Structure used in implementation of 'dict map' to hold the state that gets + * passed between parts of the implementation. + */ + +typedef struct { + Tcl_Obj *keyVarObj; /* The name of the variable that will have + * keys assigned to it. */ + Tcl_Obj *valueVarObj; /* The name of the variable that will have + * values assigned to it. */ + Tcl_DictSearch search; /* The dictionary search structure. */ + Tcl_Obj *scriptObj; /* The script to evaluate each time through + * the loop. */ + Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the + * results. */ +} DictMapStorage; + +/***** 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 = ckalloc(sizeof(ChainEntry)); + cPtr->entry.key.objPtr = 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, 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, 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; +} /* *---------------------------------------------------------------------- * * DupDictInternalRep -- * - * Initialize the internal representation of a dictionary Tcl_Obj - * to a copy of the internal representation of an existing - * dictionary object. + * Initialize the internal representation of a dictionary Tcl_Obj to a + * copy of the internal representation of an existing dictionary object. * * Results: * None. * * Side effects: - * "srcPtr"s dictionary internal rep pointer should not be NULL and - * we assume it is not NULL. We set "copyPtr"s internal rep to a - * pointer to a newly allocated dictionary rep that, in turn, points - * to "srcPtr"s key and value objects. Those objects are not - * actually copied but are shared between "srcPtr" and "copyPtr". - * The ref count of each key and value object is incremented. + * "srcPtr"s dictionary internal rep pointer should not be NULL and we + * assume it is not NULL. We set "copyPtr"s internal rep to a pointer to + * a newly allocated dictionary rep that, in turn, points to "srcPtr"s + * key and value objects. Those objects are not actually copied but are + * shared between "srcPtr" and "copyPtr". The ref count of each key and + * value object is incremented. * *---------------------------------------------------------------------- */ static void -DupDictInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr, *copyPtr; +DupDictInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { - Dict *oldDict = (Dict *) srcPtr->internalRep.otherValuePtr; - Dict *newDict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - Tcl_Obj *keyPtr, *valuePtr; - int isNew; + Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; + Dict *newDict = ckalloc(sizeof(Dict)); + 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) { + Tcl_Obj *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, valuePtr); Tcl_IncrRefCount(valuePtr); } /* * Initialise other fields. */ + newDict->epoch = 0; newDict->chain = NULL; newDict->refcount = 1; @@ -163,7 +395,8 @@ DupDictInternalRep(srcPtr, copyPtr) /* * Store in the object. */ - copyPtr->internalRep.otherValuePtr = (VOID *) newDict; + + copyPtr->internalRep.twoPtrValue.ptr1 = newDict; copyPtr->typePtr = &tclDictType; } @@ -172,32 +405,30 @@ DupDictInternalRep(srcPtr, copyPtr) * * FreeDictInternalRep -- * - * Deallocate the storage associated with a dictionary object's - * internal representation. + * Deallocate the storage associated with a dictionary object's internal + * representation. * * Results: * None * * Side effects: - * Frees the memory holding the dictionary's internal hash table - * unless it is locked by an iteration going over it. + * Frees the memory holding the dictionary's internal hash table unless + * it is locked by an iteration going over it. * *---------------------------------------------------------------------- - */ static void -FreeDictInternalRep(dictPtr) - Tcl_Obj *dictPtr; +FreeDictInternalRep( + Tcl_Obj *dictPtr) { - Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; - --dict->refcount; + dict->refcount--; if (dict->refcount <= 0) { DeleteDict(dict); } - - dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */ + dictPtr->typePtr = NULL; } /* @@ -205,41 +436,27 @@ FreeDictInternalRep(dictPtr) * * DeleteDict -- * - * Delete the structure that is used to implement a dictionary's - * internal representation. Called when either the dictionary - * object loses its internal representation or when the last - * iteration over the dictionary completes. + * Delete the structure that is used to implement a dictionary's internal + * representation. Called when either the dictionary object loses its + * internal representation or when the last iteration over the dictionary + * completes. * * Results: * None * * Side effects: - * Decrements the reference count of all key and value objects in - * the dictionary, which may free them. + * Decrements the reference count of all key and value objects in the + * dictionary, which may free them. * *---------------------------------------------------------------------- */ static void -DeleteDict(dict) - Dict *dict; +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); - ckfree((char *) dict); + DeleteChainTable(dict); + ckfree(dict); } /* @@ -247,41 +464,50 @@ DeleteDict(dict) * * UpdateStringOfDict -- * - * Update the string representation for a dictionary object. - * Note: This procedure does not invalidate an existing old string - * rep so storage will be lost if this has not already been done. - * This code is based on UpdateStringOfList in tclListObj.c + * Update the string representation for a dictionary object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. This code is based on + * UpdateStringOfList in tclListObj.c * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the dict-to-string conversion. This string will be empty if the - * dictionary has no key/value pairs. The dictionary internal - * representation should not be NULL and we assume it is not NULL. + * The object's string is set to a valid string that results from the + * dict-to-string conversion. This string will be empty if the dictionary + * has no key/value pairs. The dictionary internal representation should + * not be NULL and we assume it is not NULL. * *---------------------------------------------------------------------- */ static void -UpdateStringOfDict(dictPtr) - Tcl_Obj *dictPtr; +UpdateStringOfDict( + Tcl_Obj *dictPtr) { #define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; - Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int numElems, i, length; - char *elem, *dst; + int i, length, bytesNeeded = 0; + const char *elem; + char *dst; + const int maxFlags = UINT_MAX / sizeof(int); /* - * This field is the most useful one in the whole hash structure, - * and it is not exposed by any API function... + * This field is the most useful one in the whole hash structure, and it + * is not exposed by any API function... */ - numElems = dict->table.numEntries * 2; + + int numElems = dict->table.numEntries * 2; + + /* Handle empty list case first, simplifies what follows */ + if (numElems == 0) { + dictPtr->bytes = tclEmptyStringRep; + dictPtr->length = 0; + return; + } /* * Pass 1: estimate space, gather flags. @@ -289,57 +515,63 @@ UpdateStringOfDict(dictPtr) if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; + } else if (numElems > maxFlags) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + flagPtr = ckalloc(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 elements already. + * Assume that cPtr is never NULL since we know the number of array + * elements already. */ - keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); - elem = Tcl_GetStringFromObj(keyPtr, &length); - dictPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i]) + 1; + flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); + keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + elem = TclGetStringFromObj(keyPtr, &length); + bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - elem = Tcl_GetStringFromObj(valuePtr, &length); - dictPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i+1]) + 1; + flagPtr[i+1] = TCL_DONT_QUOTE_HASH; + valuePtr = Tcl_GetHashValue(&cPtr->entry); + elem = TclGetStringFromObj(valuePtr, &length); + bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - dictPtr->bytes = ckalloc((unsigned) dictPtr->length); + dictPtr->length = bytesNeeded - 1; + dictPtr->bytes = ckalloc(bytesNeeded); 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); - elem = Tcl_GetStringFromObj(keyPtr, &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) ); - *(dst++) = ' '; - - valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - elem = Tcl_GetStringFromObj(valuePtr, &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i+1] | TCL_DONT_QUOTE_HASH); - *(dst++) = ' '; + for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { + flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); + keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + elem = TclGetStringFromObj(keyPtr, &length); + dst += TclConvertElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; + + flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; + valuePtr = Tcl_GetHashValue(&cPtr->entry); + elem = TclGetStringFromObj(valuePtr, &length); + dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); + *dst++ = ' '; } + dictPtr->bytes[dictPtr->length] = '\0'; + if (flagPtr != localFlags) { - ckfree((char *) flagPtr); - } - if (dst == dictPtr->bytes) { - *dst = 0; - } else { - *(--dst) = 0; + ckfree(flagPtr); } - dictPtr->length = dst - dictPtr->bytes; } /* @@ -347,11 +579,10 @@ UpdateStringOfDict(dictPtr) * * SetDictFromAny -- * - * Convert a non-dictionary object into a dictionary object. This - * code is very closely related to SetListFromAny in tclListObj.c - * but does not actually guarantee that a dictionary object will - * have a string rep (as conversions from lists are handled with a - * special case.) + * Convert a non-dictionary object into a dictionary object. This code is + * very closely related to SetListFromAny in tclListObj.c but does not + * actually guarantee that a dictionary object will have a string rep (as + * conversions from lists are handled with a special case.) * * Results: * A standard Tcl result. @@ -364,168 +595,117 @@ UpdateStringOfDict(dictPtr) */ static int -SetDictFromAny(interp, objPtr) - Tcl_Interp *interp; - Tcl_Obj *objPtr; +SetDictFromAny( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { - char *string, *s; - 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 Tcl_Obj *keyPtr, *valuePtr; - Dict *dict; Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + int isNew, result; + Dict *dict = ckalloc(sizeof(Dict)); + + InitChainTable(dict); /* * Since lists and dictionaries have very closely-related string - * representations (i.e. the same parsing code) we can safely - * special-case the conversion from lists to dictionaries. + * representations (i.e. the same parsing code) we can safely special-case + * the conversion from lists to dictionaries. */ if (objPtr->typePtr == &tclListType) { int objc, i; Tcl_Obj **objv; - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } + /* Cannot fail, we already know the Tcl_ObjType is "list". */ + TclListObjGetElements(NULL, objPtr, &objc, &objv); if (objc & 1) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("missing value to go with key", -1)); - } - return TCL_ERROR; - } - - /* - * If the list is shared its string rep must not be lost so it - * still is the same list. - */ - - if (Tcl_IsShared(objPtr)) { - (void) Tcl_GetString(objPtr); + goto missingValue; } - /* - * Build the hash of key/value pairs. - */ - dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); 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); + + /* Store key and value in the hash table we're building. */ + hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { - Tcl_Obj *discardedValue = (Tcl_Obj *) 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_Obj *discardedValue = Tcl_GetHashValue(hPtr); - /* - * Share type-setting code with the string-conversion case. - */ - goto installHash; - } - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - limit = (string + length); + /* + * Not really a well-formed dictionary as there are duplicate + * keys, so better get the string rep here so that we can + * convert back. + */ - /* - * Allocate a new HashTable that has objects for keys and objects - * for values. - */ + (void) Tcl_GetString(objPtr); - dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); - for (p = string, lenRemain = length; - lenRemain > 0; - p = nextElem, lenRemain = (limit - nextElem)) { - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - goto errorExit; - } - if (elemStart >= limit) { - break; + TclDecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } + } else { + int length; + const char *nextElem = TclGetStringFromObj(objPtr, &length); + const char *limit = (nextElem + length); - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ + while (nextElem < limit) { + Tcl_Obj *keyPtr, *valuePtr; + const char *elemStart; + int elemSize, literal; - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } - - TclNewObj(keyPtr); - keyPtr->bytes = s; - keyPtr->length = elemSize; - - p = nextElem; - lenRemain = (limit - nextElem); - if (lenRemain <= 0) { - goto missingKey; - } + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + goto errorExit; + } + if (elemStart == limit) { + break; + } + if (nextElem == limit) { + goto missingValue; + } - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - TclDecrRefCount(keyPtr); - goto errorExit; - } - if (elemStart >= limit) { - goto missingKey; - } + if (literal) { + TclNewStringObj(keyPtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(keyPtr); + keyPtr->bytes = ckalloc((unsigned) elemSize + 1); + keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, + keyPtr->bytes); + } - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + TclDecrRefCount(keyPtr); + goto errorExit; + } - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } + if (literal) { + TclNewStringObj(valuePtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(valuePtr); + valuePtr->bytes = ckalloc((unsigned) elemSize + 1); + valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, + valuePtr->bytes); + } - TclNewObj(valuePtr); - valuePtr->bytes = s; - valuePtr->length = elemSize; + /* Store key and value in the hash table we're building. */ + hPtr = CreateChainEntry(dict, keyPtr, &isNew); + if (!isNew) { + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); - /* - * Store key and value in the hash table we're building. - */ - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); - if (!isNew) { - Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - TclDecrRefCount(keyPtr); - TclDecrRefCount(discardedValue); + TclDecrRefCount(keyPtr); + TclDecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, valuePtr); + Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - Tcl_SetHashValue(hPtr, (ClientData) valuePtr); - Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - installHash: /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ @@ -533,25 +713,24 @@ SetDictFromAny(interp, objPtr) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.otherValuePtr = (VOID *) dict; + objPtr->internalRep.twoPtrValue.ptr1 = dict; objPtr->typePtr = &tclDictType; return TCL_OK; - missingKey: + missingValue: if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("missing value to go with key", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value to go with key", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } - 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); + + errorExit: + if (interp != NULL) { + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } - Tcl_DeleteHashTable(&dict->table); - ckfree((char *) dict); + DeleteChainTable(dict); + ckfree(dict); return result; } @@ -560,29 +739,27 @@ SetDictFromAny(interp, objPtr) * * TclTraceDictPath -- * - * Trace through a tree of dictionaries using the array of keys - * given. If the flags argument has the DICT_PATH_UPDATE flag is - * set, a backward-pointing chain of dictionaries is also built - * (in the Dict's chain field) and the chained dictionaries are - * made into unshared dictionaries (if they aren't already.) + * Trace through a tree of dictionaries using the array of keys given. If + * the flags argument has the DICT_PATH_UPDATE flag is set, a + * backward-pointing chain of dictionaries is also built (in the Dict's + * chain field) and the chained dictionaries are made into unshared + * dictionaries (if they aren't already.) * * Results: - * The object at the end of the path, or NULL if there was an - * error. Note that this it is an error for an intermediate - * dictionary on the path to not exist. If the flags argument - * has the DICT_PATH_EXISTS set, a non-existent path gives a - * DICT_PATH_NON_EXISTENT result. + * The object at the end of the path, or NULL if there was an error. Note + * that this it is an error for an intermediate dictionary on the path to + * not exist. If the flags argument has the DICT_PATH_EXISTS set, a + * non-existent path gives a DICT_PATH_NON_EXISTENT result. * * Side effects: - * If the flags argument is zero or DICT_PATH_EXISTS, there are - * no side effects (other than potential conversion of objects to - * dictionaries.) If the flags argument is DICT_PATH_UPDATE, the - * following additional side effects occur. Shared dictionaries - * along the path are converted into unshared objects, and a - * backward-pointing chain is built using the chain fields of the - * dictionaries (for easy invalidation of string representations - * using InvalidateDictChain.) If the flags argument has the - * DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), + * If the flags argument is zero or DICT_PATH_EXISTS, there are no side + * effects (other than potential conversion of objects to dictionaries.) + * If the flags argument is DICT_PATH_UPDATE, the following additional + * side effects occur. Shared dictionaries along the path are converted + * into unshared objects, and a backward-pointing chain is built using + * the chain fields of the dictionaries (for easy invalidation of string + * representations using InvalidateDictChain). If the flags argument has + * the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), * non-existant keys will be inserted with a value of an empty * dictionary, resulting in the path being built. * @@ -590,10 +767,12 @@ SetDictFromAny(interp, objPtr) */ Tcl_Obj * -TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *CONST keyv[]; - int keyc, flags; +TclTraceDictPath( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *const keyv[], + int flags) { Dict *dict, *newDict; int i; @@ -603,25 +782,28 @@ TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) return NULL; } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } for (i=0 ; i<keyc ; i++) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[i]); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]); Tcl_Obj *tmpObj; if (hPtr == NULL) { int isNew; /* Dummy */ + if (flags & DICT_PATH_EXISTS) { return DICT_PATH_NON_EXISTENT; } if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(keyv[i]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(keyv[i]), NULL); } return NULL; } @@ -629,12 +811,13 @@ TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) /* * 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; @@ -642,15 +825,15 @@ TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) } } - newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); tmpObj = Tcl_DuplicateObj(tmpObj); Tcl_IncrRefCount(tmpObj); - Tcl_SetHashValue(hPtr, (ClientData) tmpObj); + Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.twoPtrValue.ptr1; } newDict->chain = dictPtr; @@ -666,36 +849,36 @@ TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) * * InvalidateDictChain -- * - * Go through a dictionary chain (built by an updating invokation - * of TclTraceDictPath) and invalidate the string representations - * of all the dictionaries on the chain. + * Go through a dictionary chain (built by an updating invokation of + * TclTraceDictPath) and invalidate the string representations of all the + * dictionaries on the chain. * * Results: * None * * Side effects: - * String reps are invalidated and epoch counters (for detecting - * illegal concurrent modifications) are updated through the - * chain of updated dictionaries. + * String reps are invalidated and epoch counters (for detecting illegal + * concurrent modifications) are updated through the chain of updated + * dictionaries. * *---------------------------------------------------------------------- */ static void -InvalidateDictChain(dictObj) - Tcl_Obj *dictObj; +InvalidateDictChain( + Tcl_Obj *dictObj) { - Dict *dict = (Dict *) dictObj->internalRep.otherValuePtr; + Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; do { - Tcl_InvalidateStringRep(dictObj); + TclInvalidateStringRep(dictObj); dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = (Dict *) dictObj->internalRep.otherValuePtr; + dict = dictObj->internalRep.twoPtrValue.ptr1; } while (dict != NULL); } @@ -704,48 +887,52 @@ InvalidateDictChain(dictObj) * * Tcl_DictObjPut -- * - * Add a key,value pair to a dictionary, or update the value for a - * key if that key already has a mapping in the dictionary. + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. * * Results: * A standard Tcl result. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one, and any string representation that it has - * is invalidated. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr, *valuePtr; +Tcl_DictObjPut( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr, + Tcl_Obj *valuePtr) { Dict *dict; Tcl_HashEntry *hPtr; int isNew; if (Tcl_IsShared(dictPtr)) { - Tcl_Panic("Tcl_DictObjPut called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { return result; } } if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); + dict = dictPtr->internalRep.twoPtrValue.ptr1; + 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); @@ -758,25 +945,27 @@ Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) * * Tcl_DictObjGet -- * - * Given a key, get its value from the dictionary (or NULL if key - * is not found in dictionary.) + * Given a key, get its value from the dictionary (or NULL if key is not + * found in dictionary.) * * Results: - * A standard Tcl result. The variable pointed to by valuePtrPtr - * is updated with the value for the key. Note that it is not an - * error for the key to have no mapping in the dictionary. + * A standard Tcl result. The variable pointed to by valuePtrPtr is + * updated with the value for the key. Note that it is not an error for + * the key to have no mapping in the dictionary. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one. * *---------------------------------------------------------------------- */ int -Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr, **valuePtrPtr; +Tcl_DictObjGet( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr, + Tcl_Obj **valuePtrPtr) { Dict *dict; Tcl_HashEntry *hPtr; @@ -784,16 +973,17 @@ Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { + *valuePtrPtr = NULL; return result; } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyPtr); + dict = dictPtr->internalRep.twoPtrValue.ptr1; + hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(hPtr); } return TCL_OK; } @@ -803,30 +993,30 @@ Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) * * Tcl_DictObjRemove -- * - * Remove the key,value pair with the given key from the dictionary; - * the key does not need to be present in the dictionary. + * Remove the key,value pair with the given key from the dictionary; the + * key does not need to be present in the dictionary. * * Results: * A standard Tcl result. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one, and any string representation that it has - * is invalidated. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjRemove(interp, dictPtr, keyPtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr; +Tcl_DictObjRemove( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr) { Dict *dict; - Tcl_HashEntry *hPtr; if (Tcl_IsShared(dictPtr)) { - Tcl_Panic("Tcl_DictObjRemove called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } if (dictPtr->typePtr != &tclDictType) { @@ -837,15 +1027,10 @@ Tcl_DictObjRemove(interp, dictPtr, keyPtr) } if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(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.twoPtrValue.ptr1; + if (DeleteChainEntry(dict, keyPtr)) { dict->epoch++; } return TCL_OK; @@ -859,21 +1044,21 @@ Tcl_DictObjRemove(interp, dictPtr, keyPtr) * How many key,value pairs are there in the dictionary? * * Results: - * A standard Tcl result. Updates the variable pointed to by - * sizePtr with the number of key,value pairs in the dictionary. + * A standard Tcl result. Updates the variable pointed to by sizePtr with + * the number of key,value pairs in the dictionary. * * Side effects: - * The dictPtr object is converted to a dictionary type if it is - * not a dictionary already. + * The dictPtr object is converted to a dictionary type if it is not a + * dictionary already. * *---------------------------------------------------------------------- */ int -Tcl_DictObjSize(interp, dictPtr, sizePtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr; - int *sizePtr; +Tcl_DictObjSize( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int *sizePtr) { Dict *dict; @@ -884,7 +1069,7 @@ Tcl_DictObjSize(interp, dictPtr, sizePtr) } } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -894,67 +1079,67 @@ Tcl_DictObjSize(interp, dictPtr, sizePtr) * * Tcl_DictObjFirst -- * - * Start a traversal of the dictionary. Caller must supply the - * search context, pointers for returning key and value, and a - * pointer to allow indication of whether the dictionary has been - * traversed (i.e. the dictionary is empty.) The order of traversal - * is undefined. + * Start a traversal of the dictionary. Caller must supply the search + * context, pointers for returning key and value, and a pointer to allow + * indication of whether the dictionary has been traversed (i.e. the + * dictionary is empty). The order of traversal is undefined. * * Results: - * A standard Tcl result. Updates the variables pointed to by - * keyPtrPtr, valuePtrPtr and donePtr. Either of keyPtrPtr and - * valuePtrPtr may be NULL, in which case the key/value is not made - * available to the caller. + * A standard Tcl result. Updates the variables pointed to by keyPtrPtr, + * valuePtrPtr and donePtr. Either of keyPtrPtr and valuePtrPtr may be + * NULL, in which case the key/value is not made available to the caller. * * Side effects: - * The dictPtr object is converted to a dictionary type if it is - * not a dictionary already. The search context is initialised if - * the search has not finished. The dictionary's internal rep is - * Tcl_Preserve()d if the dictionary has at least one element. + * The dictPtr object is converted to a dictionary type if it is not a + * dictionary already. The search context is initialised if the search + * has not finished. The dictionary's internal rep is Tcl_Preserve()d if + * the dictionary has at least one element. * *---------------------------------------------------------------------- */ int -Tcl_DictObjFirst(interp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr) - Tcl_Interp *interp; /* For error messages, or NULL if no - * error messages desired. */ - Tcl_Obj *dictPtr; /* Dictionary to traverse. */ - Tcl_DictSearch *searchPtr; /* Pointer to a dict search context. */ - Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the - * first key written into, or NULL. */ - Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the - * first value written into, or NULL.*/ - int *donePtr; /* Pointer to a variable which will - * have a 1 written into when there - * are no further values in the - * dictionary, or a 0 otherwise. */ +Tcl_DictObjFirst( + Tcl_Interp *interp, /* For error messages, or NULL if no error + * messages desired. */ + Tcl_Obj *dictPtr, /* Dictionary to traverse. */ + Tcl_DictSearch *searchPtr, /* Pointer to a dict search context. */ + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first + * value written into, or NULL.*/ + int *donePtr) /* Pointer to a variable which will have a 1 + * written into when there are no further + * values in the dictionary, or a 0 + * 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.twoPtrValue.ptr1; + 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_GetHashKey(&dict->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } return TCL_OK; @@ -966,69 +1151,72 @@ Tcl_DictObjFirst(interp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr) * Tcl_DictObjNext -- * * Continue a traversal of a dictionary previously started with - * Tcl_DictObjFirst. This function is safe against concurrent - * modification of the underlying object (including type - * shimmering), treating such situations as if the search has - * terminated, though it is up to the caller to ensure that the - * object itself is not disposed until the search has finished. - * It is _not_ safe against modifications from other threads. + * Tcl_DictObjFirst. This function is safe against concurrent + * modification of the underlying object (including type shimmering), + * treating such situations as if the search has terminated, though it is + * up to the caller to ensure that the object itself is not disposed + * until the search has finished. It is _not_ safe against modifications + * from other threads. * * Results: * Updates the variables pointed to by keyPtrPtr, valuePtrPtr and - * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in - * which case the key/value is not made available to the caller. + * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in which + * case the key/value is not made available to the caller. * * Side effects: - * Removes a reference to the dictionary's internal rep if the - * search terminates. + * Removes a reference to the dictionary's internal rep if the search + * terminates. * *---------------------------------------------------------------------- */ void -Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) - Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ - Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the - * first key written into, or NULL. */ - Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the - * first value written into, or NULL.*/ - int *donePtr; /* Pointer to a variable which will - * have a 1 written into when there - * are no further values in the - * dictionary, or a 0 otherwise. */ +Tcl_DictObjNext( + Tcl_DictSearch *searchPtr, /* Pointer to a hash search context. */ + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first + * value written into, or NULL.*/ + int *donePtr) /* Pointer to a variable which will have a 1 + * written into when there are no further + * values in the dictionary, or a 0 + * otherwise. */ { - Tcl_HashEntry *hPtr; + ChainEntry *cPtr; /* * If the searh is done; we do no work. */ + if (searchPtr->epoch == -1) { *donePtr = 1; return; } /* - * Bail out if the dictionary has had any elements added, modified - * or removed. This *shouldn't* happen, but... + * Bail out if the dictionary has had any elements added, modified or + * removed. This *shouldn't* happen, but... */ + if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) { 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); + *keyPtrPtr = Tcl_GetHashKey( + &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } @@ -1037,11 +1225,10 @@ Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) * * Tcl_DictObjDone -- * - * Call this if you want to stop a search before you reach the - * end of the dictionary (e.g. because of abnormal termination of - * the search.) It should not be used if the search reaches its - * natural end (i.e. if either Tcl_DictObjFirst or Tcl_DictObjNext - * sets its donePtr variable to 1.) + * Call this if you want to stop a search before you reach the end of the + * dictionary (e.g. because of abnormal termination of the search). It + * need not be used if the search reaches its natural end (i.e. if either + * Tcl_DictObjFirst or Tcl_DictObjNext sets its donePtr variable to 1). * * Results: * None. @@ -1053,8 +1240,8 @@ Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) */ void -Tcl_DictObjDone(searchPtr) - Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ +Tcl_DictObjDone( + Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; @@ -1073,36 +1260,38 @@ Tcl_DictObjDone(searchPtr) * * Tcl_DictObjPutKeyList -- * - * Add a key...key,value pair to a dictionary tree. The main - * dictionary value must not be shared, though sub-dictionaries may - * be. All intermediate dictionaries on the path must exist. + * Add a key...key,value pair to a dictionary tree. The main dictionary + * value must not be shared, though sub-dictionaries may be. All + * intermediate dictionaries on the path must exist. * * Results: - * A standard Tcl result. Note that in the error case, a message - * is left in interp unless that is NULL. + * A standard Tcl result. Note that in the error case, a message is left + * in interp unless that is NULL. * * Side effects: - * If the dictionary and any of its sub-dictionaries on the - * path have string representations, these are invalidated. + * If the dictionary and any of its sub-dictionaries on the path have + * string representations, these are invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) - Tcl_Interp *interp; - int keyc; - Tcl_Obj *dictPtr, *CONST keyv[], *valuePtr; +Tcl_DictObjPutKeyList( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *const keyv[], + Tcl_Obj *valuePtr) { Dict *dict; Tcl_HashEntry *hPtr; int isNew; if (Tcl_IsShared(dictPtr)) { - Tcl_Panic("Tcl_DictObjPutKeyList called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList"); } if (keyc < 1) { - Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list"); + Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); @@ -1110,11 +1299,11 @@ Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) return TCL_ERROR; } - dict = (Dict *) dictPtr->internalRep.otherValuePtr; - hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew); + dict = dictPtr->internalRep.twoPtrValue.ptr1; + 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); @@ -1129,36 +1318,36 @@ Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) * Tcl_DictObjRemoveKeyList -- * * Remove a key...key,value pair from a dictionary tree (the value - * removed is implicit in the key path.) The main dictionary value - * must not be shared, though sub-dictionaries may be. It is not - * an error if there is no value associated with the given key list, - * but all intermediate dictionaries on the key path must exist. + * removed is implicit in the key path). The main dictionary value must + * not be shared, though sub-dictionaries may be. It is not an error if + * there is no value associated with the given key list, but all + * intermediate dictionaries on the key path must exist. * * Results: - * A standard Tcl result. Note that in the error case, a message - * is left in interp unless that is NULL. + * A standard Tcl result. Note that in the error case, a message is left + * in interp unless that is NULL. * * Side effects: - * If the dictionary and any of its sub-dictionaries on the key - * path have string representations, these are invalidated. + * If the dictionary and any of its sub-dictionaries on the key path have + * string representations, these are invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) - Tcl_Interp *interp; - int keyc; - Tcl_Obj *dictPtr, *CONST keyv[]; +Tcl_DictObjRemoveKeyList( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *const keyv[]) { Dict *dict; - Tcl_HashEntry *hPtr; if (Tcl_IsShared(dictPtr)) { - Tcl_Panic("Tcl_DictObjRemoveKeyList called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList"); } if (keyc < 1) { - Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list"); + Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); @@ -1166,13 +1355,8 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) 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.twoPtrValue.ptr1; + DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } @@ -1182,17 +1366,17 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) * * Tcl_NewDictObj -- * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new dict object - * without any content. + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new dict object without any + * content. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDictObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewDictObj. * * Results: - * A new dict object is returned; it has no keys defined in it. - * The new object's string representation is left NULL, and the - * ref count of the object is 0. + * A new dict object is returned; it has no keys defined in it. The new + * object's string representation is left NULL, and the ref count of the + * object is 0. * * Side Effects: * None. @@ -1201,22 +1385,23 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) */ Tcl_Obj * -Tcl_NewDictObj() +Tcl_NewDictObj(void) { #ifdef TCL_MEM_DEBUG return Tcl_DbNewDictObj("unknown", 0); #else /* !TCL_MEM_DEBUG */ + Tcl_Obj *dictPtr; Dict *dict; TclNewObj(dictPtr); - Tcl_InvalidateStringRep(dictPtr); - dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + TclInvalidateStringRep(dictPtr); + dict = ckalloc(sizeof(Dict)); + InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1227,21 +1412,21 @@ Tcl_NewDictObj() * * Tcl_DbNewDictObj -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the - * same as the Tcl_NewDictObj procedure above except that it calls + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the same + * as the Tcl_NewDictObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewDictObj. * * Results: - * A new dict object is returned; it has no keys defined in it. - * The new object's string representation is left NULL, and the - * ref count of the object is 0. + * A new dict object is returned; it has no keys defined in it. The new + * object's string representation is left NULL, and the ref count of the + * object is 0. * * Side Effects: * None. @@ -1250,22 +1435,22 @@ Tcl_NewDictObj() */ Tcl_Obj * -Tcl_DbNewDictObj(file, line) - CONST char *file; - int line; +Tcl_DbNewDictObj( + const char *file, + int line) { #ifdef TCL_MEM_DEBUG Tcl_Obj *dictPtr; Dict *dict; TclDbNewObj(dictPtr, file, line); - Tcl_InvalidateStringRep(dictPtr); - dict = (Dict *) ckalloc(sizeof(Dict)); - Tcl_InitObjHashTable(&dict->table); + TclInvalidateStringRep(dictPtr); + dict = ckalloc(sizeof(Dict)); + InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1280,9 +1465,9 @@ Tcl_DbNewDictObj(file, line) * * DictCreateCmd -- * - * This function implements the "dict create" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict create" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1294,26 +1479,28 @@ Tcl_DbNewDictObj(file, line) */ static int -DictCreateCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictCreateCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictObj; int i; /* - * Must have an even number of arguments; note that number of - * preceding arguments (i.e. "dict create" is also even, which - * makes this much easier.) + * Must have an even number of arguments; note that number of preceding + * arguments (i.e. "dict create" is also even, which makes this much + * easier.) */ - if (objc & 1) { - Tcl_WrongNumArgs(interp, 2, objv, "?key value ...?"); + + if ((objc & 1) == 0) { + Tcl_WrongNumArgs(interp, 1, objv, "?key value ...?"); return TCL_ERROR; } dictObj = Tcl_NewDictObj(); - for (i=2 ; i<objc ; i+=2) { + for (i=1 ; i<objc ; i+=2) { /* * The next command is assumed to never fail... */ @@ -1328,9 +1515,9 @@ DictCreateCmd(interp, objc, objv) * * DictGetCmd -- * - * This function implements the "dict get" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict get" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1342,31 +1529,32 @@ DictCreateCmd(interp, objc, objv) */ static int -DictGetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictGetCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr = NULL; int result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?key key ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?"); return TCL_ERROR; } /* - * Test for the special case of no keys, which returns a *list* of - * all key,value pairs. We produce a copy here because that makes - * subsequent list handling more efficient. + * Test for the special case of no keys, which returns a *list* of all + * key,value pairs. We produce a copy here because that makes subsequent + * list handling more efficient. */ - if (objc == 3) { - Tcl_Obj *keyPtr, *listPtr; + if (objc == 2) { + Tcl_Obj *keyPtr = NULL, *listPtr; Tcl_DictSearch search; int done; - result = Tcl_DictObjFirst(interp, objv[2], &search, + result = Tcl_DictObjFirst(interp, objv[1], &search, &keyPtr, &valuePtr, &done); if (result != TCL_OK) { return result; @@ -1374,8 +1562,8 @@ DictGetCmd(interp, objc, objv) listPtr = Tcl_NewListObj(0, NULL); while (!done) { /* - * Assume these won't fail as we have complete control - * over the types of things here. + * Assume these won't fail as we have complete control over the + * types of things here. */ Tcl_ListObjAppendElement(interp, listPtr, keyPtr); @@ -1388,15 +1576,14 @@ DictGetCmd(interp, objc, objv) } /* - * Loop through the list of keys, looking up the key at the - * current index in the current dictionary each time. Once we've - * done the lookup, we set the current dictionary to be the value - * we looked up (in case the value was not the last one and we are - * going through a chain of searches.) Note that this loop always - * executes at least once. + * Loop through the list of keys, looking up the key at the current index + * in the current dictionary each time. Once we've done the lookup, we set + * the current dictionary to be the value we looked up (in case the value + * was not the last one and we are going through a chain of searches.) + * Note that this loop always executes at least once. */ - dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ); + dictPtr = TclTraceDictPath(interp, objv[1], objc-3,objv+2, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } @@ -1405,9 +1592,11 @@ DictGetCmd(interp, objc, objv) return result; } if (valuePtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(objv[objc-1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(objv[objc-1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, valuePtr); @@ -1419,9 +1608,9 @@ DictGetCmd(interp, objc, objv) * * DictReplaceCmd -- * - * This function implements the "dict replace" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict replace" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1433,26 +1622,27 @@ DictGetCmd(interp, objc, objv) */ static int -DictReplaceCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictReplaceCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; int i, result; int allocatedDict = 0; - if ((objc < 3) || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?key value ...?"); + if ((objc < 2) || (objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); return TCL_ERROR; } - dictPtr = objv[2]; + dictPtr = objv[1]; if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocatedDict = 1; } - for (i=3 ; i<objc ; i+=2) { + for (i=2 ; i<objc ; i+=2) { result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]); if (result != TCL_OK) { if (allocatedDict) { @@ -1470,9 +1660,9 @@ DictReplaceCmd(interp, objc, objv) * * DictRemoveCmd -- * - * This function implements the "dict remove" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict remove" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1484,26 +1674,27 @@ DictReplaceCmd(interp, objc, objv) */ static int -DictRemoveCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictRemoveCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; int i, result; int allocatedDict = 0; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?key ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?"); return TCL_ERROR; } - dictPtr = objv[2]; + dictPtr = objv[1]; if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocatedDict = 1; } - for (i=3 ; i<objc ; i++) { + for (i=2 ; i<objc ; i++) { result = Tcl_DictObjRemove(interp, dictPtr, objv[i]); if (result != TCL_OK) { if (allocatedDict) { @@ -1521,9 +1712,9 @@ DictRemoveCmd(interp, objc, objv) * * DictMergeCmd -- * - * This function implements the "dict merge" Tcl command. - * See the user documentation for details on what it does, and - * TIP#163 for the formal specification. + * This function implements the "dict merge" Tcl command. See the user + * documentation for details on what it does, and TIP#163 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1535,34 +1726,42 @@ DictRemoveCmd(interp, objc, objv) */ static int -DictMergeCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictMergeCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - Tcl_Obj *targetObj, *keyObj, *valueObj; + Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL; int allocatedDict = 0; int i, done; Tcl_DictSearch search; - if (objc == 2) { + if (objc == 1) { /* * No dictionary arguments; return default (empty value). */ + return TCL_OK; } - if (objc == 3) { + /* + * Make sure first argument is a dictionary. + */ + + targetObj = objv[1]; + if (targetObj->typePtr != &tclDictType) { + if (SetDictFromAny(interp, targetObj) != TCL_OK) { + return TCL_ERROR; + } + } + + if (objc == 2) { /* - * Single argument, make sure it is a dictionary, but - * otherwise return it. + * Single argument, return it. */ - if (objv[2]->typePtr != &tclDictType) { - if (SetDictFromAny(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, objv[2]); + + Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } @@ -1570,12 +1769,11 @@ DictMergeCmd(interp, objc, objv) * Normal behaviour: combining two (or more) dictionaries. */ - targetObj = objv[2]; if (Tcl_IsShared(targetObj)) { targetObj = Tcl_DuplicateObj(targetObj); allocatedDict = 1; } - for (i=3 ; i<objc ; i++) { + for (i=2 ; i<objc ; i++) { if (Tcl_DictObjFirst(interp, objv[i], &search, &keyObj, &valueObj, &done) != TCL_OK) { if (allocatedDict) { @@ -1584,16 +1782,15 @@ DictMergeCmd(interp, objc, objv) return TCL_ERROR; } while (!done) { - if (Tcl_DictObjPut(interp, targetObj, - keyObj, valueObj) != TCL_OK) { - Tcl_DictObjDone(&search); - if (allocatedDict) { - TclDecrRefCount(targetObj); - } - return TCL_ERROR; - } + /* + * Next line can't fail; already know we have a dictionary in + * targetObj. + */ + + Tcl_DictObjPut(NULL, targetObj, keyObj, valueObj); Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } + Tcl_DictObjDone(&search); } Tcl_SetObjResult(interp, targetObj); return TCL_OK; @@ -1604,9 +1801,9 @@ DictMergeCmd(interp, objc, objv) * * DictKeysCmd -- * - * This function implements the "dict keys" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict keys" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1618,46 +1815,66 @@ DictMergeCmd(interp, objc, objv) */ static int -DictKeysCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictKeysCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - Tcl_Obj *keyPtr, *listPtr; - Tcl_DictSearch search; - int result, done; - char *pattern = NULL; + Tcl_Obj *listPtr; + const char *pattern = NULL; - if (objc!=3 && objc!=4) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?pattern?"); + if (objc!=2 && objc!=3) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?"); return TCL_ERROR; } - result = Tcl_DictObjFirst(interp, objv[2], &search, &keyPtr, NULL, &done); - if (result != TCL_OK) { - return TCL_ERROR; + /* + * A direct check that we have a dictionary. We don't start the iteration + * yet because that might allocate memory or set locks that we do not + * need. [Bug 1705778, leak K04] + */ + + if (objv[1]->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, objv[1]); + + if (result != TCL_OK) { + return result; + } } - if (objc == 4) { - pattern = TclGetString(objv[3]); + + if (objc == 3) { + pattern = TclGetString(objv[2]); } listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { Tcl_Obj *valuePtr = NULL; - Tcl_DictObjGet(interp, objv[2], objv[3], &valuePtr); + + Tcl_DictObjGet(interp, objv[1], objv[2], &valuePtr); if (valuePtr != NULL) { - Tcl_ListObjAppendElement(interp, listPtr, objv[3]); + Tcl_ListObjAppendElement(NULL, listPtr, objv[2]); } - goto searchDone; - } - for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { - if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { - /* - * Assume this operation always succeeds. - */ - Tcl_ListObjAppendElement(interp, listPtr, keyPtr); + } else { + Tcl_DictSearch search; + Tcl_Obj *keyPtr = NULL; + int done = 0; + + /* + * At this point, we know we have a dictionary (or at least something + * that can be represented; it could theoretically have shimmered away + * when the pattern was fetched, but that shouldn't be damaging) so we + * can start the iteration process without checking for failures. + */ + + Tcl_DictObjFirst(NULL, objv[1], &search, &keyPtr, NULL, &done); + for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { + if (!pattern || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { + Tcl_ListObjAppendElement(NULL, listPtr, keyPtr); + } } + Tcl_DictObjDone(&search); } -searchDone: + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1667,9 +1884,9 @@ searchDone: * * DictValuesCmd -- * - * This function implements the "dict values" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict values" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1681,27 +1898,30 @@ searchDone: */ static int -DictValuesCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictValuesCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - Tcl_Obj *valuePtr, *listPtr; + Tcl_Obj *valuePtr = NULL, *listPtr; Tcl_DictSearch search; - int result, done; - char *pattern = NULL; + int done; + const char *pattern; - if (objc!=3 && objc!=4) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?pattern?"); + if (objc!=2 && objc!=3) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?"); return TCL_ERROR; } - result= Tcl_DictObjFirst(interp, objv[2], &search, NULL, &valuePtr, &done); - if (result != TCL_OK) { + if (Tcl_DictObjFirst(interp, objv[1], &search, NULL, &valuePtr, + &done) != TCL_OK) { return TCL_ERROR; } - if (objc == 4) { - pattern = TclGetString(objv[3]); + if (objc == 3) { + pattern = TclGetString(objv[2]); + } else { + pattern = NULL; } listPtr = Tcl_NewListObj(0, NULL); for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { @@ -1709,9 +1929,12 @@ DictValuesCmd(interp, objc, objv) /* * Assume this operation always succeeds. */ + Tcl_ListObjAppendElement(interp, listPtr, valuePtr); } } + Tcl_DictObjDone(&search); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1721,9 +1944,9 @@ DictValuesCmd(interp, objc, objv) * * DictSizeCmd -- * - * This function implements the "dict size" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict size" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1735,18 +1958,19 @@ DictValuesCmd(interp, objc, objv) */ static int -DictSizeCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictSizeCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { int result, size; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); return TCL_ERROR; } - result = Tcl_DictObjSize(interp, objv[2], &size); + result = Tcl_DictObjSize(interp, objv[1], &size); if (result == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); } @@ -1758,9 +1982,9 @@ DictSizeCmd(interp, objc, objv) * * DictExistsCmd -- * - * This function implements the "dict exists" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict exists" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1772,33 +1996,28 @@ DictSizeCmd(interp, objc, objv) */ static int -DictExistsCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictExistsCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr; - int result; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); return TCL_ERROR; } - dictPtr = TclTraceDictPath(interp, objv[2], objc-4, objv+3, + dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, DICT_PATH_EXISTS); - if (dictPtr == NULL) { - return TCL_ERROR; - } - if (dictPtr == DICT_PATH_NON_EXISTENT) { + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT + || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], + &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; - } - result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr); - if (result != TCL_OK) { - return result; + } else { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); return TCL_OK; } @@ -1807,9 +2026,9 @@ DictExistsCmd(interp, objc, objv) * * DictInfoCmd -- * - * This function implements the "dict info" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict info" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1821,31 +2040,33 @@ DictExistsCmd(interp, objc, objv) */ static int -DictInfoCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictInfoCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; Dict *dict; + char *statsStr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); return TCL_ERROR; } - dictPtr = objv[2]; + dictPtr = objv[1]; if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } - dict = (Dict *)dictPtr->internalRep.otherValuePtr; - /* - * This next cast is actually OK. - */ - Tcl_SetResult(interp, (char *)Tcl_HashStats(&dict->table), TCL_DYNAMIC); + dict = dictPtr->internalRep.twoPtrValue.ptr1; + + statsStr = Tcl_HashStats(&dict->table); + Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); + ckfree(statsStr); return TCL_OK; } @@ -1854,9 +2075,9 @@ DictInfoCmd(interp, objc, objv) * * DictIncrCmd -- * - * This function implements the "dict incr" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict incr" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1868,178 +2089,106 @@ DictInfoCmd(interp, objc, objv) */ static int -DictIncrCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictIncrCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int result, isWide = 0; - long incrValue = 1; - Tcl_WideInt wideIncrValue = 0; - int allocatedDict = 0; + int code = TCL_OK; + Tcl_Obj *dictPtr, *valuePtr = NULL; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?"); + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?"); return TCL_ERROR; } - if (objc == 5) { - if (objv[4]->typePtr == &tclIntType) { - incrValue = objv[4]->internalRep.longValue; - } else if (objv[4]->typePtr == &tclWideIntType) { - wideIncrValue = objv[4]->internalRep.wideValue; - isWide = 1; - } else { - result = Tcl_GetWideIntFromObj(interp, objv[4], &wideIncrValue); - if (result != TCL_OK) { - return result; - } - if (wideIncrValue <= Tcl_LongAsWide(LONG_MAX) - && wideIncrValue >= Tcl_LongAsWide(LONG_MIN)) { - incrValue = Tcl_WideAsLong(wideIncrValue); - objv[4]->typePtr = &tclIntType; - } else { - isWide = 1; - } - } - } - - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { - allocatedDict = 1; + /* + * Variable didn't yet exist. Create new dictionary value. + */ + dictPtr = Tcl_NewDictObj(); - if (isWide) { - valuePtr = Tcl_NewWideIntObj(wideIncrValue); + } else if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) { + /* + * Variable contents are not a dict, report error. + */ + + return TCL_ERROR; + } + if (Tcl_IsShared(dictPtr)) { + /* + * A little internals surgery to avoid copying a string rep that will + * soon be no good. + */ + + char *saved = dictPtr->bytes; + Tcl_Obj *oldPtr = dictPtr; + + dictPtr->bytes = NULL; + dictPtr = Tcl_DuplicateObj(dictPtr); + oldPtr->bytes = saved; + } + if (valuePtr == NULL) { + /* + * Key not in dictionary. Create new key with increment as value. + */ + + if (objc == 4) { + /* + * Verify increment is an integer. + */ + + mp_int increment; + + code = Tcl_GetBignumFromObj(interp, objv[3], &increment); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + } else { + /* + * Remember to dispose with the bignum as we're not actually + * using it directly. [Bug 2874678] + */ + + mp_clear(&increment); + Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); + } } else { - valuePtr = Tcl_NewLongObj(incrValue); + Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); } - Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); } else { - long lValue; - Tcl_WideInt wValue; + /* + * Key in dictionary. Increment its value with minimum dup. + */ - if (Tcl_IsShared(dictPtr)) { - allocatedDict = 1; - dictPtr = Tcl_DuplicateObj(dictPtr); + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); } + if (objc == 4) { + code = TclIncrObj(interp, valuePtr, objv[3]); + } else { + Tcl_Obj *incrPtr = Tcl_NewIntObj(1); - if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return TCL_ERROR; + Tcl_IncrRefCount(incrPtr); + code = TclIncrObj(interp, valuePtr, incrPtr); + Tcl_DecrRefCount(incrPtr); } + } + if (code == TCL_OK) { + TclInvalidateStringRep(dictPtr); + valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, + dictPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - if (isWide) { - valuePtr = Tcl_NewWideIntObj(wideIncrValue); - } else { - valuePtr = Tcl_NewLongObj(incrValue); - } - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_GetWideIntFromObj(NULL, valuePtr, &wValue); - if (Tcl_IsShared(valuePtr)) { - if (isWide) { - valuePtr = Tcl_NewWideIntObj(wValue + wideIncrValue); - } else { - valuePtr = Tcl_NewWideIntObj(wValue + incrValue); - } - } else { - if (isWide) { - Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue); - } else { - Tcl_SetWideIntObj(valuePtr, wValue + incrValue); - } - if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); - } - goto valueAlreadyInDictionary; - } - } else if (valuePtr->typePtr == &tclIntType) { - Tcl_GetLongFromObj(NULL, valuePtr, &lValue); - if (Tcl_IsShared(valuePtr)) { - if (isWide) { - valuePtr = Tcl_NewWideIntObj(lValue + wideIncrValue); - } else { - valuePtr = Tcl_NewLongObj(lValue + incrValue); - } - } else { - if (isWide) { - Tcl_SetWideIntObj(valuePtr, lValue + wideIncrValue); - } else { - Tcl_SetLongObj(valuePtr, lValue + incrValue); - } - if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); - } - goto valueAlreadyInDictionary; - } + code = TCL_ERROR; } else { - /* - * Note that these operations on wide ints should work - * fine where they are the same as normal longs, though - * the compiler might complain about trivially satisifed - * tests. - */ - result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue); - if (result != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return result; - } - /* - * Determine if we should have got a standard long instead. - */ - if (Tcl_IsShared(valuePtr)) { - if (isWide) { - valuePtr = Tcl_NewWideIntObj(wValue + wideIncrValue); - } else if (wValue >= LONG_MIN && wValue <= LONG_MAX) { - /* - * Convert the type... - */ - Tcl_GetLongFromObj(NULL, valuePtr, &lValue); - valuePtr = Tcl_NewLongObj(lValue + incrValue); - } else { - valuePtr = Tcl_NewWideIntObj(wValue + incrValue); - } - } else { - if (isWide) { - Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue); - } else if (wValue >= LONG_MIN && wValue <= LONG_MAX) { - Tcl_SetLongObj(valuePtr, - Tcl_WideAsLong(wValue) + incrValue); - } else { - Tcl_SetWideIntObj(valuePtr, wValue + incrValue); - } - if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); - } - goto valueAlreadyInDictionary; - } - } - if (Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr) != TCL_OK) { - /* - * This shouldn't happen since dictPtr is known - * from above to be a valid dictionary. - */ - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - TclDecrRefCount(valuePtr); - return TCL_ERROR; + Tcl_SetObjResult(interp, valuePtr); } + } else if (dictPtr->refCount == 0) { + Tcl_DecrRefCount(dictPtr); } - valueAlreadyInDictionary: - Tcl_IncrRefCount(dictPtr); - resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, - TCL_LEAVE_ERR_MSG); - TclDecrRefCount(dictPtr); - if (resultPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return code; } /* @@ -2047,9 +2196,9 @@ DictIncrCmd(interp, objc, objv) * * DictLappendCmd -- * - * This function implements the "dict lappend" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict lappend" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2061,20 +2210,21 @@ DictIncrCmd(interp, objc, objv) */ static int -DictLappendCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictLappendCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0, allocatedValue = 0; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "varName key ?value ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); return TCL_ERROR; } - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { allocatedDict = 1; dictPtr = Tcl_NewDictObj(); @@ -2083,7 +2233,7 @@ DictLappendCmd(interp, objc, objv) dictPtr = Tcl_DuplicateObj(dictPtr); } - if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) { if (allocatedDict) { TclDecrRefCount(dictPtr); } @@ -2091,7 +2241,7 @@ DictLappendCmd(interp, objc, objv) } if (valuePtr == NULL) { - valuePtr = Tcl_NewListObj(objc-4, objv+4); + valuePtr = Tcl_NewListObj(objc-3, objv+3); allocatedValue = 1; } else { if (Tcl_IsShared(valuePtr)) { @@ -2099,7 +2249,7 @@ DictLappendCmd(interp, objc, objv) valuePtr = Tcl_DuplicateObj(valuePtr); } - for (i=4 ; i<objc ; i++) { + for (i=3 ; i<objc ; i++) { if (Tcl_ListObjAppendElement(interp, valuePtr, objv[i]) != TCL_OK) { if (allocatedValue) { @@ -2114,15 +2264,13 @@ DictLappendCmd(interp, objc, objv) } if (allocatedValue) { - Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); + Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - Tcl_IncrRefCount(dictPtr); - resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); - TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } @@ -2135,9 +2283,9 @@ DictLappendCmd(interp, objc, objv) * * DictAppendCmd -- * - * This function implements the "dict append" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict append" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2149,20 +2297,21 @@ DictLappendCmd(interp, objc, objv) */ static int -DictAppendCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictAppendCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "varName key ?value ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); return TCL_ERROR; } - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { allocatedDict = 1; dictPtr = Tcl_NewDictObj(); @@ -2171,7 +2320,7 @@ DictAppendCmd(interp, objc, objv) dictPtr = Tcl_DuplicateObj(dictPtr); } - if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) { if (allocatedDict) { TclDecrRefCount(dictPtr); } @@ -2186,16 +2335,14 @@ DictAppendCmd(interp, objc, objv) } } - for (i=4 ; i<objc ; i++) { + for (i=3 ; i<objc ; i++) { Tcl_AppendObjToObj(valuePtr, objv[i]); } - Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); + Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); - Tcl_IncrRefCount(dictPtr); - resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); - TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } @@ -2206,11 +2353,11 @@ DictAppendCmd(interp, objc, objv) /* *---------------------------------------------------------------------- * - * DictForCmd -- + * DictForNRCmd -- * - * This function implements the "dict for" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * These functions implement the "dict for" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2222,23 +2369,29 @@ DictAppendCmd(interp, objc, objv) */ static int -DictForCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictForNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { + Interp *iPtr = (Interp *) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; - Tcl_DictSearch search; - int varc, done, result; + Tcl_DictSearch *searchPtr; + int varc, done; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "{keyVar valueVar} dictionary script"); return TCL_ERROR; } - if (Tcl_ListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) { + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2246,78 +2399,357 @@ DictForCmd(interp, objc, objv) "must have exactly two variable names", -1)); return TCL_ERROR; } + searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); + if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, + &done) != TCL_OK) { + TclStackFree(interp, searchPtr); + return TCL_ERROR; + } + if (done) { + TclStackFree(interp, searchPtr); + return TCL_OK; + } + TclListObjGetElements(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; - scriptObj = objv[4]; + scriptObj = objv[3]; + /* * Make sure that these objects (which we need throughout the body of the - * loop) don't vanish. Note that the dictionary internal rep is locked + * loop) don't vanish. Note that the dictionary internal rep is locked * internally so that updates, shimmering, etc are not a problem. */ + Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); - result = Tcl_DictObjFirst(interp, objv[3], - &search, &keyObj, &valueObj, &done); - if (result != TCL_OK) { - goto doneFor; - } + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ - while (!done) { - /* - * Stop the value from getting hit in any way by any traces on - * the key variable. - */ - Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", (char *) NULL); - TclDecrRefCount(valueObj); - result = TCL_ERROR; - goto doneFor; - } + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { + goto error; + } + TclDecrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + goto error; + } + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + valueVarObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything on error. + */ + + error: + TclDecrRefCount(keyVarObj); + TclDecrRefCount(valueVarObj); + TclDecrRefCount(scriptObj); + Tcl_DictObjDone(searchPtr); + TclStackFree(interp, searchPtr); + return TCL_ERROR; +} + +static int +DictForLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_DictSearch *searchPtr = data[0]; + Tcl_Obj *keyVarObj = data[1]; + Tcl_Obj *valueVarObj = data[2]; + Tcl_Obj *scriptObj = data[3]; + Tcl_Obj *keyObj, *valueObj; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", (char *) NULL); - result = TCL_ERROR; - goto doneFor; + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict for\" body line %d)", + Tcl_GetErrorLine(interp))); } + goto done; + } - result = Tcl_EvalObjEx(interp, scriptObj, 0); - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result != TCL_OK) { - if (result == TCL_BREAK) { - result = TCL_OK; - } else if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; + /* + * Get the next mapping from the dictionary. + */ - sprintf(msg, "\n (\"dict for\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - break; - } + Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done); + if (done) { + Tcl_ResetResult(interp); + goto done; + } + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ - Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + TclDecrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; } - doneFor: /* - * Stop holding a reference to these objects. + * Run the script. + */ + + TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + valueVarObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. */ + + done: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); + Tcl_DictObjDone(searchPtr); + TclStackFree(interp, searchPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DictMapNRCmd -- + * + * These functions implement the "dict map" Tcl command. See the user + * documentation for details on what it does, and TIP#405 for the formal + * specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - Tcl_DictObjDone(&search); - if (result == TCL_OK) { - Tcl_ResetResult(interp); +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj **varv, *keyObj, *valueObj; + DictMapStorage *storagePtr; + int varc, done; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVar valueVar} dictionary script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); + return TCL_ERROR; + } + storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, + &valueObj, &done) != TCL_OK) { + TclStackFree(interp, storagePtr); + return TCL_ERROR; + } + if (done) { + /* + * Note that this exit leaves an empty value in the result (due to + * command calling conventions) but that is OK since an empty value is + * an empty dictionary. + */ + + TclStackFree(interp, storagePtr); + return TCL_OK; + } + TclNewObj(storagePtr->accumulatorObj); + TclListObjGetElements(NULL, objv[1], &varc, &varv); + storagePtr->keyVarObj = varv[0]; + storagePtr->valueVarObj = varv[1]; + storagePtr->scriptObj = objv[3]; + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. Note that the dictionary internal rep is locked + * internally so that updates, shimmering, etc are not a problem. + */ + + Tcl_IncrRefCount(storagePtr->accumulatorObj); + Tcl_IncrRefCount(storagePtr->keyVarObj); + Tcl_IncrRefCount(storagePtr->valueVarObj); + Tcl_IncrRefCount(storagePtr->scriptObj); + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything on error. + */ + + error: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return TCL_ERROR; +} + +static int +DictMapLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + DictMapStorage *storagePtr = data[0]; + Tcl_Obj *keyObj, *valueObj; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict map\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto done; + } else { + keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL, + TCL_LEAVE_ERR_MSG); + if (keyObj == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj, + Tcl_GetObjResult(interp)); } + + /* + * Get the next mapping from the dictionary. + */ + + Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); + if (done) { + Tcl_SetObjResult(interp, storagePtr->accumulatorObj); + goto done; + } + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + done: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); return result; } @@ -2326,9 +2758,9 @@ DictForCmd(interp, objc, objv) * * DictSetCmd -- * - * This function implements the "dict set" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict set" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2340,20 +2772,21 @@ DictForCmd(interp, objc, objv) */ static int -DictSetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictSetCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; - if (objc < 5) { - Tcl_WrongNumArgs(interp, 2, objv, "varName key ?key ...? value"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value"); return TCL_ERROR; } - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { allocatedDict = 1; dictPtr = Tcl_NewDictObj(); @@ -2362,7 +2795,7 @@ DictSetCmd(interp, objc, objv) dictPtr = Tcl_DuplicateObj(dictPtr); } - result = Tcl_DictObjPutKeyList(interp, dictPtr, objc-4, objv+3, + result = Tcl_DictObjPutKeyList(interp, dictPtr, objc-3, objv+2, objv[objc-1]); if (result != TCL_OK) { if (allocatedDict) { @@ -2371,10 +2804,8 @@ DictSetCmd(interp, objc, objv) return TCL_ERROR; } - Tcl_IncrRefCount(dictPtr); - resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); - TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } @@ -2387,9 +2818,9 @@ DictSetCmd(interp, objc, objv) * * DictUnsetCmd -- * - * This function implements the "dict unset" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict unset" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2401,20 +2832,21 @@ DictSetCmd(interp, objc, objv) */ static int -DictUnsetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictUnsetCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "varName key ?key ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?"); return TCL_ERROR; } - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { allocatedDict = 1; dictPtr = Tcl_NewDictObj(); @@ -2423,7 +2855,7 @@ DictUnsetCmd(interp, objc, objv) dictPtr = Tcl_DuplicateObj(dictPtr); } - result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-3, objv+3); + result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-2, objv+2); if (result != TCL_OK) { if (allocatedDict) { TclDecrRefCount(dictPtr); @@ -2431,10 +2863,8 @@ DictUnsetCmd(interp, objc, objv) return TCL_ERROR; } - Tcl_IncrRefCount(dictPtr); - resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); - TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } @@ -2447,9 +2877,9 @@ DictUnsetCmd(interp, objc, objv) * * DictFilterCmd -- * - * This function implements the "dict filter" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict filter" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2461,58 +2891,90 @@ DictUnsetCmd(interp, objc, objv) */ static int -DictFilterCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictFilterCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - static CONST char *filters[] = { + Interp *iPtr = (Interp *) interp; + static const char *const filters[] = { "key", "script", "value", NULL }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES }; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; - Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; + Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; int index, varc, done, result, satisfied; - char *pattern; - char msg[32 + TCL_INTEGER_SPACE]; + const char *pattern; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ..."); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType", + if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum FilterTypes) index) { case FILTER_KEYS: - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary key globPattern"); - return TCL_ERROR; - } - /* * Create a dictionary whose keys all match a certain pattern. */ - if (Tcl_DictObjFirst(interp, objv[2], &search, + + if (Tcl_DictObjFirst(interp, objv[1], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } - pattern = TclGetString(objv[4]); - resultObj = Tcl_NewDictObj(); - if (TclMatchIsTrivial(pattern)) { - Tcl_DictObjGet(interp, objv[2], objv[4], &valueObj); - if (valueObj != NULL) { - Tcl_DictObjPut(interp, resultObj, objv[4], valueObj); + if (objc == 3) { + /* + * Nothing to match, so return nothing (== empty dictionary). + */ + + Tcl_DictObjDone(&search); + return TCL_OK; + } else if (objc == 4) { + pattern = TclGetString(objv[3]); + resultObj = Tcl_NewDictObj(); + if (TclMatchIsTrivial(pattern)) { + /* + * Must release the search lock here to prevent a memory leak + * since we are not exhausing the search. [Bug 1705778, leak + * K05] + */ + + Tcl_DictObjDone(&search); + Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj); + if (valueObj != NULL) { + Tcl_DictObjPut(interp, resultObj, objv[3], valueObj); + } + } else { + while (!done) { + if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } } } else { + /* + * Can't optimize this match for trivial globbing: would disturb + * order. + */ + + resultObj = Tcl_NewDictObj(); while (!done) { - if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + int i; + + for (i=3 ; i<objc ; i++) { + pattern = TclGetString(objv[i]); + if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + break; /* stop inner loop */ + } } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } @@ -2521,23 +2983,24 @@ DictFilterCmd(interp, objc, objv) return TCL_OK; case FILTER_VALUES: - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "dictionary value globPattern"); - return TCL_ERROR; - } - /* * Create a dictionary whose values all match a certain pattern. */ - if (Tcl_DictObjFirst(interp, objv[2], &search, + + if (Tcl_DictObjFirst(interp, objv[1], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } - pattern = TclGetString(objv[4]); resultObj = Tcl_NewDictObj(); while (!done) { - if (Tcl_StringMatch(TclGetString(valueObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + int i; + + for (i=3 ; i<objc ; i++) { + pattern = TclGetString(objv[i]); + if (Tcl_StringMatch(TclGetString(valueObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + break; /* stop inner loop */ + } } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } @@ -2545,20 +3008,19 @@ DictFilterCmd(interp, objc, objv) return TCL_OK; case FILTER_SCRIPT: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary script {keyVar valueVar} filterScript"); return TCL_ERROR; } /* - * Create a dictionary whose key,value pairs all satisfy a - * script (i.e. get a true boolean result from its - * evaluation.) Massive copying from the "dict for" - * implementation has occurred! + * Create a dictionary whose key,value pairs all satisfy a script + * (i.e. get a true boolean result from its evaluation). Massive + * copying from the "dict for" implementation has occurred! */ - if (Tcl_ListObjGetElements(interp, objv[4], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2568,18 +3030,20 @@ DictFilterCmd(interp, objc, objv) } keyVarObj = varv[0]; valueVarObj = varv[1]; - scriptObj = objv[5]; + scriptObj = objv[4]; + /* * Make sure that these objects (which we need throughout the body of - * the loop) don't vanish. Note that the dictionary internal rep is + * the loop) don't vanish. Note that the dictionary internal rep is * locked internally so that updates, shimmering, etc are not a * problem. */ + Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); - result = Tcl_DictObjFirst(interp, objv[2], + result = Tcl_DictObjFirst(interp, objv[1], &search, &keyObj, &valueObj, &done); if (result != TCL_OK) { TclDecrRefCount(keyVarObj); @@ -2592,28 +3056,36 @@ DictFilterCmd(interp, objc, objv) while (!done) { /* - * Stop the value from getting hit in any way by any - * traces on the key variable. + * Stop the value from getting hit in any way by any traces on the + * key variable. */ + Tcl_IncrRefCount(keyObj); Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set key variable: \"%s\"", + TclGetString(keyVarObj))); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set value variable: \"%s\"", + TclGetString(valueVarObj))); + result = TCL_ERROR; goto abnormalResult; } - result = Tcl_EvalObjEx(interp, scriptObj, 0); + /* + * TIP #280. Make invoking context available to loop body. + */ + + result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4); switch (result) { case TCL_OK: boolObj = Tcl_GetObjResult(interp); @@ -2636,15 +3108,16 @@ DictFilterCmd(interp, objc, objv) * makes the next Tcl_DictObjNext say there is nothing more to * do. */ + Tcl_ResetResult(interp); Tcl_DictObjDone(&search); case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: - sprintf(msg, "\n (\"dict filter\" script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict filter\" script line %d)", + Tcl_GetErrorLine(interp))); default: goto abnormalResult; } @@ -2658,6 +3131,7 @@ DictFilterCmd(interp, objc, objv) /* * Stop holding a reference to these objects. */ + TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); @@ -2669,6 +3143,7 @@ DictFilterCmd(interp, objc, objv) TclDecrRefCount(resultObj); } return result; + abnormalResult: Tcl_DictObjDone(&search); TclDecrRefCount(keyObj); @@ -2689,9 +3164,9 @@ DictFilterCmd(interp, objc, objv) * * DictUpdateCmd -- * - * This function implements the "dict update" Tcl command. - * See the user documentation for details on what it does, and - * TIP#212 for the formal specification. + * This function implements the "dict update" Tcl command. See the user + * documentation for details on what it does, and TIP#212 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2703,22 +3178,23 @@ DictFilterCmd(interp, objc, objv) */ static int -DictUpdateCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictUpdateCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { + Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; - int i, result, dummy, allocdict = 0; - Tcl_InterpState state; + int i, dummy; - if (objc < 6 || objc & 1) { - Tcl_WrongNumArgs(interp, 2, objv, + if (objc < 5 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "varName key varName ?key varName ...? script"); return TCL_ERROR; } - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { return TCL_ERROR; } @@ -2726,7 +3202,7 @@ DictUpdateCmd(interp, objc, objv) return TCL_ERROR; } Tcl_IncrRefCount(dictPtr); - for (i=3 ; i+2<objc ; i+=2) { + for (i=2 ; i+2<objc ; i+=2) { if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) { TclDecrRefCount(dictPtr); return TCL_ERROR; @@ -2743,21 +3219,46 @@ DictUpdateCmd(interp, objc, objv) TclDecrRefCount(dictPtr); /* - * Execute the body. + * Execute the body after setting up the NRE handler to process the + * results. + */ + + objPtr = Tcl_NewListObj(objc-3, objv+2); + Tcl_IncrRefCount(objPtr); + Tcl_IncrRefCount(objv[1]); + TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL); + + return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); +} + +static int +FinalizeDictUpdate( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *dictPtr, *objPtr, **objv; + Tcl_InterpState state; + int i, objc; + Tcl_Obj *varName = data[0]; + Tcl_Obj *argsObj = data[1]; + + /* + * ErrorInfo handling. */ - result = Tcl_EvalObj(interp, objv[objc-1]); if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")"); } /* - * If the dictionary variable doesn't exist, drop everything - * silently. + * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); if (dictPtr == NULL) { + TclDecrRefCount(varName); + TclDecrRefCount(argsObj); return result; } @@ -2766,44 +3267,54 @@ DictUpdateCmd(interp, objc, objv) */ state = Tcl_SaveInterpState(interp, result); - if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) { + if (Tcl_DictObjSize(interp, dictPtr, &objc) != TCL_OK) { Tcl_DiscardInterpState(state); + TclDecrRefCount(varName); + TclDecrRefCount(argsObj); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); - allocdict = 1; } /* - * Write back the values from the variables, treating failure to - * read as an instruction to remove the key. + * Write back the values from the variables, treating failure to read as + * an instruction to remove the key. */ - for (i=3 ; i+2<objc ; i+=2) { + Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); + for (i=0 ; i<objc ; i+=2) { objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0); if (objPtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, objv[i]); + } else if (objPtr == dictPtr) { + /* + * Someone is messing us around, trying to build a recursive + * structure. [Bug 1786481] + */ + + Tcl_DictObjPut(interp, dictPtr, objv[i], + Tcl_DuplicateObj(objPtr)); } else { /* Shouldn't fail */ Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr); } } + TclDecrRefCount(argsObj); /* * Write the dictionary back to its variable. */ - if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DiscardInterpState(state); - if (allocdict) { - TclDecrRefCount(dictPtr); - } + TclDecrRefCount(varName); return TCL_ERROR; } + TclDecrRefCount(varName); return Tcl_RestoreInterpState(interp, state); } @@ -2812,9 +3323,9 @@ DictUpdateCmd(interp, objc, objv) * * DictWithCmd -- * - * This function implements the "dict with" Tcl command. - * See the user documentation for details on what it does, and - * TIP#212 for the formal specification. + * This function implements the "dict with" Tcl command. See the user + * documentation for details on what it does, and TIP#212 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2826,18 +3337,17 @@ DictUpdateCmd(interp, objc, objv) */ static int -DictWithCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictWithCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr; - Tcl_DictSearch s; - Tcl_InterpState state; - int done, result, keyc, i, allocdict=0; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *dictPtr, *keysPtr, *pathPtr; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "dictVar ?key ...? script"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); return TCL_ERROR; } @@ -2845,32 +3355,146 @@ DictWithCmd(interp, objc, objv) * Get the dictionary to open out. */ - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { return TCL_ERROR; } - if (objc > 4) { - dictPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, + + keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2); + if (keysPtr == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(keysPtr); + + /* + * Execute the body, while making the invoking context available to the + * loop body (TIP#280) and postponing the cleanup until later (NRE). + */ + + pathPtr = NULL; + if (objc > 3) { + pathPtr = Tcl_NewListObj(objc-3, objv+2); + Tcl_IncrRefCount(pathPtr); + } + Tcl_IncrRefCount(objv[1]); + TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr, + NULL); + + return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); +} + +static int +FinalizeDictWith( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **pathv; + int pathc; + Tcl_InterpState state; + Tcl_Obj *varName = data[0]; + Tcl_Obj *keysPtr = data[1]; + Tcl_Obj *pathPtr = data[2]; + Var *varPtr, *arrayPtr; + + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); + } + + /* + * Save the result state; TDWF doesn't guarantee to not modify that on + * TCL_OK result. + */ + + state = Tcl_SaveInterpState(interp, result); + if (pathPtr != NULL) { + Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); + } else { + pathc = 0; + pathv = NULL; + } + + /* + * Pack from local variables back into the dictionary. + */ + + varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + result = TCL_ERROR; + } else { + result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1, + pathc, pathv, keysPtr); + } + + /* + * Tidy up and return the real result (unless we had an error). + */ + + TclDecrRefCount(varName); + TclDecrRefCount(keysPtr); + if (pathPtr != NULL) { + TclDecrRefCount(pathPtr); + } + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + return TCL_ERROR; + } + return Tcl_RestoreInterpState(interp, state); +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithInit -- + * + * Part of the core of [dict with]. Pokes into a dictionary and converts + * the mappings there into assignments to (presumably) local variables. + * Returns a list of all the names that were mapped so that removal of + * either the variable or the dictionary entry won't surprise us when we + * come to stuffing everything back. + * + * Result: + * List of mapped names, or NULL if there was an error. + * + * Side effects: + * Assigns to variables, so potentially legion due to traces. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDictWithInit( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int pathc, + Tcl_Obj *const pathv[]) +{ + Tcl_DictSearch s; + Tcl_Obj *keyPtr, *valPtr, *keysPtr; + int done; + + if (pathc > 0) { + dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_READ); if (dictPtr == NULL) { - return TCL_ERROR; + return NULL; } } /* - * Go over the list of keys and write each corresponding value to - * a variable in the current context with the same name. Also - * keep a copy of the keys so we can write back properly later on - * even if the dictionary has been structurally modified. + * Go over the list of keys and write each corresponding value to a + * variable in the current context with the same name. Also keep a copy of + * the keys so we can write back properly later on even if the dictionary + * has been structurally modified. */ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, &done) != TCL_OK) { - return TCL_ERROR; + return NULL; } TclNewObj(keysPtr); - Tcl_IncrRefCount(keysPtr); for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); @@ -2878,72 +3502,109 @@ DictWithCmd(interp, objc, objv) TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(keysPtr); Tcl_DictObjDone(&s); - return TCL_ERROR; + return NULL; } } - /* - * Execute the body. - */ + return keysPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithFinish -- + * + * Part of the core of [dict with]. Reassembles the piece of the dict (in + * varName, location given by pathc/pathv) from the variables named in + * the keysPtr argument. NB, does not try to preserve errors or manage + * argument lifetimes. + * + * Result: + * TCL_OK if we succeeded, or TCL_ERROR if we failed. + * + * Side effects: + * Assigns to a variable, so potentially legion due to traces. Updates + * the dictionary in the named variable. + * + *---------------------------------------------------------------------- + */ - result = Tcl_EvalObjEx(interp, objv[objc-1], 0); - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); - } +int +TclDictWithFinish( + Tcl_Interp *interp, /* Command interpreter in which variable + * exists. Used for state management, traces + * and error reporting. */ + Var *varPtr, /* Reference to the variable holding the + * dictionary. */ + Var *arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. NULL if the 'index' + * parameter is >= 0 */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + int index, /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ + int pathc, /* The number of elements in the path into the + * dictionary. */ + Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */ + Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is + * the result value from TclDictWithInit. */ +{ + Tcl_Obj *dictPtr, *leafPtr, *valPtr; + int i, allocdict, keyc; + Tcl_Obj **keyv; /* - * If the dictionary variable doesn't exist, drop everything - * silently. + * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, index); if (dictPtr == NULL) { - TclDecrRefCount(keysPtr); - return result; + return TCL_OK; } /* * Double-check that it is still a dictionary. */ - state = Tcl_SaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { - TclDecrRefCount(keysPtr); - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocdict = 1; + } else { + allocdict = 0; } - if (objc > 4) { + if (pathc > 0) { /* - * Want to get to the dictionary which we will update; need to - * do prepare-for-update de-sharing along the path *but* avoid - * generating an error on a non-existant path (we'll treat - * that the same as a non-existant variable. Luckily, the - * de-sharing operation isn't deeply damaging if we don't go - * on to update; it's just less than perfectly efficient (but - * no memory should be leaked). + * Want to get to the dictionary which we will update; need to do + * prepare-for-update de-sharing along the path *but* avoid generating + * an error on a non-existant path (we'll treat that the same as a + * non-existant variable. Luckily, the de-sharing operation isn't + * deeply damaging if we don't go on to update; it's just less than + * perfectly efficient (but no memory should be leaked). */ - leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, + + leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_EXISTS | DICT_PATH_UPDATE); if (leafPtr == NULL) { - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } } else { leafPtr = dictPtr; @@ -2953,23 +3614,29 @@ DictWithCmd(interp, objc, objv) * Now process our updates on the leaf dictionary. */ - Tcl_ListObjGetElements(NULL, keysPtr, &keyc, &keyv); + TclListObjGetElements(NULL, keysPtr, &keyc, &keyv); for (i=0 ; i<keyc ; i++) { valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0); if (valPtr == NULL) { Tcl_DictObjRemove(NULL, leafPtr, keyv[i]); + } else if (leafPtr == valPtr) { + /* + * Someone is messing us around, trying to build a recursive + * structure. [Bug 1786481] + */ + + Tcl_DictObjPut(NULL, leafPtr, keyv[i], Tcl_DuplicateObj(valPtr)); } else { Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr); } } - TclDecrRefCount(keysPtr); /* - * Ensure that none of the dictionaries in the chain still have a - * string rep. + * Ensure that none of the dictionaries in the chain still have a string + * rep. */ - if (objc > 4) { + if (pathc > 0) { InvalidateDictChain(leafPtr); } @@ -2977,88 +3644,45 @@ DictWithCmd(interp, objc, objv) * Write back the outermost dictionary to the variable. */ - if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr, + TCL_LEAVE_ERR_MSG, index) == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardInterpState(state); return TCL_ERROR; } - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_DictObjCmd -- + * TclInitDictCmd -- * - * This function is invoked to process the "dict" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function is create the "dict" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: - * A standard Tcl result. + * A Tcl command handle. * * Side effects: - * See the user documentation. + * May advance compilation epoch. * *---------------------------------------------------------------------- */ -int -Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +Tcl_Command +TclInitDictCmd( + Tcl_Interp *interp) { - static CONST char *subcommands[] = { - "append", "create", "exists", "filter", "for", - "get", "incr", "info", "keys", "lappend", "merge", - "remove", "replace", "set", "size", "unset", - "update", "values", "with", NULL - }; - enum DictSubcommands { - DICT_APPEND, DICT_CREATE, DICT_EXISTS, DICT_FILTER, DICT_FOR, - DICT_GET, DICT_INCR, DICT_INFO, DICT_KEYS, DICT_LAPPEND, DICT_MERGE, - DICT_REMOVE, DICT_REPLACE, DICT_SET, DICT_SIZE, DICT_UNSET, - DICT_UPDATE, DICT_VALUES, DICT_WITH - }; - int index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum DictSubcommands) index) { - case DICT_APPEND: return DictAppendCmd(interp, objc, objv); - case DICT_CREATE: return DictCreateCmd(interp, objc, objv); - case DICT_EXISTS: return DictExistsCmd(interp, objc, objv); - case DICT_FILTER: return DictFilterCmd(interp, objc, objv); - case DICT_FOR: return DictForCmd(interp, objc, objv); - case DICT_GET: return DictGetCmd(interp, objc, objv); - case DICT_INCR: return DictIncrCmd(interp, objc, objv); - case DICT_INFO: return DictInfoCmd(interp, objc, objv); - case DICT_KEYS: return DictKeysCmd(interp, objc, objv); - case DICT_LAPPEND: return DictLappendCmd(interp, objc, objv); - case DICT_MERGE: return DictMergeCmd(interp, objc, objv); - case DICT_REMOVE: return DictRemoveCmd(interp, objc, objv); - case DICT_REPLACE: return DictReplaceCmd(interp, objc, objv); - case DICT_SET: return DictSetCmd(interp, objc, objv); - case DICT_SIZE: return DictSizeCmd(interp, objc, objv); - case DICT_UNSET: return DictUnsetCmd(interp, objc, objv); - case DICT_UPDATE: return DictUpdateCmd(interp, objc, objv); - case DICT_VALUES: return DictValuesCmd(interp, objc, objv); - case DICT_WITH: return DictWithCmd(interp, objc, objv); - } - Tcl_Panic("unexpected fallthrough!"); - /* - * Next line is NOT REACHED - stops compliler complaint though... - */ - return TCL_ERROR; + return TclMakeEnsemble(interp, "dict", implementationMap); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |