diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 47 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 23 | ||||
| -rw-r--r-- | generic/tclCompile.h | 5 | ||||
| -rw-r--r-- | generic/tclExecute.c | 39 | ||||
| -rw-r--r-- | generic/tclInt.h | 7 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 6 | ||||
| -rw-r--r-- | tests/tailcall.test | 22 |
8 files changed, 71 insertions, 87 deletions
@@ -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 {{} { |