Attachment "td-3163961-3.patch" to
ticket [3163961fff]
added by
twylite
2012-08-02 18:55:26.
Index: doc/dict.n
==================================================================
--- doc/dict.n
+++ doc/dict.n
@@ -144,10 +144,28 @@
to in the dictionary value contained in the given variable, writing
the resulting dictionary value back to that variable. Non-existent
keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list.
+.TP
+\fBdict map {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR
+.
+This command takes three arguments, the first a two-element list of
+variable names (for the key and value respectively of each mapping in
+the dictionary), the second the dictionary value to iterate across,
+and the third a script to be evaluated for each mapping with the key
+and value variables set appropriately (in the manner of \fBmapeach\fR.)
+In an iteration where the evaluated script completes normally
+(\fBTCL_OK\fR) the script result is appended to an accumulator list.
+The result of the \fBdict map\fB command is the accumulator list.
+If any evaluation of the body generates a \fBTCL_BREAK\fR result, no
+further pairs from the dictionary will be iterated over and the
+\fBdict map\fR command will terminate successfully immediately. If any
+evaluation of the body generates a \fBTCL_CONTINUE\fR result, the
+current iteration is aborted and the accumulator list is not modified.
+The order of iteration is the order in which the keys were inserted into
+the dictionary.
.TP
\fBdict merge \fR?\fIdictionaryValue ...\fR?
.
Return a dictionary that contains the contents of each of the
\fIdictionaryValue\fR arguments. Where two (or more) dictionaries
@@ -406,11 +424,11 @@
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
-append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n)
+append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
.SH KEYWORDS
-dictionary, create, update, lookup, iterate, filter
+dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
'\" mode: nroff
'\" End:
ADDED_BY_MERGE doc/mapeach.n
Index: doc/mapeach.n
==================================================================
--- doc/mapeach.n
+++ doc/mapeach.n
@@ -0,0 +1,91 @@
+'\"
+'\" Copyright (c) 2012 Trevor Davel
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.so man.macros
+.TH mapeach n "" Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+mapeach \- Iterate over all elements in one or more lists and collect results
+.SH SYNOPSIS
+\fBmapeach \fIvarname list body\fR
+.br
+\fBmapeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR
+.BE
+
+.SH DESCRIPTION
+.PP
+The \fBmapeach\fR command implements a loop where the loop
+variable(s) take on values from one or more lists, and the loop returns a list
+of results collected from each iteration.
+.PP
+In the simplest case there is one loop variable, \fIvarname\fR,
+and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR.
+The \fIbody\fR argument is a Tcl script.
+For each element of \fIlist\fR (in order
+from first to last), \fBmapeach\fR assigns the contents of the
+element to \fIvarname\fR as if the \fBlindex\fR command had been used
+to extract the element, then calls the Tcl interpreter to execute
+\fIbody\fR. If execution of the body completes normally then the result of the
+body is appended to an accumulator list. \fBmapeach\fR returns the accumulator
+list.
+
+.PP
+In the general case there can be more than one value list
+(e.g., \fIlist1\fR and \fIlist2\fR),
+and each value list can be associated with a list of loop variables
+(e.g., \fIvarlist1\fR and \fIvarlist2\fR).
+During each iteration of the loop
+the variables of each \fIvarlist\fR are assigned
+consecutive values from the corresponding \fIlist\fR.
+Values in each \fIlist\fR are used in order from first to last,
+and each value is used exactly once.
+The total number of loop iterations is large enough to use
+up all the values from all the value lists.
+If a value list does not contain enough
+elements for each of its loop variables in each iteration,
+empty values are used for the missing elements.
+.PP
+The \fBbreak\fR and \fBcontinue\fR statements may be
+invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR
+and \fBforeach\fR commands. In these cases the body does not complete normally
+and the result is not appended to the accumulator list.
+.SH EXAMPLES
+.PP
+Zip lists together:
+.PP
+.CS
+'\" Maintainers: notice the tab hacking below!
+.ta 3i
+set list1 {a b c d}
+set list2 {1 2 3 4}
+set zipped [\fBmapeach\fR a $list1 b $list2 {list $a $b}]
+# The value of zipped is "{a 1} {b 2} {c 3} {d 4}"
+.CE
+.PP
+Filter a list:
+.PP
+.CS
+set values {1 2 3 4 5 6 7 8}
+proc isGood {n} { expr { ($n % 2) == 0 } }
+set goodOnes [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [continue]}}]
+# The value of goodOnes is "2 4 6 8"
+.CE
+.PP
+Take a prefix from a list:
+.PP
+.CS
+set values {8 7 6 5 4 3 2 1}
+proc isGood {n} { expr { $n > 3 } }
+set prefix [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [break]}}]
+# The value of prefix is "8 7 6 5 4"
+.CE
+
+.SH "SEE ALSO"
+for(n), while(n), break(n), continue(n), foreach(n)
+
+.SH KEYWORDS
+foreach, iteration, list, loop, map
Index: generic/tcl.h
==================================================================
--- generic/tcl.h
+++ generic/tcl.h
@@ -1357,10 +1357,11 @@
void *next; /* Search position for underlying hash
* table. */
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;
/*
*----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
Index: generic/tclBasic.c
==================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -235,10 +235,11 @@
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1},
{"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},
{"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1},
{"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
@@ -8847,11 +8848,11 @@
TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN);
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
-
+
int
TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Index: generic/tclCmdAH.c
==================================================================
--- generic/tclCmdAH.c
+++ generic/tclCmdAH.c
@@ -30,10 +30,11 @@
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
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. */
};
/*
* Prototypes for local procedures defined in this file:
*/
@@ -50,10 +51,12 @@
static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
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;
static Tcl_NRPostProc ForCondCallback;
static Tcl_NRPostProc ForNextCallback;
@@ -2558,11 +2561,11 @@
}
/*
*----------------------------------------------------------------------
*
- * 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.
*
* Results:
@@ -2590,10 +2593,42 @@
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
+ return TclNREachloopCmd(dummy, interp, objc, objv, 0);
+}
+
+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, 1);
+}
+
+int
+TclNREachloopCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[],
+ int collect) /* Flag == 1 to collect and return loop body result. */
+{
+
int numLists = (objc-2) / 2;
register struct ForeachState *statePtr;
int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
@@ -2632,10 +2667,12 @@
statePtr->argcList = statePtr->varcList + numLists;
statePtr->numLists = numLists;
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.
*/
@@ -2681,11 +2718,11 @@
result = ForeachAssignments(interp, statePtr);
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);
}
/*
@@ -2708,24 +2745,29 @@
ClientData data[],
Tcl_Interp *interp,
int result)
{
register struct ForeachState *statePtr = data[0];
+ int collect = (int)data[1];
/*
* Process the result code from this run of the [foreach] body. Note that
* this switch uses fallthroughs in several places. Maintainer aware!
*/
switch (result) {
case TCL_CONTINUE:
result = TCL_OK;
+ break;
case TCL_OK:
+ if (collect == 1) {
+ 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)));
default:
goto done;
@@ -2740,20 +2782,21 @@
result = ForeachAssignments(interp, statePtr);
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);
}
/*
* We're done. Tidy up our work space and finish off.
*/
-
- Tcl_ResetResult(interp);
+ finish:
+ Tcl_SetObjResult(interp, statePtr->resultList);
+ statePtr->resultList = NULL; /* Don't clean it up */
done:
ForeachCleanup(interp, statePtr);
return result;
}
@@ -2810,10 +2853,13 @@
TclDecrRefCount(statePtr->vCopyList[i]);
}
if (statePtr->aCopyList[i]) {
TclDecrRefCount(statePtr->aCopyList[i]);
}
+ if (statePtr->resultList) {
+ TclDecrRefCount(statePtr->resultList);
+ }
}
TclStackFree(interp, statePtr);
}
/*
Index: generic/tclCompCmds.c
==================================================================
--- generic/tclCompCmds.c
+++ generic/tclCompCmds.c
@@ -38,10 +38,17 @@
static int PushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
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
* the simplest of compiles. The ANSI C "prototype" for this macro is:
*
@@ -584,10 +591,11 @@
* dict for
* dict get [*]
* dict incr
* dict keys [*]
* dict lappend
+ * dict map
* dict set
* dict unset
*
* In practice, those that are pure-value operators (marked with [*]) can
* probably be left alone (except perhaps [dict get] which is very very
@@ -785,15 +793,41 @@
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* 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. */
const char **argv;
Tcl_DString buffer;
@@ -860,10 +894,26 @@
infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (infoIndex < 0) {
return TCL_ERROR;
}
+
+ /*
+ * 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!
*
@@ -906,10 +956,17 @@
* Compile the loop body itself. It should be stack-neutral.
*/
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);
/*
* Both exception target ranges (error and loop) end here.
*/
@@ -973,18 +1030,26 @@
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
/*
* 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;
}
int
TclCompileDictUpdateCmd(
@@ -1868,18 +1933,51 @@
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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) /* Flag == 1 to collect and return loop body result. */
+{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
int firstValueTemp; /* Index of the first temp var in the frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
+ int collectTemp; /* Index of temp var holding the result list. */
+
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
@@ -2065,10 +2163,26 @@
Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
loopIndex++;
}
}
+
+ /*
+ * 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);
+ }
/*
* Initialize the temporary var that holds the count of loop iterations.
*/
@@ -2090,11 +2204,20 @@
SetLineInformation(bodyIndex);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode( INST_POP, envPtr);
+
+ if (collect == 1) {
+ 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
* the distance to the test is > 120 bytes. This is conservative and
* ensures that we won't have to replace this jump if we later need to
@@ -2140,15 +2263,24 @@
*/
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 (collect == 1) {
+ 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:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != NULL) {
@@ -3694,10 +3826,40 @@
}
}
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 --
Index: generic/tclDictObj.c
==================================================================
--- generic/tclDictObj.c
+++ generic/tclDictObj.c
@@ -74,11 +74,15 @@
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 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);
/*
* Table of dict subcommand names and implementations.
@@ -93,10 +97,11 @@
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"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 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
{"size", DictSizeCmd, NULL, NULL, NULL, 0 },
@@ -2327,15 +2332,15 @@
}
/*
*----------------------------------------------------------------------
*
- * 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.
*
* Side effects:
@@ -2349,10 +2354,31 @@
ClientData dummy,
Tcl_Interp *interp,
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;
Tcl_DictSearch *searchPtr;
int varc, done;
@@ -2374,10 +2400,11 @@
Tcl_SetResult(interp, "must have exactly two variable names",
TCL_STATIC);
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);
return TCL_ERROR;
}
@@ -2417,11 +2444,11 @@
/*
* Run the script.
*/
- TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
valueVarObj, scriptObj);
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
/*
* For unwinding everything on error.
@@ -2435,11 +2462,11 @@
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
static int
-DictForLoopCallback(
+DictEachLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
@@ -2460,23 +2487,38 @@
if (result == TCL_BREAK) {
Tcl_ResetResult(interp);
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;
}
/*
* Stop the value from getting hit in any way by any traces on the key
@@ -2497,21 +2539,24 @@
/*
* Run the script.
*/
- TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj,
valueVarObj, scriptObj);
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
/*
* 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);
return result;
}
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -2772,10 +2772,11 @@
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
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;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
@@ -3363,10 +3364,13 @@
MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
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,
Tcl_Obj *const objv[]);
@@ -3489,10 +3493,13 @@
MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
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);
MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp,
@@ -3558,10 +3565,13 @@
MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
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);
MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
Index: tests/dict.test
==================================================================
--- tests/dict.test
+++ tests/dict.test
@@ -1519,13 +1519,259 @@
}
}
}} [linenumber]}}
} 5
rename linenumber {}
+
+test dict-24.1 {dict map command: syntax} -returnCodes error -body {
+ dict map
+} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+test dict-24.2 {dict map command: syntax} -returnCodes error -body {
+ dict map x
+} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+test dict-24.3 {dict map command: syntax} -returnCodes error -body {
+ dict map x x
+} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+test dict-24.4 {dict map command: syntax} -returnCodes error -body {
+ dict map x x x x
+} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+test dict-24.5 {dict map command: syntax} -returnCodes error -body {
+ dict map x x x
+} -result {must have exactly two variable names}
+test dict-24.6 {dict map command: syntax} -returnCodes error -body {
+ dict map {x x x} x x
+} -result {must have exactly two variable names}
+test dict-24.7 {dict map command: syntax} -returnCodes error -body {
+ dict map "\{x" x x
+} -result {unmatched open brace in list}
+test dict-24.8 {dict map command} -body {
+ # This test confirms that [dict keys], [dict values] and [dict map]
+ # all traverse a dictionary in the same order.
+ set dictv {a A b B c C}
+ set values {}
+ set keys [dict map {k v} $dictv {
+ lappend values $v
+ set k
+ }]
+ set result [expr {
+ $keys eq [dict keys $dictv] && $values eq [dict values $dictv]
+ }]
+ expr {$result ? "YES" : [list "NO" $dictv $keys $values]}
+} -cleanup {
+ unset result keys values k v dictv
+} -result YES
+test dict-24.9 {dict map command} {
+ dict map {k v} {} {
+ error "unexpected execution of 'dict map' body"
+ }
+} {}
+test dict-24.10 {dict map command: script results} -body {
+ set times 0
+ dict map {k v} {a a b b} {
+ incr times
+ continue
+ error "shouldn't get here"
+ }
+ return $times
+} -cleanup {
+ unset times k v
+} -result 2
+test dict-24.11 {dict map command: script results} -body {
+ set times 0
+ dict map {k v} {a a b b} {
+ incr times
+ break
+ error "shouldn't get here"
+ }
+ return $times
+} -cleanup {
+ unset times k v
+} -result 1
+test dict-24.12 {dict map command: script results} -body {
+ set times 0
+ list [catch {
+ dict map {k v} {a a b b} {
+ incr times
+ error test
+ }
+ } msg] $msg $times $::errorInfo
+} -cleanup {
+ unset times k v msg
+} -result {1 test 1 {test
+ while executing
+"error test"
+ ("dict map" body line 3)
+ invoked from within
+"dict map {k v} {a a b b} {
+ incr times
+ error test
+ }"}}
+test dict-24.13 {dict map command: script results} {
+ apply {{} {
+ dict map {k v} {a b} {
+ return ok,$k,$v
+ error "skipped return completely"
+ }
+ error "return didn't go far enough"
+ }}
+} ok,a,b
+test dict-24.14 {dict map command: handle representation loss} -body {
+ set dictVar {a b c d e f g h}
+ set values {}
+ set keys [dict map {k v} $dictVar {
+ if {[llength $dictVar]} {
+ lappend values $v
+ return -level 0 $k
+ }
+ }]
+ list [lsort $keys] [lsort $values]
+} -cleanup {
+ unset dictVar keys values k v
+} -result {{a c e g} {b d f h}}
+test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup {
+ unset -nocomplain accum
+ array set accum {}
+} -body {
+ set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
+ dict map {k v} $dictVar {
+ append accum($k) $v,
+ }
+ set result [lsort [array names accum]]
+ lappend result :
+ foreach k $result {
+ catch {lappend result $accum($k)}
+ }
+ return $result
+} -cleanup {
+ unset dictVar k v result accum
+} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
+test dict-24.16 {dict map command in compilation context} {
+ apply {{} {
+ set res {x x x x x x}
+ dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
+ lset res $v $k
+ continue
+ }
+ return $res
+ }}
+} {a b c d e f}
+test dict-24.17 {dict map command in compilation context} {
+ # Bug 1379349 (dict for)
+ apply {{} {
+ set d [dict create a 1] ;# Dict must be unshared!
+ dict map {k v} $d {
+ dict set d $k 0 ;# Any modification will do
+ }
+ return $d
+ }}
+} {a 0}
+test dict-24.17a {dict map command in compilation context} {
+ # Bug 1379349 (dict for)
+ apply {{} {
+ set d [dict create a 1] ;# Dict must be unshared!
+ dict map {k v} $d {
+ dict set d $k 0 ;# Any modification will do
+ }
+ }}
+} {{a 0}}
+test dict-24.18 {dict map command in compilation context} {
+ # Bug 1382528 (dict for)
+ apply {{} {
+ dict map {k v} {} {} ;# Note empty dict
+ catch { error foo } ;# Note compiled [catch]
+ }}
+} 1
+test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body {
+ di[list]ct map {k v} x {}
+} -returnCodes 1 -result {missing value to go with key}
+test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} {
+ apply {{x y args} {
+ dict map {a b} $x {}
+ concat "c=$y,$args"
+ }} {} 1 2 3
+} {c=1,2 3}
+proc linenumber {} {
+ dict get [info frame -1] line
+}
+test dict-24.20 {dict compilation crash: 'dict for' bug 3487626} {
+ apply {{} {apply {n {
+ set e {}
+ set k {}
+ dict map {a b} {c {d {e {f g}}}} {
+ ::tcl::dict::map {h i} $b {
+ dict update i e j {
+ ::tcl::dict::update j f k {
+ return [expr {$n - [linenumber]}]
+ }
+ }
+ }
+ }
+ }} [linenumber]}}
+} 5
+test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
+ apply {{} {apply {n {
+ set e {}
+ set k {}
+ dict map {a {
+b
+}} {c {d {e {f g}}}} {
+ ::tcl::dict::map {h {
+i
+}} ${
+b
+} {
+ dict update {
+i
+} e {
+j
+} {
+ ::tcl::dict::update {
+j
+} f k {
+ return [expr {$n - [linenumber]}]
+ }
+ }
+ }
+ }
+ }} [linenumber]}}
+} 5
+rename linenumber {}
+test dict-24.22 {dict map results (non-compiled)} {
+ dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
+ return -level 0 "$k,$v"
+ }
+} {{1 a,2 b} {3 c,4 d}}
+test dict-24.23 {dict map results (compiled)} {
+ apply {{} {
+ dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
+ return -level 0 "$k,$v"
+ }
+ }}
+} {{1 a,2 b} {3 c,4 d}}
+test dict-24.23a {dict map results (compiled)} {
+ apply {{list} {
+ dict map {k v} [dict map {k v} $list { list $v $k }] {
+ return -level 0 "$k,$v"
+ }
+ }} {a 1 b 2 c 3 d 4}
+} {{1 a,2 b} {3 c,4 d}}
+test dict-24.24 {dict map with huge dict (non-compiled)} {
+ tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 1000000 x] x] {
+ expr { $k * $v }
+ }]
+} 166666416666500000
+test dict-24.25 {dict map with huge dict (compiled)} {
+ apply {{n} {
+ tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] {
+ expr { $k * $v }
+ }]
+ }} 1000000
+} 166666416666500000
+
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
ADDED_BY_MERGE tests/mapeach.test
Index: tests/mapeach.test
==================================================================
--- tests/mapeach.test
+++ tests/mapeach.test
@@ -0,0 +1,485 @@
+# Commands covered: mapeach, continue, break
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 2011 Trevor Davel
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+catch {unset a}
+catch {unset i}
+catch {unset x}
+
+# ----- Non-compiled operation -------------------------------------------------
+
+
+# Basic "mapeach" operation (non-compiled)
+
+test mapeach-1.1 {basic mapeach tests} {
+ set a {}
+ mapeach i {a b c d} {
+ set a [concat $a $i]
+ }
+} {a {a b} {a b c} {a b c d}}
+test mapeach-1.2 {basic mapeach tests} {
+ mapeach i {a b {{c d} e} {123 {{x}}}} {
+ set i
+ }
+} {a b {{c d} e} {123 {{x}}}}
+test mapeach-1.2a {basic mapeach tests} {
+ mapeach i {a b {{c d} e} {123 {{x}}}} {
+ return -level 0 $i
+ }
+} {a b {{c d} e} {123 {{x}}}}
+test mapeach-1.3 {basic mapeach tests} {catch {mapeach} msg} 1
+test mapeach-1.4 {basic mapeach tests} {
+ catch {mapeach} msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-1.5 {basic mapeach tests} {catch {mapeach i} msg} 1
+test mapeach-1.6 {basic mapeach tests} {
+ catch {mapeach i} msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-1.7 {basic mapeach tests} {catch {mapeach i j} msg} 1
+test mapeach-1.8 {basic mapeach tests} {
+ catch {mapeach i j} msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-1.9 {basic mapeach tests} {catch {mapeach i j k l} msg} 1
+test mapeach-1.10 {basic mapeach tests} {
+ catch {mapeach i j k l} msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-1.11 {basic mapeach tests} {
+ mapeach i {} {
+ set i
+ }
+} {}
+test mapeach-1.12 {basic mapeach tests} {
+ mapeach i {} {
+ return -level 0 x
+ }
+} {}
+test mapeach-1.13 {mapeach errors} {
+ list [catch {mapeach {{a}{b}} {1 2 3} {}} msg] $msg
+} {1 {list element in braces followed by "{b}" instead of space}}
+test mapeach-1.14 {mapeach errors} {
+ list [catch {mapeach a {{1 2}3} {}} msg] $msg
+} {1 {list element in braces followed by "3" instead of space}}
+catch {unset a}
+test mapeach-1.15 {mapeach errors} {
+ catch {unset a}
+ set a(0) 44
+ list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo
+} {1 {can't set "a": variable is array} {can't set "a": variable is array
+ (setting foreach loop variable "a")
+ invoked from within
+"mapeach a {1 2 3} {}"}}
+test mapeach-1.16 {mapeach errors} {
+ list [catch {mapeach {} {} {}} msg] $msg
+} {1 {foreach varlist is empty}}
+catch {unset a}
+
+
+# Parallel "mapeach" operation (non-compiled)
+
+test mapeach-2.1 {parallel mapeach tests} {
+ mapeach {a b} {1 2 3 4} {
+ list $b $a
+ }
+} {{2 1} {4 3}}
+test mapeach-2.2 {parallel mapeach tests} {
+ mapeach {a b} {1 2 3 4 5} {
+ list $b $a
+ }
+} {{2 1} {4 3} {{} 5}}
+test mapeach-2.3 {parallel mapeach tests} {
+ mapeach a {1 2 3} b {4 5 6} {
+ list $b $a
+ }
+} {{4 1} {5 2} {6 3}}
+test mapeach-2.4 {parallel mapeach tests} {
+ mapeach a {1 2 3} b {4 5 6 7 8} {
+ list $b $a
+ }
+} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
+test mapeach-2.5 {parallel mapeach tests} {
+ mapeach {a b} {a b A B aa bb} c {c C cc CC} {
+ list $a $b $c
+ }
+} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
+test mapeach-2.6 {parallel mapeach tests} {
+ mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
+ list $a$b$c$d$e
+ }
+} {11111 22222 33333}
+test mapeach-2.7 {parallel mapeach tests} {
+ mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
+ set x $a$b$c$d$e
+ }
+} {{1111 2} 222 33 4}
+test mapeach-2.8 {parallel mapeach tests} {
+ mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
+ join [list $a $b $c $d $e] .
+ }
+} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
+test mapeach-2.9 {mapeach only sets vars if repeating loop} {
+ namespace eval ::mapeach_test {
+ set rgb {65535 0 0}
+ mapeach {r g b} [set rgb] {}
+ set ::x "r=$r, g=$g, b=$b"
+ }
+ namespace delete ::mapeach_test
+ set x
+} {r=65535, g=0, b=0}
+test mapeach-2.10 {mapeach only supports local scalar variables} {
+ catch { unset a }
+ mapeach {a(3)} {1 2 3 4} {set {a(3)}}
+} {1 2 3 4}
+catch { unset a }
+
+
+# "mapeach" with "continue" and "break" (non-compiled)
+
+test mapeach-3.1 {continue tests} {
+ mapeach i {a b c d} {
+ if {[string compare $i "b"] == 0} continue
+ set i
+ }
+} {a c d}
+test mapeach-3.2 {continue tests} {
+ set x 0
+ list [mapeach i {a b c d} {
+ incr x
+ if {[string compare $i "b"] != 0} continue
+ set i
+ }] $x
+} {b 4}
+test mapeach-3.3 {break tests} {
+ set x 0
+ list [mapeach i {a b c d} {
+ incr x
+ if {[string compare $i "c"] == 0} break
+ set i
+ }] $x
+} {{a b} 3}
+# Check for bug similar to #406709
+test mapeach-3.4 {break tests} {
+ set a 1
+ mapeach b b {list [concat a; break]; incr a}
+ incr a
+} {2}
+
+
+# ----- Compiled operation ------------------------------------------------------
+
+# Basic "mapeach" operation (compiled)
+
+test mapeach-4.1 {basic mapeach tests} {
+ apply {{} {
+ set a {}
+ mapeach i {a b c d} {
+ set a [concat $a $i]
+ }
+ }}
+} {a {a b} {a b c} {a b c d}}
+test mapeach-4.2 {basic mapeach tests} {
+ apply {{} {
+ mapeach i {a b {{c d} e} {123 {{x}}}} {
+ set i
+ }
+ }}
+} {a b {{c d} e} {123 {{x}}}}
+test mapeach-4.2a {basic mapeach tests} {
+ apply {{} {
+ mapeach i {a b {{c d} e} {123 {{x}}}} {
+ return -level 0 $i
+ }
+ }}
+} {a b {{c d} e} {123 {{x}}}}
+test mapeach-4.3 {basic mapeach tests} {catch { apply {{} { mapeach }} } msg} 1
+test mapeach-4.4 {basic mapeach tests} {
+ catch { apply {{} { mapeach }} } msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-4.5 {basic mapeach tests} {catch { apply {{} { mapeach i }} } msg} 1
+test mapeach-4.6 {basic mapeach tests} {
+ catch { apply {{} { mapeach i }} } msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-4.7 {basic mapeach tests} {catch { apply {{} { mapeach i j }} } msg} 1
+test mapeach-4.8 {basic mapeach tests} {
+ catch { apply {{} { mapeach i j }} } msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-4.9 {basic mapeach tests} {catch { apply {{} { mapeach i j k l }} } msg} 1
+test mapeach-4.10 {basic mapeach tests} {
+ catch { apply {{} { mapeach i j k l }} } msg
+ set msg
+} {wrong # args: should be "mapeach varList list ?varList list ...? command"}
+test mapeach-4.11 {basic mapeach tests} {
+ apply {{} { mapeach i {} { set i } }}
+} {}
+test mapeach-4.12 {basic mapeach tests} {
+ apply {{} { mapeach i {} { return -level 0 x } }}
+} {}
+test mapeach-4.13 {mapeach errors} {
+ list [catch { apply {{} { mapeach {{a}{b}} {1 2 3} {} }} } msg] $msg
+} {1 {list element in braces followed by "{b}" instead of space}}
+test mapeach-4.14 {mapeach errors} {
+ list [catch { apply {{} { mapeach a {{1 2}3} {} }} } msg] $msg
+} {1 {list element in braces followed by "3" instead of space}}
+catch {unset a}
+test mapeach-4.15 {mapeach errors} {
+ apply {{} {
+ set a(0) 44
+ list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo
+ }}
+} {1 {can't set "a": variable is array} {can't set "a": variable is array
+ while executing
+"mapeach a {1 2 3} {}"}}
+test mapeach-4.16 {mapeach errors} {
+ list [catch { apply {{} { mapeach {} {} {} }} } msg] $msg
+} {1 {foreach varlist is empty}}
+catch {unset a}
+
+
+# Parallel "mapeach" operation (compiled)
+
+test mapeach-5.1 {parallel mapeach tests} {
+ apply {{} {
+ mapeach {a b} {1 2 3 4} {
+ list $b $a
+ }
+ }}
+} {{2 1} {4 3}}
+test mapeach-5.2 {parallel mapeach tests} {
+ apply {{} {
+ mapeach {a b} {1 2 3 4 5} {
+ list $b $a
+ }
+ }}
+} {{2 1} {4 3} {{} 5}}
+test mapeach-5.3 {parallel mapeach tests} {
+ apply {{} {
+ mapeach a {1 2 3} b {4 5 6} {
+ list $b $a
+ }
+ }}
+} {{4 1} {5 2} {6 3}}
+test mapeach-5.4 {parallel mapeach tests} {
+ apply {{} {
+ mapeach a {1 2 3} b {4 5 6 7 8} {
+ list $b $a
+ }
+ }}
+} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
+test mapeach-5.5 {parallel mapeach tests} {
+ apply {{} {
+ mapeach {a b} {a b A B aa bb} c {c C cc CC} {
+ list $a $b $c
+ }
+ }}
+} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
+test mapeach-5.6 {parallel mapeach tests} {
+ apply {{} {
+ mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
+ list $a$b$c$d$e
+ }
+ }}
+} {11111 22222 33333}
+test mapeach-5.7 {parallel mapeach tests} {
+ apply {{} {
+ mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
+ set x $a$b$c$d$e
+ }
+ }}
+} {{1111 2} 222 33 4}
+test mapeach-5.8 {parallel mapeach tests} {
+ apply {{} {
+ mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
+ join [list $a $b $c $d $e] .
+ }
+ }}
+} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
+test mapeach-5.9 {mapeach only sets vars if repeating loop} {
+ apply {{} {
+ set rgb {65535 0 0}
+ mapeach {r g b} [set rgb] {}
+ return "r=$r, g=$g, b=$b"
+ }}
+} {r=65535, g=0, b=0}
+test mapeach-5.10 {mapeach only supports local scalar variables} {
+ apply {{} {
+ mapeach {a(3)} {1 2 3 4} {set {a(3)}}
+ }}
+} {1 2 3 4}
+
+
+# "mapeach" with "continue" and "break" (compiled)
+
+test mapeach-6.1 {continue tests} {
+ apply {{} {
+ mapeach i {a b c d} {
+ if {[string compare $i "b"] == 0} continue
+ set i
+ }
+ }}
+} {a c d}
+test mapeach-6.2 {continue tests} {
+ apply {{} {
+ list [mapeach i {a b c d} {
+ incr x
+ if {[string compare $i "b"] != 0} continue
+ set i
+ }] $x
+ }}
+} {b 4}
+test mapeach-6.3 {break tests} {
+ apply {{} {
+ list [mapeach i {a b c d} {
+ incr x
+ if {[string compare $i "c"] == 0} break
+ set i
+ }] $x
+ }}
+} {{a b} 3}
+# Check for bug similar to #406709
+test mapeach-6.4 {break tests} {
+ apply {{} {
+ set a 1
+ mapeach b b {list [concat a; break]; incr a}
+ incr a
+ }}
+} {2}
+
+
+
+# ----- Special cases and bugs -------------------------------------------------
+
+
+test mapeach-7.1 {compiled mapeach backward jump works correctly} {
+ catch {unset x}
+ array set x {0 zero 1 one 2 two 3 three}
+ lsort [apply {{arrayName} {
+ upvar 1 $arrayName a
+ mapeach member [array names a] {
+ list $member [set a($member)]
+ }
+ }} x]
+} [lsort {{0 zero} {1 one} {2 two} {3 three}}]
+
+test mapeach-7.2 {noncompiled mapeach and shared variable or value list objects that are converted to another type} {
+ catch {unset x}
+ mapeach {12.0} {a b c} {
+ set x 12.0
+ set x [expr $x + 1]
+ }
+} {13.0 13.0 13.0}
+
+# Test for incorrect "double evaluation" semantics
+test mapeach-7.3 {delayed substitution of body} {
+ apply {{} {
+ set a 0
+ mapeach a [list 1 2 3] "
+ set x $a
+ "
+ set x
+ }}
+} {0}
+
+# Related to "foreach" test for [Bug 1189274]; crash on failure
+test mapeach-7.4 {empty list handling} {
+ proc crash {} {
+ rename crash {}
+ set a "x y z"
+ set b ""
+ mapeach aa $a bb $b { set x "aa = $aa bb = $bb" }
+ }
+ crash
+} {{aa = x bb = } {aa = y bb = } {aa = z bb = }}
+
+# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version
+test mapeach-7.5 {compiled empty var list} {
+ proc foo {} {
+ mapeach {} x {
+ error "reached body"
+ }
+ }
+ list [catch { foo } msg] $msg
+} {1 {foreach varlist is empty}}
+
+test mapeach-7.6 {mapeach: related to "foreach" [Bug 1671087]} -setup {
+ proc demo {} {
+ set vals {1 2 3 4}
+ trace add variable x write {string length $vals ;# }
+ mapeach {x y} $vals {format $y}
+ }
+} -body {
+ demo
+} -cleanup {
+ rename demo {}
+} -result {2 4}
+
+# Huge lists must not overflow the bytecode interpreter (development bug)
+test mapeach-7.7 {huge list non-compiled} {
+ set x [mapeach a [lrepeat 1000000 x] { set b y$a }]
+ list $b [llength $x] [string length $x]
+} {yx 1000000 2999999}
+
+test mapeach-7.8 {huge list compiled} {
+ set x [apply {{times} { mapeach a [lrepeat $times x] { set b y$a }}} 1000000]
+ list $b [llength $x] [string length $x]
+} {yx 1000000 2999999}
+
+
+# ----- Coroutines -------------------------------------------------------------
+
+test mapeach-8.1 {mapeach non-compiled with coroutines} {
+ coroutine coro apply {{} {
+ set values [yield [info coroutine]]
+ eval mapeach i [list $values] {{ yield $i }}
+ }} ;# returns 'coro'
+ coro {a b c d e f} ;# -> a
+ coro 1 ;# -> b
+ coro 2 ;# -> c
+ coro 3 ;# -> d
+ coro 4 ;# -> e
+ coro 5 ;# -> f
+ list [coro 6] [info commands coro]
+} {{1 2 3 4 5 6} {}}
+
+test mapeach-8.2 {mapeach compiled with coroutines} {
+ coroutine coro apply {{} {
+ set values [yield [info coroutine]]
+ mapeach i $values { yield $i }
+ }} ;# returns 'coro'
+ coro {a b c d e f} ;# -> a
+ coro 1 ;# -> b
+ coro 2 ;# -> c
+ coro 3 ;# -> d
+ coro 4 ;# -> e
+ coro 5 ;# -> f
+ list [coro 6] [info commands coro]
+} {{1 2 3 4 5 6} {}}
+
+
+# cleanup
+catch {unset a}
+catch {unset x}
+catch {rename foo {}}
+::tcltest::cleanupTests
+return
