From 48251df30f4df754d76577f0bb3f1a230a205ad4 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Thu, 31 Jul 2008 18:29:38 +0000
Subject: nr-enabling [while]

---
 ChangeLog          |  5 ++--
 generic/tclBasic.c |  4 ++--
 generic/tclCmdMZ.c | 69 +++++++++++++++++++++++++++++++++++++-----------------
 generic/tclInt.h   |  4 +++-
 4 files changed, 55 insertions(+), 27 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index eb4b36a..ddbdc23 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,9 @@
 2008-07-31  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c:   NR-enabling [catch] and [if] (the script,
-	* generic/tclCmdAH.c:   not the test)
+	* generic/tclBasic.c:   NR-enabling [catch], [if] and [while] (the
+	* generic/tclCmdAH.c:   script, not the test)
 	* generic/tclCmdIL.c:
+	* generic/tclCmdMZ.c:
 	* generic/tclInt.h:
 	* tests/NRE.test:
 	
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d65d32b..b4a59d5 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.344 2008/07/31 17:32:29 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.345 2008/07/31 18:29:38 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -227,7 +227,7 @@ static const CmdInfo builtInCmds[] = {
     {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	1},
     {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	1},
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
-    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	NULL,	1},
+    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
 
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2777d92..839103e 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,13 +15,16 @@
  * 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.167 2008/07/21 22:22:27 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.168 2008/07/31 18:29:39 msofer Exp $
  */
 
 #include "tclInt.h"
 #include "tclRegexp.h"
 
 static int		UniCharIsAscii(int character);
+
+static Tcl_NRPostProc	NRWhileIterCallback;
+
 
 /*
  *----------------------------------------------------------------------
@@ -4008,38 +4011,60 @@ Tcl_WhileObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int result, value;
-    Interp *iPtr = (Interp *) interp;
+    return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv);    
+}
 
+int
+TclNRWhileObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "test command");
 	return TCL_ERROR;
     }
 
-    while (1) {
-	result = Tcl_ExprBooleanObj(interp, objv[1], &value);
-	if (result != TCL_OK) {
-	    return result;
-	}
-	if (!value) {
-	    break;
-	}
+    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. */
-        result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2);
-	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
-	    if (result == TCL_ERROR) {
-		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-			"\n    (\"while\" body line %d)", interp->errorLine));
-	    }
-	    break;
-	}
+	TclNRAddCallback(interp, NRWhileIterCallback, cond, body, NULL, NULL);
+	return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, 2);
     }
-    if (result == TCL_BREAK) {
+
+  done:    
+    switch (result) {
+    case TCL_BREAK:
 	result = TCL_OK;
-    }
-    if (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;
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9ecea20..a3f6fd2 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.384 2008/07/31 17:32:30 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.385 2008/07/31 18:29:40 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -2530,6 +2530,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
+
 MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
 
 MODULE_SCOPE int        TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
-- 
cgit v0.12