NRE-enable non-compiled [foreach]. [Bug 2017632]

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;