diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 33 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | tests/NRE.test | 19 |
5 files changed, 57 insertions, 7 deletions
@@ -1,5 +1,10 @@ 2008-07-31 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: NR-enabling [catch] + * generic/tclCmdAH.c: + * generic/tclInt.h: + * tests/NRE.test: + * generic/tclBasic.c: Moved the few remaining defs from * generic/tclDictObj.c: tclNRE.h to tclInt.h, eliminated * generic/tclExecute.c: inclusion of tclNRE.h everywhere. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8ffdcef..754d464 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.342 2008/07/31 14:43:43 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.343 2008/07/31 15:42:06 msofer Exp $ */ #include "tclInt.h" @@ -184,7 +184,7 @@ static const CmdInfo builtInCmds[] = { #ifndef EXCLUDE_OBSOLETE_COMMANDS {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, #endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, NULL, 1}, + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, {"error", Tcl_ErrorObjCmd, NULL, NULL, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6f4778b..409d633 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.99 2008/07/21 22:50:34 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.100 2008/07/31 15:42:06 msofer Exp $ */ #include "tclInt.h" @@ -30,6 +30,9 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static Tcl_NRPostProc CatchObjCmdCallback; + + /* *---------------------------------------------------------------------- @@ -228,9 +231,18 @@ Tcl_CatchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, dummy, objc, objv); +} + +int +TclNRCatchObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Obj *varNamePtr = NULL; Tcl_Obj *optionVarNamePtr = NULL; - int result; Interp *iPtr = (Interp *) interp; if ((objc < 2) || (objc > 4)) { @@ -250,8 +262,23 @@ Tcl_CatchObjCmd( * TIP #280. Make invoking context available to caught script. */ - result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); + Tcl_NRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc), + varNamePtr, optionVarNamePtr, NULL); + + return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); +} +static int +CatchObjCmdCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int objc = PTR2INT(data[0]); + Tcl_Obj *varNamePtr = data[1]; + Tcl_Obj *optionVarNamePtr = data[2]; + + /* * We disable catch in interpreters where the limit has been exceeded. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index a098b5f..6941f18 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.382 2008/07/31 14:43:45 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.383 2008/07/31 15:42:07 msofer Exp $ */ #ifndef _TCLINT @@ -2528,6 +2528,7 @@ MODULE_SCOPE char tclEmptyString; MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd; MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr, diff --git a/tests/NRE.test b/tests/NRE.test index b80eed8..dfa6f59 100644 --- a/tests/NRE.test +++ b/tests/NRE.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: NRE.test,v 1.8 2008/07/31 03:42:17 msofer Exp $ +# RCS: @(#) $Id: NRE.test,v 1.9 2008/07/31 15:42:08 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -285,6 +285,23 @@ test NRE-6.2 {[uplevel] is not recursive} -setup { rename a {} } -result {0 20001} +test NRE-7.1 {[catch] is not recursive} -setup { + proc a i { + variable x [depthDiff] + if {[incr i] > 10} { + return + } + uplevel 1 [list catch "a $i"] + } +} -body { + catch {a 0} + lrange $x 0 3 +} -cleanup { + rename a {} + unset x +} -result {0 3 3 0} + + # # Basic TclOO tests # |