From d9e5311f467b0b01c8aa09875bd1bae9eafe91dc Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Thu, 31 Jul 2008 20:01:33 +0000 Subject: nr-enabling [for]; [while] made to reuse [for]'s infrastructure. --- ChangeLog | 4 +- generic/tclBasic.c | 4 +- generic/tclCmdAH.c | 123 +++++++++++++++++++++++++++++++++++++---------------- generic/tclCmdMZ.c | 50 +++------------------- generic/tclInt.h | 4 +- 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 - * 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, -- cgit v0.12