adjusted non-compiled implementation of [dict map] to match TIP

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