? CORODIFF1.tmp
? DIFF
? DIFF.notest
? DIFF.testonly
? YIELDTO.diff
? tail
? yieldto.tip
? generic/tclBasic.c.CVS
? generic/tclExecute.c.1
? generic/tclExecute.c.CVS
? pkgs/itcl/itclConfig.sh
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.460
diff -u -r1.460 tclBasic.c
--- generic/tclBasic.c 11 Aug 2010 23:13:50 -0000 1.460
+++ generic/tclBasic.c 17 Aug 2010 23:43:00 -0000
@@ -8310,6 +8310,9 @@
restart:
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->procPtr == TclNRBlockTailcall) {
+ break;
+ }
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
if (!skip) {
break;
@@ -8333,8 +8336,19 @@
Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
}
- tailcallPtr->nextPtr = runPtr->nextPtr;
- runPtr->nextPtr = tailcallPtr;
+ if (runPtr->procPtr == TclNRBlockTailcall) {
+ /*
+ * Attempting to tailcall out of a catch or try exception block: this
+ * is an error. Mark the blocker and clear the tailcallPtr.
+ */
+
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ TclClearTailcall(interp, tailcallPtr);
+ runPtr->data[0] = INT2PTR(1);
+ } else {
+ tailcallPtr->nextPtr = runPtr->nextPtr;
+ runPtr->nextPtr = tailcallPtr;
+ }
if (eePtr) {
/*
@@ -8444,6 +8458,32 @@
TCLNR_FREE(interp, tailcallPtr);
}
+int
+TclNRBlockTailcall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ int blocked = (data[0] != NULL);
+
+ if (blocked) {
+ /*
+ * A tailcall tried to escape this block, it is an error.
+ */
+
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ Tcl_SetResult(interp,
+ "tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+ NULL);
+ result = TCL_ERROR;
+ }
+
+ return result;
+}
+
void
Tcl_NRAddCallback(
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.124
diff -u -r1.124 tclCmdAH.c
--- generic/tclCmdAH.c 5 Mar 2010 14:34:03 -0000 1.124
+++ generic/tclCmdAH.c 17 Aug 2010 23:43:00 -0000
@@ -291,11 +291,18 @@
}
/*
- * TIP #280. Make invoking context available to caught script.
+ * Add the callback to post-process the script's result and a blocker for
+ * tailcalls: you cannot tailcall out of a catch block.
*/
TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
varNamePtr, optionVarNamePtr, NULL);
+ TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
+ NULL);
+
+ /*
+ * TIP #280. Make invoking context available to caught script.
+ */
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
@@ -313,19 +320,6 @@
int rewind = iPtr->execEnvPtr->rewind;
/*
- * catch has to disable any tailcall
- */
-
- if (iPtr->varFramePtr->tailcallPtr) {
- TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
- iPtr->varFramePtr->tailcallPtr = NULL;
- result = TCL_ERROR;
- Tcl_SetResult(interp,"Tailcall called from within a catch environment",
- TCL_STATIC);
- }
-
-
- /*
* We disable catch in interpreters where the limit has been exceeded.
*/
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.479
diff -u -r1.479 tclInt.h
--- generic/tclInt.h 14 Aug 2010 17:13:02 -0000 1.479
+++ generic/tclInt.h 17 Aug 2010 23:43:05 -0000
@@ -2761,6 +2761,7 @@
MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
struct TEOV_callback *tailcallPtr,
int skip);
+MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
/*
* This structure holds the data for the various iteration callbacks used to
Index: tests/tailcall.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/tailcall.test,v
retrieving revision 1.12
diff -u -r1.12 tailcall.test
--- tests/tailcall.test 22 Jan 2010 10:22:51 -0000 1.12
+++ tests/tailcall.test 17 Aug 2010 23:43:05 -0000
@@ -557,6 +557,18 @@
}}
} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+test tailcall-12.3c {[Bug 3046594]} {
+ apply {{} {
+ list [[subst catch] [list tailcall foo] msg opt] $msg [errorcode $opt]
+ }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+
+test tailcall-12.3d {[Bug 3046594]} {
+ apply {{} {
+ list [[subst catch] {tailcall foo} msg opt] $msg [errorcode $opt]
+ }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+
test tailcall-13.1 {tailcall and coroutine} -setup {
set lambda {i {
if {$i == 1} {
