Attachment "mapeach.patch" to
ticket [3163961fff]
added by
twylite
2011-01-22 22:48:09.
Index: tcl/generic/tclBasic.c
===================================================================
--- tcl/generic/tclBasic.c
+++ tcl/generic/tclBasic.c
@@ -237,10 +237,11 @@
{"lreplace", Tcl_LreplaceObjCmd, NULL, 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},
{"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 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},
@@ -830,11 +831,11 @@
TclNRYieldToObjCmd, NULL, NULL);
Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
-
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
@@ -8804,11 +8805,11 @@
Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
-
+
int
NRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Index: tcl/generic/tclCmdAH.c
===================================================================
--- tcl/generic/tclCmdAH.c
+++ tcl/generic/tclCmdAH.c
@@ -32,10 +32,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:
*/
@@ -52,10 +53,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;
@@ -2503,11 +2506,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:
@@ -2535,10 +2538,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)) {
@@ -2577,10 +2612,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.
*/
@@ -2624,11 +2661,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);
}
/*
@@ -2651,24 +2688,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;
@@ -2683,20 +2725,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;
}
@@ -2752,10 +2795,13 @@
if (statePtr->vCopyList[i]) {
TclDecrRefCount(statePtr->vCopyList[i]);
}
if (statePtr->aCopyList[i]) {
TclDecrRefCount(statePtr->aCopyList[i]);
+ }
+ if (statePtr->resultList) {
+ TclDecrRefCount(statePtr->resultList);
}
}
TclStackFree(interp, statePtr);
}
Index: tcl/generic/tclCompCmds.c
===================================================================
--- tcl/generic/tclCompCmds.c
+++ tcl/generic/tclCompCmds.c
@@ -40,10 +40,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:
*
@@ -1579,18 +1583,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;
@@ -1782,10 +1819,26 @@
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.
*/
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
@@ -1805,11 +1858,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);
+ }
+ } else {
+ 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
@@ -1855,15 +1917,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) {
@@ -3203,10 +3274,40 @@
TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
}
}
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);
}
/*
*----------------------------------------------------------------------
*
Index: tcl/generic/tclInt.h
===================================================================
--- tcl/generic/tclInt.h
+++ tcl/generic/tclInt.h
@@ -2742,10 +2742,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 TclNRWhileObjCmd;
@@ -3305,10 +3306,13 @@
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 int Tcl_NamespaceObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
@@ -3491,10 +3495,13 @@
struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileLlengthCmd(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 TclCompileNamespaceCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
