summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog4
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdAH.c123
-rw-r--r--generic/tclCmdMZ.c50
-rw-r--r--generic/tclInt.h4
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,
generated by cgit v0.12 at 2024-11-23 05:11:22 (GMT)