summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog15
-rw-r--r--doc/dict.n29
-rw-r--r--doc/lmap.n85
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclCmdAH.c79
-rw-r--r--generic/tclCompCmds.c191
-rw-r--r--generic/tclDictObj.c244
-rw-r--r--generic/tclInt.h18
-rw-r--r--tests/dict.test262
-rw-r--r--tests/foreach.test9
-rw-r--r--tests/lmap.test464
11 files changed, 1375 insertions, 24 deletions
diff --git a/ChangeLog b/ChangeLog
index 8bb3d5e..bafd366 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,20 @@
2012-10-16 Donal K. Fellows <dkf@users.sf.net>
+ IMPLEMENTATION OF TIP#405
+
+ New commands for applying a transformation to the elements of a list
+ to produce another list (the [lmap] command) and to the mappings of a
+ dictionary to produce another dictionary (the [dict map] command). In
+ both cases, a [continue] will cause the skipping of an element/pair,
+ and a [break] will terminate the construction early and successfully.
+
+ * generic/tclCmdAH.c (Tcl_LmapObjCmd, TclNRLmapCmd): Implementation of
+ the new [lmap] command, based on (and sharing much of) [foreach].
+ * generic/tclDictObj.c (DictMapNRCmd): Implementation of the new [dict
+ map] subcommand, based on (and sharing much of) [dict for].
+ * generic/tclCompCmds.c (TclCompileLmapCmd, TclCompileDictMapCmd):
+ Compilation engines for [lmap] and [dict map].
+
IMPLEMENTATION OF TIP#400
* generic/tclZlib.c: Allow the specification of a compression
diff --git a/doc/dict.n b/doc/dict.n
index 361a112..3bd5530 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -147,6 +147,31 @@ 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 \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR
+.
+This command applies a transformation to each element of a dictionary,
+returning a new dictionary. It takes three arguments: the first is 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 \fBlmap\fR). In an iteration
+where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
+\fBerror\fR, etc.) the result of the script is put into an accumulator
+dictionary using the key that is the current contents of the \fIkeyVar\fR
+variable at that point. The result of the \fBdict map\fB command is the
+accumulator dictionary after all keys have been iterated over.
+.RS
+.PP
+If the evaluation of the body for any particular step generates a \fBbreak\fR,
+no further pairs from the dictionary will be iterated over and the \fBdict
+map\fR command will terminate successfully immediately. If the evaluation of
+the body for a particular step generates a \fBcontinue\fR result, the current
+iteration is aborted and the accumulator dictionary is not modified. The order
+of iteration is the natural order of the dictionary (typically the order in
+which the keys were added to the dictionary; the order is the same as that
+used in \fBdict for\fR).
+.RE
+.TP
\fBdict merge \fR?\fIdictionaryValue ...\fR?
.
Return a dictionary that contains the contents of each of the
@@ -408,9 +433,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/lmap.n b/doc/lmap.n
new file mode 100644
index 0000000..880b05a
--- /dev/null
+++ b/doc/lmap.n
@@ -0,0 +1,85 @@
+'\"
+'\" 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 lmap n "" Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lmap \- Iterate over all elements in one or more lists and collect results
+.SH SYNOPSIS
+\fBlmap \fIvarname list body\fR
+.br
+\fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR
+.BE
+.SH DESCRIPTION
+.PP
+The \fBlmap\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), \fBlmap\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. \fBlmap\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
+set list1 {a b c d}
+set list2 {1 2 3 4}
+set zipped [\fBlmap\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 to remove odd values:
+.PP
+.CS
+set values {1 2 3 4 5 6 7 8}
+proc isEven {n} {expr {($n % 2) == 0}}
+set goodOnes [\fBlmap\fR x $values {expr {
+ [isEven $x] ? $x : [continue]
+}}]
+# The value of goodOnes is "2 4 6 8"
+.CE
+.PP
+Take a prefix from a list based on the contents of the list:
+.PP
+.CS
+set values {8 7 6 5 4 3 2 1}
+proc isGood {counter} {expr {$n > 3}}
+set prefix [\fBlmap\fR x $values {expr {
+ [isGood $x] ? $x : [break]
+}}]
+# The value of prefix is "8 7 6 5 4"
+.CE
+.SH "SEE ALSO"
+break(n), continue(n), for(n), foreach(n), while(n)
+.SH KEYWORDS
+foreach, iteration, list, loop, map
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index db365e3..7c08f2f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -230,6 +230,7 @@ static const CmdInfo builtInCmds[] = {
{"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1},
+ {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1},
@@ -8852,7 +8853,7 @@ NRCoroInjectObjCmd(
return TCL_OK;
}
-
+
int
TclNRInterpCoroutine(
ClientData clientData,
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 5ca5cf8..14951e4 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -32,6 +32,9 @@ 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,
+ * or NULL if we're not collecting them
+ * ([lmap] vs [foreach]). */
};
/*
@@ -52,6 +55,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 inline int EachloopCmd(Tcl_Interp *interp, int collect,
+ int objc, Tcl_Obj *const objv[]);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ExprCallback;
static Tcl_NRPostProc ForSetupCallback;
@@ -2565,7 +2570,7 @@ ForPostNextCallback(
/*
*----------------------------------------------------------------------
*
- * Tcl_ForeachObjCmd, TclNRForeachCmd --
+ * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd --
*
* This object-based procedure is invoked to process the "foreach" Tcl
* command. See the user documentation for details on what it does.
@@ -2597,6 +2602,38 @@ TclNRForeachCmd(
int objc,
Tcl_Obj *const objv[])
{
+ return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv);
+}
+
+int
+Tcl_LmapObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv);
+}
+
+int
+TclNRLmapCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
+}
+
+static inline int
+EachloopCmd(
+ Tcl_Interp *interp, /* Our context for variables and script
+ * evaluation. */
+ int collect, /* Select collecting or accumulating mode
+ * (TCL_EACH_*) */
+ int objc, /* The arguments being passed in... */
+ Tcl_Obj *const objv[])
+{
int numLists = (objc-2) / 2;
register struct ForeachState *statePtr;
int i, j, result;
@@ -2640,6 +2677,12 @@ TclNRForeachCmd(
statePtr->bodyPtr = objv[objc - 1];
statePtr->bodyIdx = objc - 1;
+ if (collect == TCL_EACH_COLLECT) {
+ statePtr->resultList = Tcl_NewListObj(0, NULL);
+ } else {
+ statePtr->resultList = NULL;
+ }
+
/*
* Break up the value lists and variable lists into elements.
*/
@@ -2653,9 +2696,11 @@ TclNRForeachCmd(
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "foreach varlist is empty", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s varlist is empty",
+ (statePtr->resultList != NULL ? "lmap" : "foreach")));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+ (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
"NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
@@ -2725,14 +2770,21 @@ ForeachLoopStep(
switch (result) {
case TCL_CONTINUE:
result = TCL_OK;
+ break;
case TCL_OK:
+ if (statePtr->resultList != NULL) {
+ 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)));
+ "\n (\"%s\" body line %d)",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
+ Tcl_GetErrorLine(interp)));
default:
goto done;
}
@@ -2757,7 +2809,14 @@ ForeachLoopStep(
* We're done. Tidy up our work space and finish off.
*/
- Tcl_ResetResult(interp);
+ finish:
+ if (statePtr->resultList == NULL) {
+ Tcl_ResetResult(interp);
+ } else {
+ Tcl_SetObjResult(interp, statePtr->resultList);
+ statePtr->resultList = NULL; /* Don't clean it up */
+ }
+
done:
ForeachCleanup(interp, statePtr);
return result;
@@ -2790,7 +2849,8 @@ ForeachAssignments(
if (varValuePtr == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (setting foreach loop variable \"%s\")",
+ "\n (setting %s loop variable \"%s\")",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
TclGetString(statePtr->varvList[i][v])));
return TCL_ERROR;
}
@@ -2819,6 +2879,9 @@ ForeachCleanup(
TclDecrRefCount(statePtr->aCopyList[i]);
}
}
+ if (statePtr->resultList != NULL) {
+ TclDecrRefCount(statePtr->resultList);
+ }
TclStackFree(interp, statePtr);
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 3540716..61f7988 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 CompileEachloopCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ CompileEnv *envPtr, int collect);
+static int CompileDictEachCmd(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,42 @@ TclCompileDictForCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_KEEP_NONE);
+}
+
+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 CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+int
+CompileDictEachCmd(
+ 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 == TCL_EACH_COLLECT to collect and
+ * construct a new dictionary with the 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 collectVar = -1; /* Index of temp var holding the result
+ * dict. */
int savedStackDepth = envPtr->currStackDepth;
/* Needed because jumps confuse the stack
* space calculator. */
@@ -815,6 +854,19 @@ TclCompileDictForCmd(
}
/*
+ * Create temporary variable to capture return values from loop body when
+ * we're collecting results.
+ */
+
+ if (collect == TCL_EACH_COLLECT) {
+ collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
+ envPtr);
+ if (collectVar < 0) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
* Check we've got a pair of variables and that they are local variables.
* Then extract their indices in the LVT.
*/
@@ -867,8 +919,18 @@ TclCompileDictForCmd(
* Preparation complete; issue instructions. Note that this code issues
* fixed-sized jumps. That simplifies things a lot!
*
- * First up, get the dictionary and start the iteration. No catching of
- * errors at this point.
+ * First up, initialize the accumulator dictionary if needed.
+ */
+
+ if (collect == TCL_EACH_COLLECT) {
+ PushLiteral(envPtr, "", 0);
+ Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+
+ /*
+ * Get the dictionary and start the iteration. No catching of errors at
+ * this point.
*/
CompileWord(envPtr, dictTokenPtr, interp, 3);
@@ -908,6 +970,13 @@ TclCompileDictForCmd(
SetLineInformation(3);
CompileBody(envPtr, bodyTokenPtr, interp);
+ if (collect == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_DICT_SET, 1, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
TclEmitOpcode( INST_POP, envPtr);
/*
@@ -956,6 +1025,10 @@ TclCompileDictForCmd(
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
+ if (collect == TCL_EACH_COLLECT) {
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ }
TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
@@ -971,18 +1044,24 @@ TclCompileDictForCmd(
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, 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 == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ } else {
+ PushLiteral(envPtr, "", 0);
+ }
return TCL_OK;
}
@@ -1870,6 +1949,39 @@ TclCompileForeachCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_KEEP_NONE);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileEachloopCmd --
+ *
+ * Procedure called to compile the "foreach" and "lmap" 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
+CompileEachloopCmd(
+ 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 +1990,9 @@ TclCompileForeachCmd(
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
+ int collectVar = -1; /* Index of temp var holding the result var
+ * index. */
+
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
@@ -1993,6 +2108,14 @@ TclCompileForeachCmd(
loopIndex++;
}
+ if (collect == TCL_EACH_COLLECT) {
+ collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
+ envPtr);
+ if (collectVar < 0) {
+ return TCL_ERROR;
+ }
+ }
+
/*
* We will compile the foreach command. Reserve (numLists + 1) temporary
* variables:
@@ -2069,6 +2192,16 @@ TclCompileForeachCmd(
}
/*
+ * Create temporary variable to capture return values from loop body.
+ */
+
+ if (collect == TCL_EACH_COLLECT) {
+ PushLiteral(envPtr, "", 0);
+ Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+
+ /*
* Initialize the temporary var that holds the count of loop iterations.
*/
@@ -2092,6 +2225,10 @@ TclCompileForeachCmd(
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
+
+ if (collect == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr);
+ }
TclEmitOpcode( INST_POP, envPtr);
/*
@@ -2142,11 +2279,18 @@ 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 (collect == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ } else {
+ PushLiteral(envPtr, "", 0);
+ }
envPtr->currStackDepth = savedStackDepth + 1;
done:
@@ -3700,6 +3844,37 @@ TclCompileLsetCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileLmapCmd --
+ *
+ * Procedure called to compile the "lmap" 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 "lmap" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLmapCmd(
+ 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 CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileNamespaceCmd --
*
* Procedure called to compile the "namespace" command; currently, only
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index b5c7ac0..d1087b2 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -76,9 +76,12 @@ static int FinalizeDictWith(ClientData data[],
Tcl_Interp *interp, int result);
static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
+static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
static int DictForLoopCallback(ClientData data[],
Tcl_Interp *interp, int result);
-
+static int DictMapLoopCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
/*
* Table of dict subcommand names and implementations.
@@ -95,6 +98,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 },
@@ -181,6 +185,23 @@ static const Tcl_HashKeyType chainHashType = {
AllocChainEntry,
TclFreeObjEntry
};
+
+/*
+ * Structure used in implementation of 'dict map' to hold the state that gets
+ * passed between parts of the implementation.
+ */
+
+typedef struct {
+ Tcl_Obj *keyVarObj; /* The name of the variable that will have
+ * keys assigned to it. */
+ Tcl_Obj *valueVarObj; /* The name of the variable that will have
+ * values assigned to it. */
+ Tcl_DictSearch search; /* The dictionary search structure. */
+ Tcl_Obj *scriptObj; /* The script to evaluate each time through
+ * the loop. */
+ Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the
+ * results. */
+} DictMapStorage;
/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
@@ -2336,7 +2357,7 @@ DictAppendCmd(
*
* DictForNRCmd --
*
- * This function implements the "dict for" Tcl command. See the user
+ * These functions implement the "dict for" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
@@ -2489,13 +2510,15 @@ DictForLoopCallback(
*/
Tcl_IncrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
result = TCL_ERROR;
goto done;
}
TclDecrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
goto done;
}
@@ -2524,6 +2547,217 @@ DictForLoopCallback(
/*
*----------------------------------------------------------------------
*
+ * DictMapNRCmd --
+ *
+ * These functions implement the "dict map" Tcl command. See the user
+ * documentation for details on what it does, and TIP#405 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictMapNRCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj **varv, *keyObj, *valueObj;
+ DictMapStorage *storagePtr;
+ int varc, done;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "{keyVar valueVar} dictionary script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse arguments.
+ */
+
+ if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (varc != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
+ return TCL_ERROR;
+ }
+ storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
+ if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
+ &valueObj, &done) != TCL_OK) {
+ TclStackFree(interp, storagePtr);
+ return TCL_ERROR;
+ }
+ if (done) {
+ /*
+ * Note that this exit leaves an empty value in the result (due to
+ * command calling conventions) but that is OK since an empty value is
+ * an empty dictionary.
+ */
+
+ TclStackFree(interp, storagePtr);
+ return TCL_OK;
+ }
+ TclNewObj(storagePtr->accumulatorObj);
+ TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ storagePtr->keyVarObj = varv[0];
+ storagePtr->valueVarObj = varv[1];
+ storagePtr->scriptObj = objv[3];
+
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish. Note that the dictionary internal rep is locked
+ * internally so that updates, shimmering, etc are not a problem.
+ */
+
+ Tcl_IncrRefCount(storagePtr->accumulatorObj);
+ Tcl_IncrRefCount(storagePtr->keyVarObj);
+ Tcl_IncrRefCount(storagePtr->valueVarObj);
+ Tcl_IncrRefCount(storagePtr->scriptObj);
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ goto error;
+ }
+ if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ goto error;
+ }
+ TclDecrRefCount(valueObj);
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
+ return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
+ iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything on error.
+ */
+
+ error:
+ TclDecrRefCount(storagePtr->keyVarObj);
+ TclDecrRefCount(storagePtr->valueVarObj);
+ TclDecrRefCount(storagePtr->scriptObj);
+ TclDecrRefCount(storagePtr->accumulatorObj);
+ Tcl_DictObjDone(&storagePtr->search);
+ TclStackFree(interp, storagePtr);
+ return TCL_ERROR;
+}
+
+static int
+DictMapLoopCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ DictMapStorage *storagePtr = data[0];
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"dict map\" body line %d)",
+ Tcl_GetErrorLine(interp)));
+ }
+ goto done;
+ } else {
+ keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (keyObj == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj,
+ Tcl_GetObjResult(interp));
+ }
+
+ /*
+ * Get the next mapping from the dictionary.
+ */
+
+ Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done);
+ if (done) {
+ Tcl_SetObjResult(interp, storagePtr->accumulatorObj);
+ goto done;
+ }
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclDecrRefCount(valueObj);
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
+ return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
+ iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ done:
+ TclDecrRefCount(storagePtr->keyVarObj);
+ TclDecrRefCount(storagePtr->valueVarObj);
+ TclDecrRefCount(storagePtr->scriptObj);
+ TclDecrRefCount(storagePtr->accumulatorObj);
+ Tcl_DictObjDone(&storagePtr->search);
+ TclStackFree(interp, storagePtr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DictSetCmd --
*
* This function implements the "dict set" Tcl command. See the user
@@ -3446,7 +3680,7 @@ TclInitDictCmd(
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6c6e664..c716ed2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2487,6 +2487,14 @@ typedef struct List {
(((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
/*
+ * Modes for collecting (or not) in the implementations of TclNRForeachCmd,
+ * TclNRLmapCmd and their compilations.
+ */
+
+#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
+#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
+
+/*
* Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
* Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
*
@@ -2778,6 +2786,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
@@ -3346,6 +3355,9 @@ MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3496,6 +3508,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);
@@ -3556,6 +3571,9 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/tests/dict.test b/tests/dict.test
index 77bacf6..aa22c00 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1521,6 +1521,268 @@ 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} -setup {
+ set values {}
+ set keys {}
+} -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}
+ dict map {k v} $dictv {
+ lappend keys $k
+ lappend values $v
+ }
+ 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} -setup {
+ set keys {}
+ set values {}
+} -body {
+ set dictVar {a b c d e f g h}
+ list [dict size [dict map {k v} $dictVar {
+ if {[llength $dictVar]} {
+ lappend keys $k
+ lappend values $v
+ return -level 0 $k
+ }
+ }]] [lsort $keys] [lsort $values]
+} -cleanup {
+ unset dictVar keys values k v
+} -result {4 {a c e g} {b d f h}}
+test dict-24.14a {dict map command: handle representation loss} -body {
+ apply {{} {
+ set dictVar {a b c d e f g h}
+ list [dict size [dict map {k v} $dictVar {
+ if {[llength $dictVar]} {
+ lappend keys $k
+ lappend values $v
+ return -level 0 $k
+ }
+ }]] [lsort $keys] [lsort $values]
+ }}
+} -result {4 {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 {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"
+ }
+} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,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"
+ }
+ }}
+} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,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}
+} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
+test dict-24.24 {dict map with huge dict (non-compiled)} {
+ tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] {
+ expr { $k * $v }
+ }]
+} 166666666600000
+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 }
+ }]
+ }} 100000
+} 166666666600000
+
# 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/lmap.test b/tests/lmap.test
new file mode 100644
index 0000000..7baa77b
--- /dev/null
+++ b/tests/lmap.test
@@ -0,0 +1,464 @@
+# Commands covered: lmap, 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 {"::tcltest" ni [namespace children]} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+unset -nocomplain a i x
+
+# ----- Non-compiled operation -----------------------------------------------
+
+# Basic "lmap" operation (non-compiled)
+test lmap-1.1 {basic lmap tests} {
+ set a {}
+ lmap i {a b c d} {
+ set a [concat $a $i]
+ }
+} {a {a b} {a b c} {a b c d}}
+test lmap-1.2 {basic lmap tests} {
+ lmap i {a b {{c d} e} {123 {{x}}}} {
+ set i
+ }
+} {a b {{c d} e} {123 {{x}}}}
+test lmap-1.2a {basic lmap tests} {
+ lmap i {a b {{c d} e} {123 {{x}}}} {
+ return -level 0 $i
+ }
+} {a b {{c d} e} {123 {{x}}}}
+test lmap-1.4 {basic lmap tests} -returnCodes error -body {
+ lmap
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-1.6 {basic lmap tests} -returnCodes error -body {
+ lmap i
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-1.8 {basic lmap tests} -returnCodes error -body {
+ lmap i j
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-1.10 {basic lmap tests} -returnCodes error -body {
+ lmap i j k l
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-1.11 {basic lmap tests} {
+ lmap i {} {
+ set i
+ }
+} {}
+test lmap-1.12 {basic lmap tests} {
+ lmap i {} {
+ return -level 0 x
+ }
+} {}
+test lmap-1.13 {lmap errors} -returnCodes error -body {
+ lmap {{a}{b}} {1 2 3} {}
+} -result {list element in braces followed by "{b}" instead of space}
+test lmap-1.14 {lmap errors} -returnCodes error -body {
+ lmap a {{1 2}3} {}
+} -result {list element in braces followed by "3" instead of space}
+unset -nocomplain a
+test lmap-1.15 {lmap errors} -setup {
+ unset -nocomplain a
+} -body {
+ set a(0) 44
+ list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
+} -result {1 {can't set "a": variable is array} {can't set "a": variable is array
+ (setting lmap loop variable "a")
+ invoked from within
+"lmap a {1 2 3} {}"}}
+test lmap-1.16 {lmap errors} -returnCodes error -body {
+ lmap {} {} {}
+} -result {lmap varlist is empty}
+unset -nocomplain a
+
+# Parallel "lmap" operation (non-compiled)
+test lmap-2.1 {parallel lmap tests} {
+ lmap {a b} {1 2 3 4} {
+ list $b $a
+ }
+} {{2 1} {4 3}}
+test lmap-2.2 {parallel lmap tests} {
+ lmap {a b} {1 2 3 4 5} {
+ list $b $a
+ }
+} {{2 1} {4 3} {{} 5}}
+test lmap-2.3 {parallel lmap tests} {
+ lmap a {1 2 3} b {4 5 6} {
+ list $b $a
+ }
+} {{4 1} {5 2} {6 3}}
+test lmap-2.4 {parallel lmap tests} {
+ lmap a {1 2 3} b {4 5 6 7 8} {
+ list $b $a
+ }
+} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
+test lmap-2.5 {parallel lmap tests} {
+ lmap {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 lmap-2.6 {parallel lmap tests} {
+ lmap 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 lmap-2.7 {parallel lmap tests} {
+ lmap 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 lmap-2.8 {parallel lmap tests} {
+ lmap 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 lmap-2.9 {lmap only sets vars if repeating loop} {
+ namespace eval ::lmap_test {
+ set rgb {65535 0 0}
+ lmap {r g b} [set rgb] {}
+ set ::x "r=$r, g=$g, b=$b"
+ }
+ namespace delete ::lmap_test
+ set x
+} {r=65535, g=0, b=0}
+test lmap-2.10 {lmap only supports local scalar variables} -setup {
+ unset -nocomplain a
+} -body {
+ lmap {a(3)} {1 2 3 4} {set {a(3)}}
+} -result {1 2 3 4}
+unset -nocomplain a
+
+# "lmap" with "continue" and "break" (non-compiled)
+test lmap-3.1 {continue tests} {
+ lmap i {a b c d} {
+ if {[string compare $i "b"] == 0} continue
+ set i
+ }
+} {a c d}
+test lmap-3.2 {continue tests} {
+ set x 0
+ list [lmap i {a b c d} {
+ incr x
+ if {[string compare $i "b"] != 0} continue
+ set i
+ }] $x
+} {b 4}
+test lmap-3.3 {break tests} {
+ set x 0
+ list [lmap 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 lmap-3.4 {break tests} {
+ set a 1
+ lmap b b {list [concat a; break]; incr a}
+ incr a
+} {2}
+
+# ----- Compiled operation ---------------------------------------------------
+
+# Basic "lmap" operation (compiled)
+test lmap-4.1 {basic lmap tests} {
+ apply {{} {
+ set a {}
+ lmap i {a b c d} {
+ set a [concat $a $i]
+ }
+ }}
+} {a {a b} {a b c} {a b c d}}
+test lmap-4.2 {basic lmap tests} {
+ apply {{} {
+ lmap i {a b {{c d} e} {123 {{x}}}} {
+ set i
+ }
+ }}
+} {a b {{c d} e} {123 {{x}}}}
+test lmap-4.2a {basic lmap tests} {
+ apply {{} {
+ lmap i {a b {{c d} e} {123 {{x}}}} {
+ return -level 0 $i
+ }
+ }}
+} {a b {{c d} e} {123 {{x}}}}
+test lmap-4.4 {basic lmap tests} -returnCodes error -body {
+ apply {{} { lmap }}
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-4.6 {basic lmap tests} -returnCodes error -body {
+ apply {{} { lmap i }}
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-4.8 {basic lmap tests} -returnCodes error -body {
+ apply {{} { lmap i j }}
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-4.10 {basic lmap tests} -returnCodes error -body {
+ apply {{} { lmap i j k l }}
+} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
+test lmap-4.11 {basic lmap tests} {
+ apply {{} { lmap i {} { set i } }}
+} {}
+test lmap-4.12 {basic lmap tests} {
+ apply {{} { lmap i {} { return -level 0 x } }}
+} {}
+test lmap-4.13 {lmap errors} -returnCodes error -body {
+ apply {{} { lmap {{a}{b}} {1 2 3} {} }}
+} -result {list element in braces followed by "{b}" instead of space}
+test lmap-4.14 {lmap errors} -returnCodes error -body {
+ apply {{} { lmap a {{1 2}3} {} }}
+} -result {list element in braces followed by "3" instead of space}
+unset -nocomplain a
+test lmap-4.15 {lmap errors} {
+ apply {{} {
+ set a(0) 44
+ list [catch {lmap 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
+"lmap a {1 2 3} {}"}}
+test lmap-4.16 {lmap errors} -returnCodes error -body {
+ apply {{} {
+ lmap {} {} {}
+ }}
+} -result {lmap varlist is empty}
+unset -nocomplain a
+
+# Parallel "lmap" operation (compiled)
+test lmap-5.1 {parallel lmap tests} {
+ apply {{} {
+ lmap {a b} {1 2 3 4} {
+ list $b $a
+ }
+ }}
+} {{2 1} {4 3}}
+test lmap-5.2 {parallel lmap tests} {
+ apply {{} {
+ lmap {a b} {1 2 3 4 5} {
+ list $b $a
+ }
+ }}
+} {{2 1} {4 3} {{} 5}}
+test lmap-5.3 {parallel lmap tests} {
+ apply {{} {
+ lmap a {1 2 3} b {4 5 6} {
+ list $b $a
+ }
+ }}
+} {{4 1} {5 2} {6 3}}
+test lmap-5.4 {parallel lmap tests} {
+ apply {{} {
+ lmap a {1 2 3} b {4 5 6 7 8} {
+ list $b $a
+ }
+ }}
+} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
+test lmap-5.5 {parallel lmap tests} {
+ apply {{} {
+ lmap {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 lmap-5.6 {parallel lmap tests} {
+ apply {{} {
+ lmap 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 lmap-5.7 {parallel lmap tests} {
+ apply {{} {
+ lmap 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 lmap-5.8 {parallel lmap tests} {
+ apply {{} {
+ lmap 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 lmap-5.9 {lmap only sets vars if repeating loop} {
+ apply {{} {
+ set rgb {65535 0 0}
+ lmap {r g b} [set rgb] {}
+ return "r=$r, g=$g, b=$b"
+ }}
+} {r=65535, g=0, b=0}
+test lmap-5.10 {lmap only supports local scalar variables} {
+ apply {{} {
+ lmap {a(3)} {1 2 3 4} {set {a(3)}}
+ }}
+} {1 2 3 4}
+
+# "lmap" with "continue" and "break" (compiled)
+test lmap-6.1 {continue tests} {
+ apply {{} {
+ lmap i {a b c d} {
+ if {[string compare $i "b"] == 0} continue
+ set i
+ }
+ }}
+} {a c d}
+test lmap-6.2 {continue tests} {
+ apply {{} {
+ list [lmap i {a b c d} {
+ incr x
+ if {[string compare $i "b"] != 0} continue
+ set i
+ }] $x
+ }}
+} {b 4}
+test lmap-6.3 {break tests} {
+ apply {{} {
+ list [lmap 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 lmap-6.4 {break tests} {
+ apply {{} {
+ set a 1
+ lmap b b {list [concat a; break]; incr a}
+ incr a
+ }}
+} {2}
+
+# ----- Special cases and bugs -----------------------------------------------
+test lmap-7.1 {compiled lmap backward jump works correctly} -setup {
+ unset -nocomplain x
+} -body {
+ array set x {0 zero 1 one 2 two 3 three}
+ lsort [apply {{arrayName} {
+ upvar 1 $arrayName a
+ lmap member [array names a] {
+ list $member [set a($member)]
+ }
+ }} x]
+} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}]
+test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup {
+ unset -nocomplain x
+} -body {
+ lmap {12.0} {a b c} {
+ set x 12.0
+ set x [expr $x + 1]
+ }
+} -result {13.0 13.0 13.0}
+# Test for incorrect "double evaluation" semantics
+test lmap-7.3 {delayed substitution of body} {
+ apply {{} {
+ set a 0
+ lmap a [list 1 2 3] "
+ set x $a
+ "
+ return $x
+ }}
+} {0}
+# Related to "foreach" test for [Bug 1189274]; crash on failure
+test lmap-7.4 {empty list handling} {
+ proc crash {} {
+ rename crash {}
+ set a "x y z"
+ set b ""
+ lmap 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 lmap-7.5 {compiled empty var list} -returnCodes error -body {
+ proc foo {} {
+ lmap {} x {
+ error "reached body"
+ }
+ }
+ foo
+} -cleanup {
+ catch {rename foo ""}
+} -result {lmap varlist is empty}
+test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup {
+ proc demo {} {
+ set vals {1 2 3 4}
+ trace add variable x write {string length $vals ;# }
+ lmap {x y} $vals {format $y}
+ }
+} -body {
+ demo
+} -cleanup {
+ rename demo {}
+} -result {2 4}
+# Huge lists must not overflow the bytecode interpreter (development bug)
+test lmap-7.7 {huge list non-compiled} {
+ set x [lmap a [lrepeat 1000000 x] { set b y$a }]
+ list $b [llength $x] [string length $x]
+} {yx 1000000 2999999}
+test lmap-7.8 {huge list compiled} {
+ set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000]
+ list $b [llength $x] [string length $x]
+} {yx 1000000 2999999}
+test lmap-7.9 {error then dereference loop var (dev bug)} {
+ catch { lmap a 0 b {1 2 3} { error x } }
+ set a
+} 0
+test lmap-7.9a {error then dereference loop var (dev bug)} {
+ catch { lmap a 0 b {1 2 3} { incr a $b; error x } }
+ set a
+} 1
+
+# ----- Coroutines -----------------------------------------------------------
+test lmap-8.1 {lmap non-compiled with coroutines} -body {
+ coroutine coro apply {{} {
+ set values [yield [info coroutine]]
+ eval lmap 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]
+} -cleanup {
+ catch {rename coro ""}
+} -result {{1 2 3 4 5 6} {}}
+test lmap-8.2 {lmap compiled with coroutines} -body {
+ coroutine coro apply {{} {
+ set values [yield [info coroutine]]
+ lmap 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]
+} -cleanup {
+ catch {rename coro ""}
+} -result {{1 2 3 4 5 6} {}}
+
+# cleanup
+unset -nocomplain a x
+catch {rename foo {}}
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-11-16 18:48:45 (GMT)