summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdMZ.c69
-rw-r--r--generic/tclInt.h4
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,