diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 141 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 6 | ||||
| -rw-r--r-- | generic/tclExecute.c | 21 | ||||
| -rw-r--r-- | generic/tclInt.h | 16 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 19 | ||||
| -rw-r--r-- | tests/tailcall.test | 100 |
8 files changed, 136 insertions, 180 deletions
@@ -1,3 +1,12 @@ +2010-08-30 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: New implementation for [tailcall]: + * generic/tclCmdAH.c: it now schedules the command and returns + * generic/tclCmdMZ.c: TCL_RETURN. This fixes all issues with + * generic/tclExecute.c: [catch] and [try] - [Bug 3046594], + * generic/tclInt.h: [Bug 3047235] and [Bug 3048771]. Thanks + * generic/tclNamesp.c: dgp for exploring the dark corners. + * tests/tailcall.test: More thorough testing is required. + 2010-08-30 Jan Nijtmans <nijtmans@users.sf.net> * win/Makefile.in: [Freq 2965056]: Windows build with -DUNICODE diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5216f96..6769211 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.463 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.464 2010/08/30 14:02:09 msofer Exp $ */ #include "tclInt.h" @@ -167,10 +167,6 @@ static Tcl_NRPostProc YieldToCallback; static void ClearTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); -static int SpliceTailcall(Tcl_Interp *interp, - struct TEOV_callback *tailcallPtr, - int skip); - MODULE_SCOPE const TclStubs tclStubs; @@ -8291,30 +8287,10 @@ Tcl_NRCmdSwap( * FIXME NRE! */ -void TclRemoveTailcall( - Tcl_Interp *interp) -{ - TEOV_callback *runPtr, *tailcallPtr; - - for (runPtr = TOP_CB(interp); runPtr->nextPtr; runPtr = runPtr->nextPtr) { - if (runPtr->nextPtr->procPtr == NRTailcallEval) { - break; - } - } - if (!runPtr->nextPtr) { - Tcl_Panic("TclRemoveTailcall did not find a tailcall"); - } - - tailcallPtr = runPtr->nextPtr; - runPtr->nextPtr = tailcallPtr->nextPtr; - ClearTailcall(interp, tailcallPtr); -} - -static int -SpliceTailcall( +void +TclSpliceTailcall( Tcl_Interp *interp, - TEOV_callback *tailcallPtr, - int skip) + TEOV_callback *tailcallPtr) { /* * Find the splicing spot: right before the NRCommand of the thing @@ -8322,53 +8298,19 @@ SpliceTailcall( * (used by command redirectors). */ - Interp *iPtr = (Interp *) interp; TEOV_callback *runPtr; - runPtr = TOP_CB(interp); - if (skip) { - while (runPtr && (runPtr != iPtr->varFramePtr->wherePtr)) { - if ((runPtr->procPtr) == TclNRBlockTailcall) { - ClearTailcall(interp, tailcallPtr); - Tcl_SetResult(interp,"tailcall called from within a catch environment", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", - NULL); - return TCL_ERROR; - } - runPtr = runPtr->nextPtr; - } - } - - restart: - for (; runPtr; runPtr = runPtr->nextPtr) { + for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { break; } } if (!runPtr) { - /* - * If we are tailcalling out of a coroutine, the splicing spot is in - * the caller's execEnv: go find it! - */ - - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (corPtr) { - runPtr = corPtr->callerEEPtr->callbackPtr; - goto restart; - } - - Tcl_SetResult(interp, - "tailcall cannot find the right splicing spot: should not happen!", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "UNKNOWN", NULL); - return TCL_ERROR; + Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } tailcallPtr->nextPtr = runPtr->nextPtr; runPtr->nextPtr = tailcallPtr; - return TCL_OK; } int @@ -8379,18 +8321,13 @@ TclNRTailcallObjCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; - TEOV_callback *tailcallPtr; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); return TCL_ERROR; } - if (!iPtr->varFramePtr->isProcCallFrame || /* is not a body */ - (iPtr->framePtr != iPtr->varFramePtr)) { /* or is upleveled */ + if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ Tcl_SetResult(interp, "tailcall can only be called from a proc or lambda", TCL_STATIC); @@ -8398,33 +8335,45 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); + /* + * Invocation without args just clears a scheduled tailcall; invocation + * with an argument replaces any previously scheduled tailcall. + */ - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); + if (iPtr->varFramePtr->tailcallPtr) { + ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; } - Tcl_IncrRefCount(nsObjPtr); /* * Create the callback to actually evaluate the tailcalled - * command, then pass it to tebc so that it is stashed at the proper - * place. Being lazy: exploit the TclNRAddCallBack macro to build the - * callback. + * command, then set it in the varFrame so that PopCallFrame can use it + * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to + * build the callback. */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); - tailcallPtr = TOP_CB(interp); - TOP_CB(interp) = tailcallPtr->nextPtr; + if (objc > 1) { + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; + TEOV_callback *tailcallPtr; + + listPtr = Tcl_NewListObj(objc-1, objv+1); + Tcl_IncrRefCount(listPtr); - if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) { - return TCL_ERROR; + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("Tailcall failed to find the proper namespace"); + } + Tcl_IncrRefCount(nsObjPtr); + + TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); + tailcallPtr = TOP_CB(interp); + TOP_CB(interp) = tailcallPtr->nextPtr; + iPtr->varFramePtr->tailcallPtr = tailcallPtr; } - - iPtr->varFramePtr->isProcCallFrame |= FRAME_TAILCALLING; - return TCL_OK; + return TCL_RETURN; } int @@ -8484,15 +8433,6 @@ ClearTailcall( TCLNR_FREE(interp, tailcallPtr); } -int -TclNRBlockTailcall( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - return result; -} - void Tcl_NRAddCallback( @@ -8661,7 +8601,7 @@ YieldToCallback( cbPtr = TOP_CB(interp); TOP_CB(interp) = cbPtr->nextPtr; - SpliceTailcall(interp, cbPtr, 0); + TclSpliceTailcall(interp, cbPtr); return TCL_OK; } @@ -9042,7 +8982,6 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - iPtr->evalFlags |= TCL_EVAL_REDIRECT; iPtr->lookupNsPtr = nsPtr; TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index e8a249f..7ef3bec 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.125 2010/08/18 15:44:12 msofer Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.126 2010/08/30 14:02:09 msofer Exp $ */ #include "tclInt.h" @@ -292,8 +292,6 @@ TclNRCatchObjCmd( TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc), varNamePtr, optionVarNamePtr, NULL); - TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL, - NULL); /* * TIP #280. Make invoking context available to caught script. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b844dae..7690649 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -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: tclCmdMZ.c,v 1.213 2010/08/18 15:54:06 msofer Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.214 2010/08/30 14:02:09 msofer Exp $ */ #include "tclInt.h" @@ -4274,13 +4274,11 @@ TclNRTryObjCmd( } /* - * Execute the body; block tailcalling out of it. + * Execute the body. */ Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, (ClientData)objv, INT2PTR(objc)); - TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL, - NULL); return TclNREvalObjEx(interp, bodyObj, 0, ((Interp *) interp)->cmdFramePtr, 1); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4970443..2664558 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.492 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.493 2010/08/30 14:02:09 msofer Exp $ */ #include "tclInt.h" @@ -2901,25 +2901,6 @@ TclExecuteByteCode( iPtr->cmdFramePtr = bcFramePtr->nextPtr; TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); - /* - * If the CallFrame is marked as tailcalling, keep tailcalling - */ - - if (iPtr->varFramePtr->isProcCallFrame & FRAME_TAILCALLING) { - if (catchTop == initCatchTop) { - goto abnormalReturn; - } - - iPtr->varFramePtr->isProcCallFrame &= ~FRAME_TAILCALLING; - TclRemoveTailcall(interp); - Tcl_SetResult(interp, - "tailcall called from within a catch environment", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - pc--; - goto gotError; - } - if (iPtr->execEnvPtr->rewind) { TRESULT = TCL_ERROR; goto abnormalReturn; diff --git a/generic/tclInt.h b/generic/tclInt.h index 881dec4..1fb8869 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.481 2010/08/18 22:33:27 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482 2010/08/30 14:02:10 msofer Exp $ */ #ifndef _TCLINT @@ -1152,10 +1152,8 @@ typedef struct CallFrame { * meaning of the value is, which we do not * specify. */ LocalCache *localCachePtr; - struct TEOV_callback *wherePtr; - /* The top of the callback stack when this - * frame was pushed; used to find the spot - * where to tailcall to. */ + struct TEOV_callback *tailcallPtr; + /* NULL if no tailcall is scheduled */ } CallFrame; #define FRAME_IS_PROC 0x1 @@ -1168,8 +1166,6 @@ typedef struct CallFrame { * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ -#define FRAME_TAILCALLING 0x10 /* Flag is set while the CallFrame is winding - * down to process a tailcall */ /* * TIP #280 @@ -2758,10 +2754,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; -MODULE_SCOPE void TclRemoveTailcall(Tcl_Interp *interp); - -MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall; - +MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, + struct TEOV_callback *tailcallPtr); /* * This structure holds the data for the various iteration callbacks used to diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 5bd3c24..6961fd5 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.211 2010/08/18 22:33:27 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.212 2010/08/30 14:02:10 msofer Exp $ */ #include "tclInt.h" @@ -313,18 +313,7 @@ Tcl_PushCallFrame( framePtr->compiledLocals = NULL; framePtr->clientData = NULL; framePtr->localCachePtr = NULL; - - /* - * Record the top of the callback stack, so that tailcall can identify - * the spot where to splice the new command. - */ - - if (iPtr->execEnvPtr) { - framePtr->wherePtr = TOP_CB(interp); - } else { - framePtr->wherePtr = NULL; - } - + framePtr->tailcallPtr = NULL; /* * Push the new call frame onto the interpreter's stack of procedure call @@ -403,6 +392,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 efb5fa4..46e2471 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.13 2010/08/18 15:44:13 msofer Exp $ +# RCS: @(#) $Id: tailcall.test,v 1.14 2010/08/30 14:02:10 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -384,6 +384,20 @@ test tailcall-11b {tailcall and uplevel} -setup { unset -nocomplain ::x } -match glob -result *tailcall* -returnCodes error +test tailcall-11c {tailcall and uplevel} -setup { + proc a {} { + uplevel 1 {tailcall lappend ::x 2} + set ::x 1 + } + proc b {} {set ::x 0; a; lappend ::x 3} +} -body { + list [b] $::x +} -cleanup { + rename a {} + rename b {} + unset -nocomplain ::x +} -result {{0 3 2} {0 3 2}} + test tailcall-12.1 {[Bug 2649975]} -setup { proc dump {{text {}}} { set text [uplevel 1 [list subst $text]] @@ -545,47 +559,77 @@ test tailcall-12.2 {[Bug 2649975]} -setup { 1: exiting from foo's alpha } -test tailcall-12.3a {[Bug 2695587]} { +test tailcall-12.3a0 {[Bug 2695587]} -body { apply {{} { - list [catch [list tailcall foo] msg opt] $msg [errorcode $opt] + catch [list tailcall foo] }} -} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}} +} -returnCodes 1 -result {invalid command name "foo"} -test tailcall-12.3b {[Bug 2695587]} { +test tailcall-12.3a1 {[Bug 2695587]} -body { apply {{} { - list [catch {tailcall foo} msg opt] $msg [errorcode $opt] + catch [list tailcall foo] + tailcall }} -} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}} +} -result {} -test tailcall-12.3c {[Bug 3046594]} { +test tailcall-12.3a2 {[Bug 2695587]} -body { apply {{} { - list [[subst catch] {tailcall foo} msg opt] $msg [errorcode $opt] + catch [list tailcall foo] + tailcall moo }} -} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}} +} -returnCodes 1 -result {invalid command name "moo"} -test tailcall-12.3d {[Bug 3046594]} { +test tailcall-12.3a3 {[Bug 2695587]} -body { + set x 0 apply {{} { - list [[subst catch] [list tailcall foo] msg opt] $msg [errorcode $opt] + catch [list tailcall foo] + tailcall lappend x 1 }} -} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}} + set x +} -cleanup { + unset x +} -result {0 1} -test tailcall-13.1 {tailcall and coroutine} -setup { - set lambda {i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall coroutine foo ::apply $::lambda $i +test tailcall-12.3b0 {[Bug 2695587]} -body { + apply {{} { + set catch catch + $catch [list tailcall foo] }} -} -body { - coroutine moo ::apply $::lambda 0 +} -returnCodes 1 -result {invalid command name "foo"} + +test tailcall-12.3b1 {[Bug 2695587]} -body { + apply {{} { + set catch catch + $catch [list tailcall foo] + tailcall + }} +} -result {} + +test tailcall-12.3b2 {[Bug 2695587]} -body { + apply {{} { + set catch catch + $catch [list tailcall foo] + tailcall moo + }} +} -returnCodes 1 -result {invalid command name "moo"} + +test tailcall-12.3b3 {[Bug 2695587]} -body { + set x 0 + apply {{} { + set catch catch + $catch [list tailcall foo] + tailcall lappend x 1 + }} + set x } -cleanup { - unset lambda -} -result {0 0 0 0 0 0} + unset x +} -result {0 1} + +# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) +# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that +# standard catch behaviour is required. -test tailcall-14.1 {directly tailcalling the tailcall command is ok} { +test tailcall-13.1 {directly tailcalling the tailcall command is ok} { list [catch { apply {{} { apply {{} { @@ -596,7 +640,7 @@ test tailcall-14.1 {directly tailcalling the tailcall command is ok} { }} } msg opt] $msg [errorcode $opt] } {0 ok NONE} -test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} { +test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} { list [catch { apply {{} { apply {{} { |