Attachment "td-3163961-2.patch" to
ticket [3163961fff]
added by
twylite
2012-07-31 20:37:04.
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,14 @@
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);
+
/*
* Macro that encapsulates an efficiency trick that avoids a function call for
* the simplest of compiles. The ANSI C "prototype" for this macro is:
*
@@ -1868,18 +1872,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 +2102,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 +2143,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 +2202,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 +3765,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/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[]);
@@ -3558,10 +3562,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,
ADDED 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
