diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 71 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 |
2 files changed, 68 insertions, 6 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 33e0273..b201af9 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.414 2009/12/07 14:04:27 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.415 2009/12/07 16:33:01 msofer Exp $ */ #include "tclInt.h" @@ -799,6 +799,9 @@ Tcl_CreateInterp(void) Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRTailcallObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, + TclNRYieldToObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -8415,15 +8418,24 @@ YieldCallback( int result) { CoroutineData *corPtr = data[0]; - Tcl_Obj *cmdPtr = data[1]; + Tcl_Obj *listPtr = data[1]; corPtr->stackLevel = NULL; /* mark suspended */ iPtr->execEnvPtr = corPtr->callerEEPtr; - if (cmdPtr) { - /* yieldTo: invoke the command, use tailcall tech */ + if (listPtr) { + /* yieldTo: invoke the command using tailcall tech */ + TEOV_callback *cbPtr; + ClientData nsPtr = data[2]; + + TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, + NULL, NULL); + cbPtr = TOP_CB(interp); + TOP_CB(interp) = cbPtr->nextPtr; + + TclSpliceTailcall(interp, cbPtr); } - return result; + return TCL_OK; } int @@ -8459,6 +8471,55 @@ TclNRYieldObjCmd( NULL, NULL, NULL); return TCL_OK; } + +int +TclNRYieldToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int numLevels = iPtr->numLevels; + + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + return TCL_ERROR; + } + + if (!corPtr) { + Tcl_SetResult(interp, "yieldTo can only be called in a coroutine", + TCL_STATIC); + return TCL_ERROR; + } + + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + + /* + * This is essentially code from TclNRTailcallObjCmd + */ + + listPtr = Tcl_NewListObj(objc-1, objv+1); + Tcl_IncrRefCount(listPtr); + + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("yieldTo failed to find the proper namespace"); + } + Tcl_IncrRefCount(nsObjPtr); + + TclNRAddCallback(interp, YieldCallback, corPtr, listPtr, nsObjPtr, NULL); + TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), + NULL, NULL, NULL); + return TCL_OK; +} + static int RewindCoroutine( diff --git a/generic/tclInt.h b/generic/tclInt.h index efde2ce..c1315be 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.449 2009/12/06 20:35:39 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.450 2009/12/07 16:33:01 msofer Exp $ */ #ifndef _TCLINT @@ -2660,6 +2660,7 @@ MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); |