[Patch-3163961] Implementation of TIP #405 merged from private branch. Includes 'mapeach', 'dict map' and 'foreacha' commands, test suite (partial for 'foreacha') and man pages (except for 'foreacha').

8 files changed, 390 insertions, 37 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 729e521..9a7c224 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1359,6 +1359,7 @@ typedef struct {
     int epoch;			/* Epoch marker for dictionary being searched,
 				 * or -1 if search has terminated. */
     Tcl_Dict dictionaryPtr;	/* Reference to dictionary being searched. */
+    Tcl_Obj *resultList;	/* List of result values from the loop body. */
 } Tcl_DictSearch;
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 537750e..fe8fa5a 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -219,6 +219,7 @@ static const CmdInfo builtInCmds[] = {
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	1},
+    {"foreacha",	Tcl_ForeachaObjCmd,	TclCompileForeachaCmd,	TclNRForeachaCmd,	1},
     {"format",		Tcl_FormatObjCmd,	NULL,			NULL,	1},
     {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	1},
     {"if",		Tcl_IfObjCmd,		TclCompileIfCmd,	TclNRIfObjCmd,	1},
@@ -237,6 +238,7 @@ static const CmdInfo builtInCmds[] = {
     {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	1},
     {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	1},
     {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	1},
+    {"mapeach",		Tcl_MapeachObjCmd,	TclCompileMapeachCmd,	TclNRMapeachCmd,	1},
     {"package",		Tcl_PackageObjCmd,	NULL,			NULL,	1},
     {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	1},
     {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	1},
@@ -8849,7 +8851,7 @@ NRCoroInjectObjCmd(
 
     return TCL_OK;
 }
-
+
 int
 TclNRInterpCoroutine(
     ClientData clientData,
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index f09ee70..333946a 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -32,6 +32,7 @@ struct ForeachState {
     int *argcList;		/* Array of value list sizes. */
     Tcl_Obj ***argvList;	/* Array of value lists. */
     Tcl_Obj **aCopyList;	/* Copies of value list arguments. */
+    Tcl_Obj *resultList;	/* List of result values from the loop body. */
 };
 
 /*
@@ -44,7 +45,7 @@ static int		EncodingDirsObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
 static inline int	ForeachAssignments(Tcl_Interp *interp,
-			    struct ForeachState *statePtr);
+			    struct ForeachState *statePtr, int collect);
 static inline void	ForeachCleanup(Tcl_Interp *interp,
 			    struct ForeachState *statePtr);
 static int		GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -52,6 +53,8 @@ static int		GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
 static const char *	GetTypeFromMode(int mode);
 static int		StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
 			    Tcl_StatBuf *statPtr);
+static int		TclNREachloopCmd(ClientData dummy, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[], int collect);
 static Tcl_NRPostProc	CatchObjCmdCallback;
 static Tcl_NRPostProc	ExprCallback;
 static Tcl_NRPostProc	ForSetupCallback;
@@ -2560,7 +2563,7 @@ ForPostNextCallback(
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_ForeachObjCmd, TclNRForeachCmd --
+ * Tcl_ForeachObjCmd, TclNRForeachCmd, TclNREachloopCmd --
  *
  *	This object-based procedure is invoked to process the "foreach" Tcl
  *	command. See the user documentation for details on what it does.
@@ -2592,6 +2595,58 @@ TclNRForeachCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
+    return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_KEEP_NONE);
+}
+
+int
+Tcl_MapeachObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRMapeachCmd, dummy, objc, objv);
+}
+
+int
+TclNRMapeachCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_COLLECT);
+}
+
+int
+Tcl_ForeachaObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRForeachaCmd, dummy, objc, objv);
+}
+
+int
+TclNRForeachaCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_ACCUM);
+}
+
+int
+TclNREachloopCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[],
+    int collect)	/* Select collecting or accumulating mode (TCL_EACH_*) */
+{
+
     int numLists = (objc-2) / 2;
     register struct ForeachState *statePtr;
     int i, j, result;
@@ -2635,6 +2690,8 @@ TclNRForeachCmd(
     statePtr->bodyPtr = objv[objc - 1];
     statePtr->bodyIdx = objc - 1;
 
+    statePtr->resultList = Tcl_NewListObj(0, NULL);
+
     /*
      * Break up the value lists and variable lists into elements.
      */
@@ -2663,9 +2720,13 @@ TclNRForeachCmd(
 	TclListObjGetElements(NULL, statePtr->aCopyList[i],
 		&statePtr->argcList[i], &statePtr->argvList[i]);
 
-	j = statePtr->argcList[i] / statePtr->varcList[i];
-	if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
-	    j++;
+	j = (i == 0) && (collect == TCL_EACH_ACCUM); /* Accumulator present? */
+	/* If accumulator is only var in list, then we iterate j=1 times */
+	if (statePtr->varcList[i] > j) {
+	    /* We need listLen/numVars round up = ((listLen+numVars-1)/numVars)
+	     * When accum is present we need (listLen-1)/(numVars-1) round up */
+	    j = (statePtr->argcList[i] - j + statePtr->varcList[i] - j - 1)
+		/ (statePtr->varcList[i] - j);
 	}
 	if (j > statePtr->maxj) {
 	    statePtr->maxj = j;
@@ -2678,12 +2739,12 @@ TclNRForeachCmd(
      */
 
     if (statePtr->maxj > 0) {
-	result = ForeachAssignments(interp, statePtr);
+	result = ForeachAssignments(interp, statePtr, collect);
 	if (result == TCL_ERROR) {
 	    goto done;
 	}
 
-	TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+	TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL);
 	return TclNREvalObjEx(interp, objv[objc-1], 0,
 		((Interp *) interp)->cmdFramePtr, objc-1);
     }
@@ -2710,6 +2771,7 @@ ForeachLoopStep(
     int result)
 {
     register struct ForeachState *statePtr = data[0];
+    int collect = (int)data[1]; /* Selected collecting or accumulating mode. */
 
     /*
      * Process the result code from this run of the [foreach] body. Note that
@@ -2719,11 +2781,15 @@ ForeachLoopStep(
     switch (result) {
     case TCL_CONTINUE:
 	result = TCL_OK;
+	break;
     case TCL_OK:
+	if (collect == TCL_EACH_COLLECT) {
+	  Tcl_ListObjAppendElement(interp, statePtr->resultList, Tcl_GetObjResult(interp));
+	}
 	break;
     case TCL_BREAK:
 	result = TCL_OK;
-	goto done;
+	goto finish;
     case TCL_ERROR:
 	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 		"\n    (\"foreach\" body line %d)", Tcl_GetErrorLine(interp)));
@@ -2737,12 +2803,12 @@ ForeachLoopStep(
      */
 
     if (statePtr->maxj > ++statePtr->j) {
-	result = ForeachAssignments(interp, statePtr);
+	result = ForeachAssignments(interp, statePtr, collect);
 	if (result == TCL_ERROR) {
 	    goto done;
 	}
 
-	TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+	TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL);
 	return TclNREvalObjEx(interp, statePtr->bodyPtr, 0,
 		((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
     }
@@ -2750,8 +2816,18 @@ ForeachLoopStep(
     /*
      * We're done. Tidy up our work space and finish off.
      */
-
-    Tcl_ResetResult(interp);
+finish:
+    if (collect == TCL_EACH_ACCUM) {
+	Tcl_Obj* valueObj =  Tcl_ObjGetVar2(interp, statePtr->varvList[0][0], 
+		NULL, TCL_LEAVE_ERR_MSG);
+	if (valueObj == NULL) {
+	    goto done;
+	}
+	Tcl_SetObjResult(interp, valueObj);
+    } else {
+	Tcl_SetObjResult(interp, statePtr->resultList);
+	statePtr->resultList = NULL; /* Don't clean it up */
+    }
   done:
     ForeachCleanup(interp, statePtr);
     return result;
@@ -2764,13 +2840,16 @@ ForeachLoopStep(
 static inline int
 ForeachAssignments(
     Tcl_Interp *interp,
-    struct ForeachState *statePtr)
+    struct ForeachState *statePtr,
+    int collect)	/* Select collecting or accumulating mode (TCL_EACH_*) */
 {
     int i, v, k;
     Tcl_Obj *valuePtr, *varValuePtr;
 
     for (i=0 ; i<statePtr->numLists ; i++) {
-	for (v=0 ; v<statePtr->varcList[i] ; v++) {
+	/* Don't modify the accumulator except on the first iteration */
+	v = ((i == 0) && (collect == TCL_EACH_ACCUM) && (statePtr->index[i] > 0));
+	for (; v<statePtr->varcList[i] ; v++) {
 	    k = statePtr->index[i]++;
 
 	    if (k < statePtr->argcList[i]) {
@@ -2813,6 +2892,9 @@ ForeachCleanup(
 	    TclDecrRefCount(statePtr->aCopyList[i]);
 	}
     }
+    if (statePtr->resultList) {
+	TclDecrRefCount(statePtr->resultList);
+    }
     TclStackFree(interp, statePtr);
 }
 
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 3540716..07a5eea 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -40,6 +40,13 @@ static int		PushVarName(Tcl_Interp *interp,
 			    int flags, int *localIndexPtr,
 			    int *simpleVarNamePtr, int *isScalarPtr,
 			    int line, int *clNext);
+static int      TclCompileEachloopCmd(Tcl_Interp *interp,
+                Tcl_Parse *parsePtr, Command *cmdPtr,    CompileEnv *envPtr,
+                int collect);
+static int		TclCompileDictEachCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr, int collect);
+
 
 /*
  * Macro that encapsulates an efficiency trick that avoids a function call for
@@ -586,6 +593,7 @@ TclCompileContinueCmd(
  *		dict incr
  *		dict keys	[*]
  *		dict lappend
+ *		dict map
  *		dict set
  *		dict unset
  *
@@ -787,11 +795,37 @@ TclCompileDictForCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
+    return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 0);
+}
+
+int
+TclCompileDictMapCmd(
+    Tcl_Interp *interp,     /* Used for looking up stuff. */
+    Tcl_Parse *parsePtr,    /* Points to a parse structure for the command
+                 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,        /* Points to defintion of command being
+                 * compiled. */
+    CompileEnv *envPtr)     /* Holds resulting instructions. */
+{
+    return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 1);
+}
+
+int
+TclCompileDictEachCmd(
+    Tcl_Interp *interp,     /* Used for looking up stuff. */
+    Tcl_Parse *parsePtr,    /* Points to a parse structure for the command
+                 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,        /* Points to defintion of command being
+                 * compiled. */
+    CompileEnv *envPtr,     /* Holds resulting instructions. */
+    int collect)	    /* Flag == 1 to collect and return loop body result. */
+{
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
     int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
     int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
     int numVars, endTargetOffset;
+    int collectTemp; /* Index of temp var holding the result list. */
     int savedStackDepth = envPtr->currStackDepth;
 				/* Needed because jumps confuse the stack
 				 * space calculator. */
@@ -864,6 +898,22 @@ TclCompileDictForCmd(
     }
 
     /*
+     * Create temporary variable to capture return values from loop body.
+     */
+
+    if (collect == 1) {
+	collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr);
+
+	PushLiteral(envPtr, "", 0);
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(INST_STORE_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(INST_STORE_SCALAR4, collectTemp, envPtr);
+	}
+	TclEmitOpcode(INST_POP, envPtr);
+    }
+
+    /*
      * Preparation complete; issue instructions. Note that this code issues
      * fixed-sized jumps. That simplifies things a lot!
      *
@@ -908,6 +958,13 @@ TclCompileDictForCmd(
 
     SetLineInformation(3);
     CompileBody(envPtr, bodyTokenPtr, interp);
+    if (collect == 1) {
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(INST_LAPPEND_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(INST_LAPPEND_SCALAR4, collectTemp, envPtr);
+	}
+    }
     TclEmitOpcode(	INST_POP,				envPtr);
 
     /*
@@ -975,14 +1032,22 @@ TclCompileDictForCmd(
 
     /*
      * Final stage of the command (normal case) is that we push an empty
-     * object. This is done last to promote peephole optimization when it's
-     * dropped immediately.
+     * object (or push the accumulator as the result object). This is done
+     * last to promote peephole optimization when it's dropped immediately.
      */
 
     jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
     TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
 	    envPtr->codeStart + endTargetOffset);
-    PushLiteral(envPtr, "", 0);
+    if (collect == 1) {
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(INST_LOAD_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(INST_LOAD_SCALAR4, collectTemp, envPtr);
+	}
+    } else {
+	PushLiteral(envPtr, "", 0);
+    }
     return TCL_OK;
 }
 
@@ -1846,9 +1911,9 @@ TclCompileForCmd(
 /*
  *----------------------------------------------------------------------
  *
- * TclCompileForeachCmd --
+ * TclCompileForeachCmd, TclCompileForeachaCmd --
  *
- *	Procedure called to compile the "foreach" command.
+ *	Procedure called to compile the "foreach" and "foreacha" commands.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -1870,6 +1935,49 @@ TclCompileForeachCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
+  return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0);
+}
+
+int
+TclCompileForeachaCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+  return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 2);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileEachloopCmd --
+ *
+ *	Procedure called to compile the "foreach" and "mapeach" commands.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "foreach" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclCompileEachloopCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr,		/* Holds resulting instructions. */
+    int collect)		/* Select collecting or accumulating mode (TCL_EACH_*) */
+{
     Proc *procPtr = envPtr->procPtr;
     ForeachInfo *infoPtr;	/* Points to the structure describing this
 				 * foreach command. Stored in a AuxData
@@ -1878,6 +1986,8 @@ TclCompileForeachCmd(
 				 * used to point to a value list. */
     int loopCtTemp;		/* Index of temp var holding the loop's
 				 * iteration count. */
+    int collectTemp = -1;	/* Index of temp var holding the result var index. */
+
     Tcl_Token *tokenPtr, *bodyTokenPtr;
     unsigned char *jumpPc;
     JumpFixup jumpFalseFixup;
@@ -2026,6 +2136,7 @@ TclCompileForeachCmd(
     infoPtr->numLists = numLists;
     infoPtr->firstValueTemp = firstValueTemp;
     infoPtr->loopCtTemp = loopCtTemp;
+    infoPtr->collect = collect;
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
 	ForeachVarList *varListPtr;
 
@@ -2039,6 +2150,9 @@ TclCompileForeachCmd(
 
 	    varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
 		    nameChars, /*create*/ 1, envPtr);
+	    if ((collect == TCL_EACH_ACCUM) && ((loopIndex + j) == 0)) {
+		collectTemp = varListPtr->varIndexes[j];
+	    }
 	}
 	infoPtr->varLists[loopIndex] = varListPtr;
     }
@@ -2069,6 +2183,22 @@ TclCompileForeachCmd(
     }
 
     /*
+     * Create temporary variable to capture return values from loop body.
+     */
+     
+    if (collect == TCL_EACH_COLLECT) {
+	collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr);
+	    
+	PushLiteral(envPtr, "", 0);
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(  INST_STORE_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(  INST_STORE_SCALAR4, collectTemp, envPtr);
+	}
+	TclEmitOpcode(      INST_POP,       envPtr);
+    }
+
+    /*
      * Initialize the temporary var that holds the count of loop iterations.
      */
 
@@ -2092,7 +2222,16 @@ TclCompileForeachCmd(
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
     envPtr->currStackDepth = savedStackDepth + 1;
-    TclEmitOpcode(		INST_POP,			envPtr);
+
+    if (collect == TCL_EACH_COLLECT) {
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(  INST_LAPPEND_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(  INST_LAPPEND_SCALAR4, collectTemp, envPtr);
+	}
+    }
+    TclEmitOpcode(        INST_POP,           envPtr);
+
 
     /*
      * Jump back to the test at the top of the loop. Generate a 4 byte jump if
@@ -2142,11 +2281,20 @@ TclCompileForeachCmd(
     ExceptionRangeTarget(envPtr, range, breakOffset);
 
     /*
-     * The foreach command's result is an empty string.
+     * The command's result is an empty string if not collecting, or the
+     * list of results from evaluating the loop body.
      */
 
     envPtr->currStackDepth = savedStackDepth;
-    PushLiteral(envPtr, "", 0);
+    if (collectTemp >= 0) {
+	if (collectTemp <= 255) {
+	    TclEmitInstInt1(  INST_LOAD_SCALAR1, collectTemp, envPtr);
+	} else {
+	    TclEmitInstInt4(  INST_LOAD_SCALAR4, collectTemp, envPtr);
+	}
+    } else {
+	PushLiteral(envPtr, "", 0);
+    }
     envPtr->currStackDepth = savedStackDepth + 1;
 
   done:
@@ -2196,6 +2344,7 @@ DupForeachInfo(
     dupPtr->numLists = numLists;
     dupPtr->firstValueTemp = srcPtr->firstValueTemp;
     dupPtr->loopCtTemp = srcPtr->loopCtTemp;
+    dupPtr->collect = srcPtr->collect;
 
     for (i = 0;  i < numLists;  i++) {
 	srcListPtr = srcPtr->varLists[i];
@@ -2286,6 +2435,8 @@ PrintForeachInfo(
     }
     Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
 	    (unsigned) infoPtr->loopCtTemp);
+    Tcl_AppendPrintfToObj(appendObj, "], collect=%%v%u",
+	    (unsigned) infoPtr->collect);
     for (i=0 ; i<infoPtr->numLists ; i++) {
 	if (i) {
 	    Tcl_AppendToObj(appendObj, ",", -1);
@@ -3700,6 +3851,36 @@ TclCompileLsetCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileMapeachCmd --
+ *
+ *	Procedure called to compile the "mapeach" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "mapeach" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileMapeachCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+  return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileNamespaceCmd --
  *
  *	Procedure called to compile the "namespace" command; currently, only
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index ba78c36..7a41bb1 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -807,6 +807,7 @@ typedef struct ForeachInfo {
 				 * the loop's iteration count. Used to
 				 * determine next value list element to assign
 				 * each loop var. */
+    int collect;		/* Selected collecting or accumulating mode. */
     ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList
 				 * structures describing each var list. The
 				 * actual size of this field will be large
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ac2cb62..2e24d75 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -76,7 +76,11 @@ 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		DictForLoopCallback(ClientData data[],
+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[],
 			    Tcl_Interp *interp, int result);
 
 
@@ -95,6 +99,7 @@ static const EnsembleImplMap implementationMap[] = {
     {"info",	DictInfoCmd, NULL, NULL, NULL, 0 },
     {"keys",	DictKeysCmd, NULL, NULL, NULL, 0 },
     {"lappend",	DictLappendCmd,	TclCompileDictLappendCmd, NULL, NULL, 0 },
+    {"map", 	NULL,       	TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
     {"merge",	DictMergeCmd, NULL, NULL, NULL, 0 },
     {"remove",	DictRemoveCmd, NULL, NULL, NULL, 0 },
     {"replace",	DictReplaceCmd, NULL, NULL, NULL, 0 },
@@ -2329,11 +2334,11 @@ DictAppendCmd(
 /*
  *----------------------------------------------------------------------
  *
- * DictForNRCmd --
+ * DictForNRCmd, DictMapNRCmd, DictEachNRCmd --
  *
- *	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" 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.
  *
  * Results:
  *	A standard Tcl result.
@@ -2351,6 +2356,27 @@ 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;
@@ -2376,6 +2402,7 @@ DictForNRCmd(
 	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);
@@ -2419,7 +2446,7 @@ DictForNRCmd(
      * Run the script.
      */
 
-    TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+    TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
 	    valueVarObj, scriptObj);
     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
 
@@ -2437,7 +2464,7 @@ DictForNRCmd(
 }
 
 static int
-DictForLoopCallback(
+DictEachLoopCallback(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -2462,19 +2489,34 @@ DictForLoopCallback(
 	    result = TCL_OK;
 	} else if (result == TCL_ERROR) {
 	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		    "\n    (\"dict for\" body line %d)",
+		    ((searchPtr->resultList == NULL) ? 
+			"\n    (\"dict for\" body line %d)" : 
+			"\n    (\"dict map\" 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) {
-	Tcl_ResetResult(interp);
+    	if (searchPtr->resultList != NULL) {
+	    Tcl_SetObjResult(interp, searchPtr->resultList);
+	    searchPtr->resultList = NULL; /* Don't clean it up */
+	} else {
+	    Tcl_ResetResult(interp);
+	}    	
 	goto done;
     }
 
@@ -2499,7 +2541,7 @@ DictForLoopCallback(
      * Run the script.
      */
 
-    TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+    TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
 	    valueVarObj, scriptObj);
     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
 
@@ -2507,9 +2549,12 @@ DictForLoopCallback(
      * 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);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e402634..952eb32 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5492,7 +5492,15 @@ TEBCresume(
 			opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
 		goto gotError;
 	    }
-	    if (listLen > iterNum * numVars) {
+
+	    /* If the accumulator is the only variable then this list gets
+	     * just one iteration.  Otherwise we must keep going until the
+	     * list is exhausted by non-accumulator loop vars */
+	    j = ((i == 0) && (iterNum > 0) 
+		&& (infoPtr->collect == TCL_EACH_ACCUM));
+		/* j is 1 if the accumulator is present but does not consume
+		 * an element, or 0 otherwise (consuming or not-present). */
+	    if ((numVars > j) && (listLen > (iterNum * (numVars - j) + j))) {
 		continueLoop = 1;
 	    }
 	    listTmpIndex++;
@@ -5517,8 +5525,11 @@ TEBCresume(
 		listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
 		TclListObjGetElements(interp, listPtr, &listLen, &elements);
 
-		valIndex = (iterNum * numVars);
-		for (j = 0;  j < numVars;  j++) {
+		/* Don't modify the accumulator except on the first iteration */
+		j = ((i == 0) && (iterNum > 0) 
+			&& (infoPtr->collect == TCL_EACH_ACCUM));
+		valIndex = (iterNum * (numVars - j) + j);
+		for (;  j < numVars;  j++) {
 		    if (valIndex >= listLen) {
 			TclNewObj(valuePtr);
 		    } else {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 53a88d6..6600dd9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2773,7 +2773,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachaCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
@@ -2854,6 +2856,19 @@ struct Tcl_LoadHandle_ {
 #define TCL_DD_SHORTEST0		0x0
 				/* 'Shortest possible' after masking */
 
+/* Modes for collecting or accumulating in TclNREachloopCmd, 
+ * TclCompileEachloopCmd and INST_FOREACH_STEP4. */
+
+#define TCL_EACH_KEEP_NONE		0
+				/* Discard iteration result like [foreach] */
+
+#define TCL_EACH_COLLECT		1
+				/* Collect iteration result like [mapeach] */
+
+#define TCL_EACH_ACCUM			2
+				/* First loop var is accumulator like [foreacha] */
+
+
 /*
  *----------------------------------------------------------------
  * Procedures shared among Tcl modules but not used by the outside world:
@@ -3299,6 +3314,9 @@ MODULE_SCOPE int	Tcl_ForObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_ForeachObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_ForeachaObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_FormatObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3366,6 +3384,9 @@ MODULE_SCOPE int	Tcl_LsetObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LsortObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_MapeachObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	TclNamespaceEnsembleCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
@@ -3492,6 +3513,9 @@ MODULE_SCOPE int	TclCompileDictAppendCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileDictForCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileDictMapCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileDictGetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
@@ -3525,6 +3549,9 @@ MODULE_SCOPE int	TclCompileForCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileForeachCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileForeachaCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileGlobalCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
@@ -3561,6 +3588,9 @@ MODULE_SCOPE int	TclCompileLreplaceCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileMapeachCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);