nr-enabling [for]; [while] made to reuse [for]'s infrastructure.

5 files changed, 101 insertions, 84 deletions

diff --git a/ChangeLog b/ChangeLog
index ddbdc23..fa4893f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,7 @@
 2008-07-31  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c:   NR-enabling [catch], [if] and [while] (the
-	* generic/tclCmdAH.c:   script, not the test)
+	* generic/tclBasic.c:   NR-enabling [catch], [if] and [for] and 
+	* generic/tclCmdAH.c:   [while] (the script, not the tests)
 	* generic/tclCmdIL.c:
 	* generic/tclCmdMZ.c:
 	* generic/tclInt.h:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b4a59d5..019de9c 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.345 2008/07/31 18:29:38 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.346 2008/07/31 20:01:38 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -190,7 +190,7 @@ static const CmdInfo builtInCmds[] = {
     {"error",		Tcl_ErrorObjCmd,	NULL,			NULL,	1},
     {"eval",		Tcl_EvalObjCmd,		NULL,			NULL,	1},
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	NULL,	1},
-    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	NULL,	1},
+    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	NULL,	1},
     {"format",		Tcl_FormatObjCmd,	NULL,			NULL,	1},
     {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 409d633..868b0b8 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,7 @@
  * 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.100 2008/07/31 15:42:06 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.101 2008/07/31 20:01:39 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -31,6 +31,7 @@ static char *		GetTypeFromMode(int mode);
 static int		StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
 			    Tcl_StatBuf *statPtr);
 static Tcl_NRPostProc	CatchObjCmdCallback;
+static Tcl_NRPostProc	ForNextCallback;
 
 
 
@@ -1635,7 +1636,18 @@ Tcl_ForObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int result, value;
+    return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv);    
+}
+
+
+int
+TclNRForObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    int result;
     Interp *iPtr = (Interp *) interp;
 
     if (objc != 5) {
@@ -1654,55 +1666,94 @@ Tcl_ForObjCmd(
 	}
 	return result;
     }
-    while (1) {
-	/*
-	 * We need to reset the result before passing it off to
-	 * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
-	 * to the result of the last evaluation.
-	 */
 
-	Tcl_ResetResult(interp);
-	result = Tcl_ExprBooleanObj(interp, objv[2], &value);
-	if (result != TCL_OK) {
-	    return result;
-	}
-	if (!value) {
-	    break;
-	}
+    TclNRAddCallback(interp, TclNRForIterCallback, objv[2], objv[4],
+	    objv[3], "\n    (\"for\" body line %d)");
+    return TCL_OK;
+}
 
-	/*
-	 * TIP #280. Make invoking context available to loop body.
-	 */
+int
+TclNRForIterCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *cond = data[0];
+    Tcl_Obj *body = data[1];
+    Tcl_Obj *next = data[2];
+    char *msg = data[3];
+    int value;
 
-	result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4);
-	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
-	    if (result == TCL_ERROR) {
-		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-			"\n    (\"for\" body line %d)", interp->errorLine));
-	    }
-	    break;
+    if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
+	goto done;
+    }
+
+    /*
+     * We need to reset the result before passing it off to
+     * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
+     * to the result of the last evaluation.
+     */
+    
+    Tcl_ResetResult(interp);
+    result = Tcl_ExprBooleanObj(interp, cond, &value);
+    if (result != TCL_OK) {
+	return result;
+    }
+    if (value) {
+	/* TIP #280. */
+	if (next) {
+	    TclNRAddCallback(interp, ForNextCallback, cond, body, next, msg);
+	} else {
+	    TclNRAddCallback(interp, TclNRForIterCallback, cond, body, NULL, msg);
 	}
+	return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, 2);
+    }
+
+  done:    
+    switch (result) {
+    case TCL_BREAK:
+	result = TCL_OK;
+    case TCL_OK:
+	Tcl_ResetResult(interp);
+	break;
+    case TCL_ERROR:
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(msg, interp->errorLine));
+    }
+    return result;
+}
 
+static int
+ForNextCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *cond = data[0];
+    Tcl_Obj *body = data[1];
+    Tcl_Obj *next = data[2];
+    char *msg = data[3];
+
+    
+    if (result == TCL_OK) {
 	/*
 	 * TIP #280. Make invoking context available to next script.
+	 *
+	 * NRE: we let the next script run in a new TEBC instance, ie, it is
+	 * not nr-enabled.
 	 */
 
-	result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
-	if (result == TCL_BREAK) {
-	    break;
-	} else if (result != TCL_OK) {
+	result = TclEvalObjEx(interp, next, 0, iPtr->cmdFramePtr, 3);
+	if ((result != TCL_BREAK) && (result != TCL_OK)) {
 	    if (result == TCL_ERROR) {
 		Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
 	    }
 	    return result;
 	}
     }
-    if (result == TCL_BREAK) {
-	result = TCL_OK;
-    }
-    if (result == TCL_OK) {
-	Tcl_ResetResult(interp);
-    }
+    
+    TclNRAddCallback(interp, TclNRForIterCallback, cond, body, next, msg);
     return result;
 }
 
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 839103e..227e7b8 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.168 2008/07/31 18:29:39 msofer Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.169 2008/07/31 20:01:40 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -23,8 +23,6 @@
 
 static int		UniCharIsAscii(int character);
 
-static Tcl_NRPostProc	NRWhileIterCallback;
-
 
 /*
  *----------------------------------------------------------------------
@@ -4026,47 +4024,13 @@ TclNRWhileObjCmd(
 	return TCL_ERROR;
     }
 
-    TclNRAddCallback(interp, NRWhileIterCallback, objv[1], objv[2], NULL, NULL);
-    return TCL_CONTINUE;
-}
-
-static int
-NRWhileIterCallback(
-    ClientData data[],
-    Tcl_Interp *interp,
-    int result)
-{
-    Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *cond = data[0];
-    Tcl_Obj *body = data[1];
-    int value;
-
-    if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
-	goto done;
-    }
-	    
-    result = Tcl_ExprBooleanObj(interp, cond, &value);
-    if (result != TCL_OK) {
-	return result;
-    }
-    if (value) {
-	/* TIP #280. */
-	TclNRAddCallback(interp, NRWhileIterCallback, cond, body, NULL, NULL);
-	return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, 2);
-    }
+    /*
+     * We reuse [for]'s callback, passing a NULL for the 'next' script.
+     */
 
-  done:    
-    switch (result) {
-    case TCL_BREAK:
-	result = TCL_OK;
-    case TCL_OK:
-	Tcl_ResetResult(interp);
-	break;
-    case TCL_ERROR:
-	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		    "\n    (\"while\" body line %d)", interp->errorLine));
-    }
-    return result;
+    TclNRAddCallback(interp, TclNRForIterCallback, objv[1], objv[2],
+	    NULL, "\n    (\"while\" body line %d)");
+    return TCL_OK;
 }
 
 /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a3f6fd2..31114e9 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.385 2008/07/31 18:29:40 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.386 2008/07/31 20:01:40 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -2529,9 +2529,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
+MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
 MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
 
 MODULE_SCOPE int        TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,