diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 69 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 |
4 files changed, 55 insertions, 27 deletions
@@ -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, |