summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog85
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdAH.c309
-rw-r--r--generic/tclInt.h3
4 files changed, 257 insertions, 144 deletions
diff --git a/ChangeLog b/ChangeLog
index c70f1d1..bdbda13 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-08-24 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdAH.c (TclNRForeachCmd): Converted the [foreach]
+ command to have an NRE-aware non-compiled implementation. Part of the
+ [Bug 2017632] project. Also restructured the code so as to manage its
+ temporary memory more efficiently.
+
2008-08-23 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c: Removed unused var; fixed function
@@ -27,19 +34,19 @@
* changes: Updates for 8.6a2 release.
- * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added
- indirection without value. Use -DCONST86="" to engage source compat
+ * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added
+ indirection without value. Use -DCONST86="" to engage source compat
support for code written for 8.5 headers.
* generic/tclUtil.c (TclReToGlob): Added missing set of the
- *exactPtr value to really fix [Bug 2065115]. Also avoid possible
+ *exactPtr value to really fix [Bug 2065115]. Also avoid possible
DString overflow.
* tests/regexpComp.test: Correct duplicate test names.
2008-08-21 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c: Previous fix, now done right.
- * generic/tclCmdIL.c:
+ * generic/tclCmdIL.c:
* generic/tclInt.h:
* tests/unsupported.test:
@@ -55,7 +62,7 @@
* generic/tcl.decls: the use of CONST86_RETURN to support source
code compatibility with Tcl 8.5 on those public routines passing
(Tcl_Filesystem *), (Tcl_Timer *), and (Tcl_Objtype *) values which
- have been const-ified. What remains is the minimum configurability
+ have been const-ified. What remains is the minimum configurability
needed to support code written for pre-8.6 headers via the new
-DUSE_COMPAT85_CONST compiler directive.
*** POTENTIAL INCOMPATIBILITY ***
@@ -178,7 +185,7 @@
2008-08-08 Don Porter <dgp@users.sourceforge.net>S
* generic/tclOOMethod.c (PushMethodCallFrame): Added missing check
- for bytecode validity. [Bug 2037727]
+ for bytecode validity. [Bug 2037727]
* generic/tclProc.c (TclProcCompileProc): On recompile of a
proc, clear away any entries on the CompiledLocal list from the
@@ -365,9 +372,9 @@
* generic/tclBasic.c: Revised timing of the CmdFrame stack management
* tests/info.test: in TclEvalEx so that the CmdFrame will still
be on the stack at the time Tcl_LogCommandInfo is called to append
- another level of -errorinfo information. Sets the stage to add
- file and line data to the stack trace. Added test to check that
- [info frame] functioning remains unchanged by the revision.
+ another level of -errorinfo information. Sets the stage to add file
+ and line data to the stack trace. Added test to check that [info
+ frame] functioning remains unchanged by the revision.
2008-07-31 Miguel Sofer <msofer@users.sf.net>
@@ -961,7 +968,7 @@
* generic/tclPathObj.c: Fixed some internals management in the "path"
Tcl_ObjType for the empty string value. Problem led to a crash in the
- command [glob -dir {} a]. [Bug 1999176].
+ command [glob -dir {} a]. [Bug 1999176]
2008-06-24 Pat Thoyts <patthoyts@users.sourceforge.net>
@@ -1475,7 +1482,7 @@
2008-04-14 Kevin B. Kenny <kennykb@acm.org>
* unix/tclUnixTime.c (NativeGetTime): Removed obsolete use of
- 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197].
+ 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197]
* tests/clock.test (clock-33.5, clock-33.5a, clock-33.8, clock-33.8a):
Added comments to the test that it can fail on a heavily loaded
@@ -1512,10 +1519,10 @@
* generic/tclIOCmd.c (Tcl_FcopyObjCmd): Added checking of -size value
* tests/ioCmd.test (iocmd-15.{13,14}): to reject negative values, and
- values overflowing 32-bit signed. [Bug 1557855]. Basic patch by
- Alexandre Ferrieux <ferrieux@users.sourceforge.net>, with
- modifications from me to separate overflow from true negative value.
- Extended testsuite.
+ values overflowing 32-bit signed. Basic patch by Alexandre Ferrieux
+ <ferrieux@users.sourceforge.net>, with modifications from me to
+ separate overflow from true negative value. Extended testsuite. [Bug
+ 1557855]
2008-04-09 Daniel Steffen <das@users.sourceforge.net>
@@ -1549,8 +1556,8 @@
* generic/tclIO.c (BUSY_STATE, CheckChannelErrors, TclCopyChannel):
New macro, and the places using it. This change allows for
- bi-directional fcopy on channels. [Bug 1350564]. Thanks to Alexandre
- Ferrieux <ferrieux@users.sourceforge.net> for the patch.
+ bi-directional fcopy on channels. Thanks to Alexandre Ferrieux
+ <ferrieux@users.sourceforge.net> for the patch. [Bug 1350564]
2008-04-07 Reinhard Max <max@suse.de>
@@ -1664,7 +1671,7 @@
* generic/tclBasic.c: Revised stubs-generation tool and interp
* tools/genStubs.tcl: creation so that "tclStubsPtr" is not present
* unix/Makefile.in: in libtcl.so, but is present only in
- * win/Makefile.in: libtclstub.a. This tightens up the rules for
+ * win/Makefile.in: libtclstub.a. This tightens up the rules for
* win/makefile.bc: users of the stubs interfaces. [Bug 1819422]
* win/makefile.vc:
@@ -1802,10 +1809,10 @@
2008-03-18 Andreas Kupries <andreask@activestate.com>
* library/tm.tcl (::tcl::tm::Defaults): Modified handling of
- environment variables. See [Bug 1914604]. Solution slightly different
- than proposed in the report. Using the underscored form TCLX_y_TM_PATH
- even if TCLX.y_TM_PATH exists. Also using a loop to cut prevent code
- replication.
+ environment variables. Solution slightly different than proposed in
+ the report. Using the underscored form TCLX_y_TM_PATH even if
+ TCLX.y_TM_PATH exists. Also using a loop to cut prevent code
+ replication. [Bug 1914604]
2008-03-16 Donal K. Fellows <dkf@users.sf.net>
@@ -1992,7 +1999,7 @@
* generic/tclResult.c (Tcl_SetReturnOptions): Revised the refcount
management of Tcl_SetReturnOptions to become that of a conventional
- Consumer routine. Thanks to Peter Spjuth for pointing out the
+ Consumer routine. Thanks to Peter Spjuth for pointing out the
difficulties calling Tcl_SetReturnOptions with non-0-count value for
options.
* generic/tclExecute.c (INST_RETURN_STK): Revised the one caller
@@ -2018,7 +2025,7 @@
* unix/tclUnixChan.c, unix/tclUnixNotfy.c, unix/tclUnixPipe.c:
Consolidate all code conditionalized on -DUSE_FIONBIO into one place.
* unix/tclUnixPort.h, unix/tclUnixCompat.c: New routine
- TclUnixSetBlockingMode() [Patch 1903339].
+ TclUnixSetBlockingMode(). [Patch 1903339]
2008-02-28 Don Porter <dgp@users.sourceforge.net>
@@ -2059,7 +2066,7 @@
* generic/tclIOUtil.c, unix/tclUnixPort.h, unix/tclUnixChan.c:
Remove dead/unused portability-related #defines and unused conditional
- code. See [Patch 1901828] for discussion.
+ code. See [Patch 1901828] for discussion.
2008-02-26 Joe English <jenglish@users.sourceforge.net>
@@ -2319,7 +2326,7 @@
2007-12-21 Miguel Sofer <msofer@users.sf.net>
- * generic/tclCmdIL.c: Speed patch for lsort [Patch 1856994].
+ * generic/tclCmdIL.c: Speed patch for lsort. [Patch 1856994]
2007-12-21 Miguel Sofer <msofer@users.sf.net>
@@ -2343,8 +2350,8 @@
* generic/tclCompCmds.c (TclCompileSwitchCmd): update switch -regexp
* tests/switch.test-14.*: compilation to pass
- the cflags to INST_REGEXP (changed on 12-07). Added tests for
- switch -regexp compilation (need more). [Bug 1854399]
+ the cflags to INST_REGEXP (changed on 12-07). Added tests for switch
+ -regexp compilation (need more). [Bug 1854399]
2007-12-18 Don Porter <dgp@users.sourceforge.net>
@@ -2396,8 +2403,8 @@
2007-12-12 Don Porter <dgp@users.sourceforge.net>
* doc/IntObj.3: Update docs for the Tcl_GetBignumAndClearObj() ->
- Tcl_TakeBignumFromObj() revision [TIP 298]. Added docs for the
- Tcl_InitBignumFromDouble() routine. [Bug 1446971].
+ Tcl_TakeBignumFromObj() revision [TIP 298]. Added docs for the
+ Tcl_InitBignumFromDouble() routine. [Bug 1446971]
* changes: Updated for 8.5.0 release.
@@ -2472,11 +2479,11 @@
2007-12-06 Don Porter <dgp@users.sourceforge.net>
* README: Remove mention of dead comp.lang.tcl.announce
- newsgroup. [Bug 1846433].
+ newsgroup. [Bug 1846433]
* unix/README: Mention the stub library created by `make` and warn
about the effect of embedded paths in the installed binaries.
- Thanks to Larry Virden. [Bug 1794084]
+ Thanks to Larry Virden. [Bug 1794084]
* doc/AddErrInfo.3: Documentation for the new routines in TIP 270.
* doc/Interp.3:
@@ -2509,7 +2516,7 @@
2007-12-05 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIO.h: Create Tcl_Obj for Tcl channels to reduce
- * generic/tclIO.c: overhead in lookup by Tcl_GetChannel. New
+ * generic/tclIO.c: overhead in lookup by Tcl_GetChannel. New
* generic/tclIOCmd.c: TclGetChannelFromObj for internal use.
* generic/tclIO.c (WriteBytes, WriteChars): add opt check to avoid
EOL translation when not linebuffered or using lf. [Bug 1845092]
@@ -4910,8 +4917,8 @@
* library/msgs/ja.msg:
* tools/loadICU.tcl: Corrected several localisation faults in the
Japanese locale (most notably, incorrect dates for the Emperors'
- eras). [Bug 1637471]. Many thanks to SourceForge user 'nyademo' for
- pointing this out and developing a fix.
+ eras). Many thanks to SourceForge user 'nyademo' for pointing this out
+ and developing a fix. [Bug 1637471]
* generic/tclPathObj.c: Corrected a 'const'ness fault that caused
bitter complaints from MSVC.
* tests/clock.test (clock-40.1, clock-58.1, clock-59.1): Corrected a
@@ -5987,7 +5994,7 @@
* tests/event.test (event-14.*): Corrected a bug where
TclUnixWaitForFile would present select() with the wrong mask on an
LP64 machine if a fd number exceeds 32. Thanks to Jean-Luc Fontaine
- for reporting and diagnosing [Bug 1602208].
+ for reporting and diagnosing. [Bug 1602208]
2006-11-27 Don Porter <dgp@users.sourceforge.net>
@@ -7496,9 +7503,9 @@
* generic/tclProc.c (ProcCompileProc): When a bump of the compile
epoch forces the re-compile of a proc body, take care not to overwrite
- any Proc struct that may be referred to on the active call stack. This
- fixes [Bug 1482718]. Note that the fix will not be effective for code
- that calls the private routine TclProcCompileProc() directly.
+ any Proc struct that may be referred to on the active call stack. Note
+ that the fix will not be effective for code that calls the private
+ routine TclProcCompileProc() directly. [Bug 1482718]
2006-05-13 Daniel Steffen <das@users.sourceforge.net>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3eb9908..68b32bb 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.362 2008/08/23 18:53:09 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.363 2008/08/24 14:38:08 dkf Exp $
*/
#include "tclInt.h"
@@ -177,7 +177,7 @@ static const CmdInfo builtInCmds[] = {
{"eval", Tcl_EvalObjCmd, NULL, NULL, 1},
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, NULL, 1},
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
- {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, NULL, 1},
+ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
{"format", Tcl_FormatObjCmd, NULL, NULL, 1},
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 8e26dcf..272cb20 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,13 +10,33 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.102 2008/08/17 19:37:11 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.103 2008/08/24 14:38:11 dkf Exp $
*/
#include "tclInt.h"
#include <locale.h>
/*
+ * The state structure used by [foreach]. Note that the actual structure has
+ * all its working arrays appended afterwards so they can be allocated and
+ * freed in a single step.
+ */
+
+struct ForeachState {
+ Tcl_Obj *bodyPtr; /* The script body of the command. */
+ int bodyIdx; /* The argument index of the body. */
+ int j, maxj; /* Number of loop iterations. */
+ int numLists; /* Count of value lists. */
+ int *index; /* Array of value list indices. */
+ int *varcList; /* # loop variables per list. */
+ 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. */
+};
+
+/*
* Prototypes for local procedures defined in this file:
*/
@@ -25,6 +45,10 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
static int EncodingDirsObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static inline int ForeachAssignments(Tcl_Interp *interp,
+ struct ForeachState *statePtr);
+static inline void ForeachCleanup(Tcl_Interp *interp,
+ struct ForeachState *statePtr);
static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
static char * GetTypeFromMode(int mode);
@@ -32,8 +56,7 @@ static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ForNextCallback;
-
-
+static Tcl_NRPostProc ForeachLoopStep;
/*
*----------------------------------------------------------------------
@@ -1639,7 +1662,6 @@ Tcl_ForObjCmd(
return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv);
}
-
int
TclNRForObjCmd(
ClientData dummy, /* Not used. */
@@ -1760,7 +1782,7 @@ ForNextCallback(
/*
*----------------------------------------------------------------------
*
- * Tcl_ForeachObjCmd --
+ * Tcl_ForeachObjCmd, TclNRForeachCmd --
*
* This object-based procedure is invoked to process the "foreach" Tcl
* command. See the user documentation for details on what it does.
@@ -1782,21 +1804,19 @@ Tcl_ForeachObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int result = TCL_OK;
- int i; /* i selects a value list */
- int j, maxj; /* Number of loop iterations */
- int v; /* v selects a loop variable */
- int numLists = (objc-2)/2; /* Count of value lists */
- Tcl_Obj *bodyPtr;
- Interp *iPtr = (Interp *) interp;
+ return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv);
+}
- int *index; /* Array of value list indices */
- int *varcList; /* # loop variables per list */
- 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 */
+int
+TclNRForeachCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int numLists = (objc-2) / 2;
+ register struct ForeachState *statePtr;
+ int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1806,129 +1826,214 @@ Tcl_ForeachObjCmd(
/*
* Manage numList parallel value lists.
- * argvList[i] is a value list counted by argcList[i]l;
- * varvList[i] is the list of variables associated with the value list;
- * varcList[i] is the number of variables associated with the value list;
- * index[i] is the current pointer into the value list argvList[i].
+ * statePtr->argvList[i] is a value list counted by statePtr->argcList[i];
+ * statePtr->varvList[i] is the list of variables associated with the
+ * value list;
+ * statePtr->varcList[i] is the number of variables associated with the
+ * value list;
+ * statePtr->index[i] is the current pointer into the value list
+ * statePtr->argvList[i].
+ *
+ * The setting up of all of these pointers is moderately messy, but allows
+ * the rest of this code to be simple and for us to use a single memory
+ * allocation for better performance.
*/
- index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int));
- varcList = index + numLists;
- argcList = varcList + numLists;
- memset(index, 0, 3 * numLists * sizeof(int));
-
- varvList = (Tcl_Obj ***)
- TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **));
- argvList = varvList + numLists;
- memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **));
-
- vCopyList = (Tcl_Obj **)
- TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *));
- aCopyList = vCopyList + numLists;
- memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *));
+ statePtr = TclStackAlloc(interp,
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
+ memset(statePtr, 0,
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
+ statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
+ statePtr->argvList = statePtr->varvList + numLists;
+ statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists);
+ statePtr->aCopyList = statePtr->vCopyList + numLists;
+ statePtr->index = (int *) (statePtr->aCopyList + numLists);
+ statePtr->varcList = statePtr->index + numLists;
+ statePtr->argcList = statePtr->varcList + numLists;
+
+ statePtr->numLists = numLists;
+ statePtr->bodyPtr = objv[objc - 1];
+ statePtr->bodyIdx = objc - 1;
/*
* Break up the value lists and variable lists into elements.
*/
- maxj = 0;
for (i=0 ; i<numLists ; i++) {
-
- vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
- if (vCopyList[i] == NULL) {
+ statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
+ if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]);
- if (varcList[i] < 1) {
+ TclListObjGetElements(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i], &statePtr->varvList[i]);
+ if (statePtr->varcList[i] < 1) {
Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
result = TCL_ERROR;
goto done;
}
- aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (aCopyList[i] == NULL) {
+ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]);
+ TclListObjGetElements(NULL, statePtr->aCopyList[i],
+ &statePtr->argcList[i], &statePtr->argvList[i]);
- j = argcList[i] / varcList[i];
- if ((argcList[i] % varcList[i]) != 0) {
+ j = statePtr->argcList[i] / statePtr->varcList[i];
+ if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
}
- if (j > maxj) {
- maxj = j;
+ if (j > statePtr->maxj) {
+ statePtr->maxj = j;
}
}
/*
- * Iterate maxj times through the lists in parallel. If some value lists
- * run out of values, set loop vars to ""
+ * If there is any work to do, assign the variables and set things going
+ * non-recursively.
*/
- bodyPtr = objv[objc-1];
- for (j=0 ; j<maxj ; j++) {
- for (i=0 ; i<numLists ; i++) {
- for (v=0 ; v<varcList[i] ; v++) {
- int k = index[i]++;
- Tcl_Obj *valuePtr, *varValuePtr;
+ if (statePtr->maxj > 0) {
+ result = ForeachAssignments(interp, statePtr);
+ if (result == TCL_ERROR) {
+ goto done;
+ }
- if (k < argcList[i]) {
- valuePtr = argvList[i][k];
- } else {
- valuePtr = Tcl_NewObj(); /* Empty string */
- }
- varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
- valuePtr, TCL_LEAVE_ERR_MSG);
- if (varValuePtr == NULL) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (setting foreach loop variable \"%s\")",
- TclGetString(varvList[i][v])));
- result = TCL_ERROR;
- goto done;
- }
- }
+ TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, objv[objc-1], 0,
+ ((Interp *) interp)->cmdFramePtr, objc-1);
+ }
+
+ /*
+ * This cleanup stage is only used when an error occurs during setup or if
+ * there is no work to do.
+ */
+
+ result = TCL_OK;
+ done:
+ ForeachCleanup(interp, statePtr);
+ return result;
+}
+
+/*
+ * Post-body processing handler.
+ */
+
+static int
+ForeachLoopStep(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ register struct ForeachState *statePtr = data[0];
+
+ /*
+ * 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;
+ case TCL_OK:
+ break;
+ case TCL_BREAK:
+ result = TCL_OK;
+ goto done;
+ case TCL_ERROR:
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"foreach\" body line %d)", interp->errorLine));
+ default:
+ goto done;
+ }
+
+ /*
+ * Test if there is work still to be done. If so, do the next round of
+ * variable assignments, reschedule ourselves and run the body again.
+ */
+
+ if (statePtr->maxj > ++statePtr->j) {
+ result = ForeachAssignments(interp, statePtr);
+ if (result == TCL_ERROR) {
+ goto done;
}
- /*
- * TIP #280. Make invoking context available to loop body.
- */
+ TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, statePtr->bodyPtr, 0,
+ ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
+ }
- result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1);
- if (result != TCL_OK) {
- if (result == TCL_CONTINUE) {
- result = TCL_OK;
- } else if (result == TCL_BREAK) {
- result = TCL_OK;
- break;
- } else if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"foreach\" body line %d)",
- interp->errorLine));
- break;
+ /*
+ * We're done. Tidy up our work space and finish off.
+ */
+
+ Tcl_ResetResult(interp);
+ done:
+ ForeachCleanup(interp, statePtr);
+ return result;
+}
+
+/*
+ * Factored out code to do the assignments in [foreach].
+ */
+
+static inline int
+ForeachAssignments(
+ Tcl_Interp *interp,
+ struct ForeachState *statePtr)
+{
+ int i, v, k;
+ Tcl_Obj *valuePtr, *varValuePtr;
+
+ for (i=0 ; i<statePtr->numLists ; i++) {
+ for (v=0 ; v<statePtr->varcList[i] ; v++) {
+ k = statePtr->index[i]++;
+
+ if (k < statePtr->argcList[i]) {
+ valuePtr = statePtr->argvList[i][k];
} else {
- break;
+ TclNewObj(valuePtr); /* Empty string */
+ }
+
+ varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+
+ if (varValuePtr == NULL) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (setting foreach loop variable \"%s\")",
+ TclGetString(statePtr->varvList[i][v])));
+ return TCL_ERROR;
}
}
}
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- }
- done:
- for (i=0 ; i<numLists ; i++) {
- if (vCopyList[i]) {
- Tcl_DecrRefCount(vCopyList[i]);
+ return TCL_OK;
+}
+
+/*
+ * Factored out code for cleaning up the state of the foreach.
+ */
+
+static inline void
+ForeachCleanup(
+ Tcl_Interp *interp,
+ struct ForeachState *statePtr)
+{
+ int i;
+
+ for (i=0 ; i<statePtr->numLists ; i++) {
+ if (statePtr->vCopyList[i]) {
+ TclDecrRefCount(statePtr->vCopyList[i]);
}
- if (aCopyList[i]) {
- Tcl_DecrRefCount(aCopyList[i]);
+ if (statePtr->aCopyList[i]) {
+ TclDecrRefCount(statePtr->aCopyList[i]);
}
}
- TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */
- TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */
- TclStackFree(interp, index); /* int arrays */
- return result;
+ TclStackFree(interp, statePtr);
}
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f5b7ba5..f9a53a9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.395 2008/08/23 11:35:52 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.396 2008/08/24 14:38:11 dkf Exp $
*/
#ifndef _TCLINT
@@ -2557,6 +2557,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
generated by cgit v0.12 at 2024-07-08 10:49:16 (GMT)