summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2009-12-07 16:33:01 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2009-12-07 16:33:01 (GMT)
commit7b7f63470a6ad3bc615a4120d09489ae02c9fa7d (patch)
tree3a2cefb694b5d02ed1e89b00ed6d427ef8877af3 /generic
parentf02342c0abbf0a641833353f729836274db3b80a (diff)
downloadtcl-7b7f63470a6ad3bc615a4120d09489ae02c9fa7d.zip
tcl-7b7f63470a6ad3bc615a4120d09489ae02c9fa7d.tar.gz
tcl-7b7f63470a6ad3bc615a4120d09489ae02c9fa7d.tar.bz2
* generic/tclBasic.c: add ::tcl::unsupported::yieldTo
* generic/tclInt.h: [Patch 2910056]
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c71
-rw-r--r--generic/tclInt.h3
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);