diff options
Diffstat (limited to 'generic')
| -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 |
6 files changed, 55 insertions, 152 deletions
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); + } } /* |