summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-07-31 15:42:06 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-07-31 15:42:06 (GMT)
commitcad03f83809878b3802167f7b8cd219012690cc8 (patch)
treec1cd6fe19b292b68cd8a7fb589a5d7753ab2367f
parent0a80549aa57439939e05b98b8471c00b2af09b49 (diff)
downloadtcl-cad03f83809878b3802167f7b8cd219012690cc8.zip
tcl-cad03f83809878b3802167f7b8cd219012690cc8.tar.gz
tcl-cad03f83809878b3802167f7b8cd219012690cc8.tar.bz2
* generic/tclBasic.c: NR-enabling [catch]
* generic/tclCmdAH.c: * generic/tclInt.h: * tests/NRE.test:
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdAH.c33
-rw-r--r--generic/tclInt.h3
-rw-r--r--tests/NRE.test19
5 files changed, 57 insertions, 7 deletions
diff --git a/ChangeLog b/ChangeLog
index 506acf3..87d8e5a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
#