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

3 files changed, 211 insertions, 105 deletions

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;