Attachment "YIELDTO.diff" to
ticket [2910056fff]
added by
msofer
2009-12-07 23:29:09.
? CORODIFF.tmp
? CORODIFF2.tmp
? YIELDTO.diff
? pkgs/itcl/itclConfig.sh
? pkgs/itcl/pkgIndex.tcl
? unix/dltest.marker
? unix/tcl.pc
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.4856
diff -u -r1.4856 ChangeLog
--- ChangeLog 7 Dec 2009 15:08:46 -0000 1.4856
+++ ChangeLog 7 Dec 2009 16:28:01 -0000
@@ -1,3 +1,8 @@
+2009-12-07 Miguel Sofer <[email protected]>
+
+ * generic/tclBasic.c: ::tcl::unsupported::yieldTo
+ * generic/tclInt.h: [Patch 2910056]
+
2009-12-07 Donal K. Fellows <[email protected]>
* generic/tclCmdMZ.c (TryPostBody): [Bug 2910044]: Close off memory
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.414
diff -u -r1.414 tclBasic.c
--- generic/tclBasic.c 7 Dec 2009 14:04:27 -0000 1.414
+++ generic/tclBasic.c 7 Dec 2009 16:28:07 -0000
@@ -799,6 +799,9 @@
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 @@
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 @@
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(
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.449
diff -u -r1.449 tclInt.h
--- generic/tclInt.h 6 Dec 2009 20:35:39 -0000 1.449
+++ generic/tclInt.h 7 Dec 2009 16:28:11 -0000
@@ -2660,6 +2660,7 @@
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);
