summaryrefslogtreecommitdiffstats
path: root/generic/tclDictObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclDictObj.c')
-rw-r--r--generic/tclDictObj.c620
1 files changed, 482 insertions, 138 deletions
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 83fc3a6..e31d708 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -76,9 +76,12 @@ 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.
@@ -86,24 +89,25 @@ static int DictForLoopCallback(ClientData data[],
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
- {"create", DictCreateCmd, NULL, NULL, NULL, 0 },
- {"exists", DictExistsCmd, NULL, NULL, NULL, 0 },
- {"filter", DictFilterCmd, NULL, 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, NULL, NULL, NULL, 0 },
- {"keys", DictKeysCmd, NULL, NULL, NULL, 0 },
+ {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
- {"merge", DictMergeCmd, NULL, NULL, NULL, 0 },
- {"remove", DictRemoveCmd, NULL, 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, NULL, NULL, NULL, 0 },
- {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 },
+ {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
{"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
- {"values", DictValuesCmd, NULL, NULL, NULL, 0 },
- {"with", DictWithCmd, NULL, NULL, NULL, 0 },
+ {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 },
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -181,6 +185,23 @@ static const Tcl_HashKeyType chainHashType = {
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 *****/
@@ -340,7 +361,7 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = srcPtr->internalRep.otherValuePtr;
+ Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
@@ -375,7 +396,7 @@ DupDictInternalRep(
* Store in the object.
*/
- copyPtr->internalRep.otherValuePtr = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
copyPtr->typePtr = &tclDictType;
}
@@ -401,14 +422,12 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
dict->refcount--;
if (dict->refcount <= 0) {
DeleteDict(dict);
}
-
- dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */
dictPtr->typePtr = NULL;
}
@@ -468,7 +487,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -694,13 +713,14 @@ SetDictFromAny(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- objPtr->internalRep.otherValuePtr = dict;
+ objPtr->internalRep.twoPtrValue.ptr1 = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
missingValue:
if (interp != NULL) {
- Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
result = TCL_ERROR;
@@ -762,7 +782,7 @@ TclTraceDictPath(
return NULL;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -779,9 +799,9 @@ TclTraceDictPath(
}
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);
}
@@ -805,7 +825,7 @@ TclTraceDictPath(
}
}
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -813,7 +833,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
}
newDict->chain = dictPtr;
@@ -848,17 +868,17 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- 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 = dictObj->internalRep.otherValuePtr;
+ dict = dictObj->internalRep.twoPtrValue.ptr1;
} while (dict != NULL);
}
@@ -905,9 +925,9 @@ Tcl_DictObjPut(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -953,11 +973,12 @@ Tcl_DictObjGet(
if (dictPtr->typePtr != &tclDictType) {
int result = SetDictFromAny(interp, dictPtr);
if (result != TCL_OK) {
+ *valuePtrPtr = NULL;
return result;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1006,9 +1027,9 @@ Tcl_DictObjRemove(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (DeleteChainEntry(dict, keyPtr)) {
dict->epoch++;
}
@@ -1048,7 +1069,7 @@ Tcl_DictObjSize(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1103,7 +1124,7 @@ Tcl_DictObjFirst(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = -1;
@@ -1278,7 +1299,7 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1334,7 +1355,7 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1374,13 +1395,13 @@ Tcl_NewDictObj(void)
Dict *dict;
TclNewObj(dictPtr);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1423,13 +1444,13 @@ Tcl_DbNewDictObj(
Dict *dict;
TclDbNewObj(dictPtr, file, line);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
@@ -1571,9 +1592,9 @@ DictGetCmd(
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;
@@ -1982,7 +2003,6 @@ DictExistsCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr;
- int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
@@ -1991,18 +2011,13 @@ DictExistsCmd(
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;
}
@@ -2033,6 +2048,7 @@ DictInfoCmd(
{
Tcl_Obj *dictPtr;
Dict *dict;
+ char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
@@ -2046,9 +2062,11 @@ DictInfoCmd(
return result;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
- Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC);
+ statsStr = Tcl_HashStats(&dict->table);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
+ ckfree(statsStr);
return TCL_OK;
}
@@ -2159,7 +2177,7 @@ DictIncrCmd(
}
}
if (code == TCL_OK) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
@@ -2248,7 +2266,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
} else if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
@@ -2337,7 +2355,7 @@ DictAppendCmd(
*
* DictForNRCmd --
*
- * This function implements the "dict for" Tcl command. See the user
+ * 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.
*
@@ -2377,8 +2395,8 @@ DictForNRCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
@@ -2490,13 +2508,15 @@ DictForLoopCallback(
*/
Tcl_IncrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ 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) {
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
goto done;
}
@@ -2525,6 +2545,217 @@ DictForLoopCallback(
/*
*----------------------------------------------------------------------
*
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DictSetCmd --
*
* This function implements the "dict set" Tcl command. See the user
@@ -2793,8 +3024,8 @@ DictFilterCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
keyVarObj = varv[0];
@@ -2834,16 +3065,19 @@ DictFilterCmd(
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), "\"", 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), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set value variable: \"%s\"",
+ TclGetString(valueVarObj)));
+ result = TCL_ERROR;
goto abnormalResult;
}
@@ -3110,9 +3344,7 @@ DictWithCmd(
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr;
- Tcl_DictSearch s;
- int done;
+ Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script");
@@ -3127,39 +3359,13 @@ DictWithCmd(
if (dictPtr == NULL) {
return TCL_ERROR;
}
- if (objc > 3) {
- dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2,
- DICT_PATH_READ);
- if (dictPtr == NULL) {
- return TCL_ERROR;
- }
- }
- /*
- * 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) {
+ keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2);
+ if (keysPtr == NULL) {
return TCL_ERROR;
}
-
- TclNewObj(keysPtr);
Tcl_IncrRefCount(keysPtr);
- for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
- Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
- if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
- TCL_LEAVE_ERR_MSG) == NULL) {
- TclDecrRefCount(keysPtr);
- Tcl_DictObjDone(&s);
- return TCL_ERROR;
- }
- }
-
/*
* Execute the body, while making the invoking context available to the
* loop body (TIP#280) and postponing the cleanup until later (NRE).
@@ -3183,55 +3389,200 @@ FinalizeDictWith(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr;
- int keyc, i, allocdict = 0;
+ 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 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.
+ */
+
+ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
+ &done) != TCL_OK) {
+ return NULL;
+ }
+
+ TclNewObj(keysPtr);
+
+ for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
+ Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
+ if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(keysPtr);
+ Tcl_DictObjDone(&s);
+ return NULL;
+ }
+ }
+
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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.
*/
- dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
+ dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, index);
if (dictPtr == NULL) {
- TclDecrRefCount(varName);
- TclDecrRefCount(keysPtr);
- if (pathPtr) {
- TclDecrRefCount(pathPtr);
- }
- 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(varName);
- TclDecrRefCount(keysPtr);
- if (pathPtr) {
- TclDecrRefCount(pathPtr);
- }
- Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
allocdict = 1;
+ } else {
+ allocdict = 0;
}
- if (pathPtr != NULL) {
- Tcl_Obj **pathv;
- int pathc;
-
+ 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
@@ -3241,26 +3592,19 @@ FinalizeDictWith(
* perfectly efficient (but no memory should be leaked).
*/
- Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
DICT_PATH_EXISTS | DICT_PATH_UPDATE);
- TclDecrRefCount(pathPtr);
if (leafPtr == NULL) {
- TclDecrRefCount(varName);
- TclDecrRefCount(keysPtr);
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
if (leafPtr == DICT_PATH_NON_EXISTENT) {
- TclDecrRefCount(varName);
- TclDecrRefCount(keysPtr);
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- return Tcl_RestoreInterpState(interp, state);
+ return TCL_OK;
}
} else {
leafPtr = dictPtr;
@@ -3286,14 +3630,13 @@ FinalizeDictWith(
Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
}
}
- TclDecrRefCount(keysPtr);
/*
* Ensure that none of the dictionaries in the chain still have a string
* rep.
*/
- if (pathPtr != NULL) {
+ if (pathc > 0) {
InvalidateDictChain(leafPtr);
}
@@ -3301,13 +3644,14 @@ FinalizeDictWith(
* Write back the outermost dictionary to the variable.
*/
- if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
- TCL_LEAVE_ERR_MSG) == NULL) {
- Tcl_DiscardInterpState(state);
+ if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr,
+ TCL_LEAVE_ERR_MSG, index) == NULL) {
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
return TCL_ERROR;
}
- TclDecrRefCount(varName);
- return Tcl_RestoreInterpState(interp, state);
+ return TCL_OK;
}
/*
@@ -3334,7 +3678,7 @@ TclInitDictCmd(
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
-
+
/*
* Local Variables:
* mode: c
generated by cgit v0.12 at 2025-10-24 13:08:51 (GMT)