summaryrefslogtreecommitdiffstats
path: root/generic/tclDictObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclDictObj.c')
-rw-r--r--generic/tclDictObj.c306
1 files changed, 247 insertions, 59 deletions
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 56baf1f..dac4cbe 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -76,13 +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 DictEachNRCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv, int collect);
-static int DictEachLoopCallback(ClientData data[],
+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.
@@ -186,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 *****/
@@ -2338,11 +2354,11 @@ DictAppendCmd(
/*
*----------------------------------------------------------------------
*
- * DictForNRCmd, DictMapNRCmd, DictEachNRCmd --
+ * DictForNRCmd --
*
- * These functions implement the "dict for" and "dict map" Tcl commands.
- * See the user documentation for details on what it does, and TIP#111
- * and TIP#405 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.
@@ -2360,27 +2376,6 @@ DictForNRCmd(
int objc,
Tcl_Obj *const *objv)
{
- return DictEachNRCmd(dummy, interp, objc, objv, 0);
-}
-
-static int
-DictMapNRCmd(
- ClientData dummy,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- return DictEachNRCmd(dummy, interp, objc, objv, 1);
-}
-
-static int
-DictEachNRCmd(
- ClientData dummy,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv,
- int collect) /* Flag == 1 to collect and return loop body result. */
-{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
@@ -2406,7 +2401,6 @@ DictEachNRCmd(
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
- searchPtr->resultList = (collect ? Tcl_NewListObj(0, NULL) : NULL );
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
@@ -2450,7 +2444,7 @@ DictEachNRCmd(
* Run the script.
*/
- TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
valueVarObj, scriptObj);
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
@@ -2468,7 +2462,7 @@ DictEachNRCmd(
}
static int
-DictEachLoopCallback(
+DictForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -2493,34 +2487,19 @@ DictEachLoopCallback(
result = TCL_OK;
} else if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- ((searchPtr->resultList == NULL) ?
- "\n (\"dict for\" body line %d)" :
- "\n (\"dict map\" body line %d)"),
+ "\n (\"dict for\" body line %d)",
Tcl_GetErrorLine(interp)));
}
goto done;
}
/*
- * Capture result if collecting.
- */
-
- if (searchPtr->resultList != NULL) {
- Tcl_ListObjAppendElement(interp, searchPtr->resultList, Tcl_GetObjResult(interp));
- }
-
- /*
* Get the next mapping from the dictionary.
*/
Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done);
if (done) {
- if (searchPtr->resultList != NULL) {
- Tcl_SetObjResult(interp, searchPtr->resultList);
- searchPtr->resultList = NULL; /* Don't clean it up */
- } else {
- Tcl_ResetResult(interp);
- }
+ Tcl_ResetResult(interp);
goto done;
}
@@ -2530,13 +2509,15 @@ DictEachLoopCallback(
*/
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;
}
@@ -2545,7 +2526,7 @@ DictEachLoopCallback(
* Run the script.
*/
- TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
valueVarObj, scriptObj);
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
@@ -2553,12 +2534,9 @@ DictEachLoopCallback(
* For unwinding everything once the iterating is done.
*/
-done:
+ done:
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
- if (searchPtr->resultList != NULL) {
- TclDecrRefCount(searchPtr->resultList);
- }
TclDecrRefCount(scriptObj);
Tcl_DictObjDone(searchPtr);
TclStackFree(interp, searchPtr);
@@ -2568,6 +2546,216 @@ done:
/*
*----------------------------------------------------------------------
*
+ * 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->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_ResetResult(interp);
+ 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
@@ -3490,7 +3678,7 @@ TclInitDictCmd(
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
-
+
/*
* Local Variables:
* mode: c
generated by cgit v0.12 at 2024-10-31 18:28:39 (GMT)