summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2010-08-18 15:44:09 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2010-08-18 15:44:09 (GMT)
commit096e06e4b8606abecd8fe11c9919df4f35cf4d52 (patch)
treef997dd6e04e669fc5c94627f3ab580c39c22fc71
parent8288b47f5e7647e90d8499bf5e45099b1651aa62 (diff)
downloadtcl-096e06e4b8606abecd8fe11c9919df4f35cf4d52.zip
tcl-096e06e4b8606abecd8fe11c9919df4f35cf4d52.tar.gz
tcl-096e06e4b8606abecd8fe11c9919df4f35cf4d52.tar.bz2
* generic/tclBasic.c: Redesign of [tailcall] to
* generic/tclCmdAH.c: (a) fix #3047235 * generic/tclCompile.h: (b) enable fix for #3046594 * generic/tclExecute.c: (c) enable recursive tailcalls * generic/tclInt.h: * generic/tclNamesp.c: * tests/tailcall.test:
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c47
-rw-r--r--generic/tclCmdAH.c23
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c39
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclNamesp.c6
-rw-r--r--tests/tailcall.test22
8 files changed, 71 insertions, 87 deletions
diff --git a/ChangeLog b/ChangeLog
index 9c6f136..8105067 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-08-18 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Redesign of [tailcall] to
+ * generic/tclCmdAH.c: (a) fix #3047235
+ * generic/tclCompile.h: (b) enable fix for #3046594
+ * generic/tclExecute.c: (c) enable recursive tailcalls
+ * generic/tclInt.h:
+ * generic/tclNamesp.c:
+ * tests/tailcall.test:
+
2010-08-18 Donal K. Fellows <dkf@users.sf.net>
* library/safe.tcl (AliasGlob): [Bug 3004191]: Restore safe [glob] to
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5fd559d..5b767fe 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.460 2010/08/11 23:13:50 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.461 2010/08/18 15:44:10 msofer Exp $
*/
#include "tclInt.h"
@@ -4398,13 +4398,6 @@ NRCallTEBC(
switch (type) {
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
- case TCL_NR_TAILCALL_TYPE:
- /* For tailcalls */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
- return TCL_ERROR;
case TCL_NR_YIELD_TYPE:
if (iPtr->execEnvPtr->corPtr) {
Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
@@ -8294,14 +8287,12 @@ Tcl_NRCmdSwap(
void
TclSpliceTailcall(
Tcl_Interp *interp,
- TEOV_callback *tailcallPtr,
- int skip)
+ TEOV_callback *tailcallPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
* being tailcalled. Note that we skip NRCommands marked in data[1]
- * (used by command redirectors), and we skip the first command that we
- * find if requested to do so: it corresponds to [tailcall] itself.
+ * (used by command redirectors).
*/
Interp *iPtr = (Interp *) interp;
@@ -8311,10 +8302,7 @@ TclSpliceTailcall(
restart:
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
- if (!skip) {
- break;
- }
- skip = 0;
+ break;
}
}
if (!runPtr) {
@@ -8393,9 +8381,8 @@ TclNRTailcallObjCmd(
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
-
- TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE),
- tailcallPtr, NULL, NULL);
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+
return TCL_OK;
}
@@ -8444,6 +8431,26 @@ TclClearTailcall(
TCLNR_FREE(interp, tailcallPtr);
}
+int
+TclNRBlockTailcall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+ NULL);
+ }
+ return result;
+}
+
void
Tcl_NRAddCallback(
@@ -8612,7 +8619,7 @@ YieldToCallback(
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
- TclSpliceTailcall(interp, cbPtr, 0);
+ TclSpliceTailcall(interp, cbPtr);
return TCL_OK;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 6456bd5..e8a249f 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.124 2010/03/05 14:34:03 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.125 2010/08/18 15:44:12 msofer Exp $
*/
#include "tclInt.h"
@@ -290,13 +290,15 @@ TclNRCatchObjCmd(
optionVarNamePtr = objv[3];
}
+ TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
+ varNamePtr, optionVarNamePtr, NULL);
+ TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
+ NULL);
+
/*
* TIP #280. Make invoking context available to caught script.
*/
- TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
- varNamePtr, optionVarNamePtr, NULL);
-
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
@@ -313,19 +315,6 @@ CatchObjCmdCallback(
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.
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e73ce73..686f508 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.125 2010/04/29 23:39:32 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.126 2010/08/18 15:44:12 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -869,8 +869,7 @@ MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine;
#define TCL_NR_BC_TYPE 0
#define TCL_NR_ATEXIT_TYPE 1
-#define TCL_NR_TAILCALL_TYPE 2
-#define TCL_NR_YIELD_TYPE 3
+#define TCL_NR_YIELD_TYPE 2
/*
*----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 249d748..c3201a5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.489 2010/07/19 14:10:43 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.490 2010/08/18 15:44:12 msofer Exp $
*/
#include "tclInt.h"
@@ -2851,33 +2851,6 @@ TclExecuteByteCode(
OBP = BP;
goto resumeCoroutine;
}
- case TCL_NR_TAILCALL_TYPE:
- /*
- * A request to perform a tailcall: just drop this bytecode.
- */
-
-#ifdef TCL_COMPILE_DEBUG
- if (TAUX.traceInstructions) {
- fprintf(stdout, " Tailcall request received\n");
- }
-#endif /* TCL_COMPILE_DEBUG */
- iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
-
- if (catchTop != initCatchTop) {
- TclClearTailcall(interp, param);
- iPtr->varFramePtr->tailcallPtr = NULL;
- Tcl_SetResult(interp,
- "tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
- NULL);
- pc--;
- goto gotError;
- }
- iPtr->varFramePtr->tailcallPtr = param;
- TclSpliceTailcall(interp, param, 1);
- goto abnormalReturn;
case TCL_NR_YIELD_TYPE: { /* [yield] */
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
@@ -6592,7 +6565,6 @@ TclExecuteByteCode(
returnToCaller:
if (OBP) {
BP = OBP; /* back to old bc */
- rerunCallbacks:
TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
NR_DATA_DIG();
@@ -6618,15 +6590,6 @@ TclExecuteByteCode(
*/
goto nonRecursiveCallSetup;
- case TCL_NR_TAILCALL_TYPE:
- TOP_CB(iPtr) = callbackPtr->nextPtr;
- TCLNR_FREE(interp, callbackPtr);
-
- Tcl_SetResult(interp,
- "tailcall cannot be invoked recursively", TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "REENTRY", NULL);
- TRESULT = TCL_ERROR;
- goto rerunCallbacks;
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3d30581..2f18375 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.479 2010/08/14 17:13:02 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.480 2010/08/18 15:44:12 msofer Exp $
*/
#ifndef _TCLINT
@@ -2759,8 +2759,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
struct TEOV_callback *tailcallPtr);
MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct TEOV_callback *tailcallPtr,
- int skip);
+ struct TEOV_callback *tailcallPtr);
+MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
+
/*
* This structure holds the data for the various iteration callbacks used to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 12fb46e..401eea4 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.209 2010/06/08 12:54:38 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.210 2010/08/18 15:44:13 msofer Exp $
*/
#include "tclInt.h"
@@ -391,6 +391,10 @@ Tcl_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ }
}
/*
diff --git a/tests/tailcall.test b/tests/tailcall.test
index b8a3210..efb5fa4 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tailcall.test,v 1.12 2010/01/22 10:22:51 dkf Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.13 2010/08/18 15:44:13 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -323,7 +323,7 @@ test tailcall-8 {tailcall tailcall} -setup {
namespace eval ::foo c
} -cleanup {
namespace delete ::foo
-} -match glob -result *tailcall* -returnCodes error
+} -result cbac
test tailcall-9 {tailcall factorial} -setup {
proc fact {n {b 1}} {
@@ -557,6 +557,18 @@ test tailcall-12.3b {[Bug 2695587]} {
}}
} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+test tailcall-12.3c {[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-12.3d {[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-13.1 {tailcall and coroutine} -setup {
set lambda {i {
if {$i == 1} {
@@ -573,17 +585,17 @@ test tailcall-13.1 {tailcall and coroutine} -setup {
unset lambda
} -result {0 0 0 0 0 0}
-test tailcall-14.1 {directly tailcalling the tailcall command is an error} {
+test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
list [catch {
apply {{} {
apply {{} {
- tailcall tailcall subst a
+ tailcall tailcall subst ok
subst b
}}
subst c
}}
} msg opt] $msg [errorcode $opt]
-} {1 {tailcall cannot be invoked recursively} {TCL TAILCALL REENTRY}}
+} {0 ok NONE}
test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} {
list [catch {
apply {{} {