summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/dict.n22
-rw-r--r--doc/mapeach.n91
-rw-r--r--generic/tcl.h1
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdAH.c110
-rw-r--r--generic/tclCompCmds.c197
-rw-r--r--generic/tclCompile.h1
-rw-r--r--generic/tclDictObj.c67
-rw-r--r--generic/tclExecute.c17
-rw-r--r--generic/tclInt.h30
-rw-r--r--tests/dict.test246
-rw-r--r--tests/foreach.test9
-rw-r--r--tests/foreacha.test217
-rw-r--r--tests/mapeach.test493
14 files changed, 1466 insertions, 39 deletions
diff --git a/doc/dict.n b/doc/dict.n
index 361a112..b9b4767 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -147,6 +147,24 @@ 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
@@ -408,9 +426,9 @@ 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:
diff --git a/doc/mapeach.n b/doc/mapeach.n
new file mode 100644
index 0000000..c89f7d9
--- /dev/null
+++ b/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
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);
diff --git a/tests/dict.test b/tests/dict.test
index 77bacf6..398493a 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1521,6 +1521,252 @@ j
}} [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
diff --git a/tests/foreach.test b/tests/foreach.test
index a4b652a..6c69b29 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -266,6 +266,15 @@ test foreach-10.1 {foreach: [Bug 1671087]} -setup {
rename demo {}
} -result {}
+test foreach-11.1 {error then dereference loop var (dev bug)} {
+ catch { foreach a 0 b {1 2 3} { error x } }
+ set a
+} 0
+test foreach-11.2 {error then dereference loop var (dev bug)} {
+ catch { foreach a 0 b {1 2 3} { incr a $b; error x } }
+ set a
+} 1
+
# cleanup
catch {unset a}
catch {unset x}
diff --git a/tests/foreacha.test b/tests/foreacha.test
new file mode 100644
index 0000000..09a90e4
--- /dev/null
+++ b/tests/foreacha.test
@@ -0,0 +1,217 @@
+# Commands covered: foreach, 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+catch {unset a}
+catch {unset x}
+
+# ----- Basic "foreacha" operation (non-compiled) ------------------------------
+
+test foreacha-1.1 {basic foreacha tests (non-compiled) - foldl/reduce with initial value} {
+ set x {}
+ set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }]
+ list $a $b $c $x
+} {10 4 10 {0 1 3 6}}
+
+test foreacha-1.2 {basic foreacha tests (non-compiled) - foldl/reduce without initial value} {
+ set x {}
+ set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }]
+ list $a $b $c $x
+} {21 6 21 {1 3 6 10 15}}
+
+test foreacha-1.3 {basic foreacha tests (non-compiled) - filter} {
+ foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } }
+} {2 4 6}
+
+test foreacha-1.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} {
+ foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b }
+} {1 3 5}
+
+test foreacha-1.4 {basic foreacha tests (non-compiled) - map} {
+ foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] }
+} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}}
+
+test foreacha-1.5 {basic foreacha tests (non-compiled) - prefix (via break)} {
+ foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b }
+} {1 2 3 4}
+
+test foreacha-1.6 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} {
+ set x {}
+ set b [foreacha a {1 2 3 4} { lappend x $a }]
+ list $a $b $x
+} {1 1 1}
+
+test foreacha-1.7 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} {
+ set x {}
+ set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }]
+ list $a $b $c $x
+} {10 010 10 {1 0}}
+
+test foreacha-1.8 {basic foreacha tests (non-compiled) - huge list} {
+ foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b }
+} 499999500000
+
+test foreacha-1.9 {basic foreacha tests (non-compiled) - spaghetti} {
+ foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] {
+ lappend a [expr { $b * $c }]
+ }] {
+ incr a $b
+ }
+} 166416500
+
+test foreacha-1.9.1 {basic foreacha tests (non-compiled) - spaghetti with mapeach} {
+ foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] {
+ expr { $b * $c }
+ }] {
+ incr a $b
+ }
+} 166416500
+
+test foreacha-1.10 {basic foreacha tests (non-compiled) - nested} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }]
+ }
+} 332843490
+
+test foreacha-1.10.1 {basic foreacha tests (non-compiled) - nested with loop var collision} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ foreacha a 10 b [lrepeat $b $b] { incr a $b }
+ }
+} 998011
+
+test foreacha-1.10.2 {basic foreacha tests (non-compiled) - nested, inner non-compiled} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]]
+ }
+} 332843490
+
+
+# ----- Basic "foreacha" operation (compiled) ----------------------------------
+
+test foreacha-2.1 {basic foreacha tests (compiled) - foldl/reduce with initial value} {
+ apply {{} {
+ set x {}
+ set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }]
+ list $a $b $c $x
+ }}
+} {10 4 10 {0 1 3 6}}
+
+test foreacha-2.2 {basic foreacha tests (compiled) - foldl/reduce without initial value} {
+ apply {{} {
+ set x {}
+ set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }]
+ list $a $b $c $x
+ }}
+} {21 6 21 {1 3 6 10 15}}
+
+test foreacha-2.3 {basic foreacha tests (compiled) - filter} {
+ apply {{} {
+ foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } }
+ }}
+} {2 4 6}
+
+test foreacha-2.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} {
+ apply {{} {
+ foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b }
+ }}
+} {1 3 5}
+
+test foreacha-2.4 {basic foreacha tests (compiled) - map} {
+ apply {{} {
+ foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] }
+ }}
+} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}}
+
+test foreacha-2.5 {basic foreacha tests (non-compiled) - prefix (via break)} {
+ apply {{} {
+ foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b }
+ }}
+} {1 2 3 4}
+
+test foreacha-2.6 {basic foreacha tests (compiled) - accumulator doesn't iterate} {
+ apply {{} {
+ set x {}
+ set b [foreacha a {1 2 3 4} { lappend x $a }]
+ list $a $b $x
+ }}
+} {1 1 1}
+
+test foreacha-2.7 {basic foreacha tests (compiled) - accumulator doesn't iterate} {
+ apply {{} {
+ set x {}
+ set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }]
+ list $a $b $c $x
+ }}
+} {10 010 10 {1 0}}
+
+test foreacha-2.8 {basic foreacha tests (compiled) - huge list} {
+ apply {{} {
+ foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b }
+ }}
+} 499999500000
+
+test foreacha-2.9 {basic foreacha tests (compiled) - spaghetti} {
+ apply {{} {
+ foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] {
+ lappend a [expr { $b * $c }]
+ }] {
+ incr a $b
+ }
+ }}
+} 166416500
+
+test foreacha-2.9.1 {basic foreacha tests (compiled) - spaghetti with mapeach} {
+ apply {{} {
+ foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] {
+ expr { $b * $c }
+ }] {
+ incr a $b
+ }
+ }}
+} 166416500
+
+test foreacha-2.10 {basic foreacha tests (compiled) - nested} {
+ apply {{} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }]
+ }
+ }}
+} 332843490
+
+test foreacha-2.10.1 {basic foreacha tests (compiled) - nested with loop var collision} {
+ apply {{} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ foreacha a 10 b [lrepeat $b $b] { incr a $b }
+ }
+ }}
+} 998011
+
+test foreacha-2.10.2 {basic foreacha tests (compiled) - nested, inner non-compiled} {
+ apply {{} {
+ foreacha {a b} [lsearch -all [lrepeat 1000 x] x] {
+ incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]]
+ }
+ }}
+} 332843490
+
+
+
+# cleanup
+catch {unset a}
+catch {unset x}
+catch {rename foo {}}
+::tcltest::cleanupTests
+return
diff --git a/tests/mapeach.test b/tests/mapeach.test
new file mode 100644
index 0000000..9ad9d72
--- /dev/null
+++ b/tests/mapeach.test
@@ -0,0 +1,493 @@
+# 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}
+
+test mapeach-7.9 {error then dereference loop var (dev bug)} {
+ catch { mapeach a 0 b {1 2 3} { error x } }
+ set a
+} 0
+test mapeach-7.9a {error then dereference loop var (dev bug)} {
+ catch { mapeach a 0 b {1 2 3} { incr a $b; error x } }
+ set a
+} 1
+
+# ----- 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
generated by cgit v0.12 at 2024-11-05 07:16:12 (GMT)