summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2010-04-25 13:39:24 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2010-04-25 13:39:24 (GMT)
commit645ae6e948ae08dfa895b2c01c79119733011da6 (patch)
tree13e6375482e74c54296a8a89ead998754e0755f7
parenteac8ecf3bb3d3d4cc99c78f12abf28cf9e408174 (diff)
downloadtcl-645ae6e948ae08dfa895b2c01c79119733011da6.zip
tcl-645ae6e948ae08dfa895b2c01c79119733011da6.tar.gz
tcl-645ae6e948ae08dfa895b2c01c79119733011da6.tar.bz2
* generic/tclBasic.c: add unsupported [yieldm] command.
* generic/tclInt.h:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBasic.c66
-rw-r--r--generic/tclInt.h6
3 files changed, 54 insertions, 25 deletions
diff --git a/ChangeLog b/ChangeLog
index 621f806..6e07a11 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,11 @@
+2010-04-25 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c: add unsupported [yieldm] command.
+ * generic/tclInt.h:
+
2010-04-24 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.test: modify api of TclSpliceTailcall()
+ * generic/tclBasic.c: modify api of TclSpliceTailcall()
* generic/tclExecute.c: to fix yieldTo, which had not survived
* generic/tclInt.h: the latest mods to tailcall. Thanks kbk
for detecting the problem.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e3b5714..11ddefd 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.451 2010/04/24 17:07:31 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.452 2010/04/25 13:39:25 msofer Exp $
*/
#include "tclInt.h"
@@ -800,6 +800,8 @@ Tcl_CreateInterp(void)
Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
TclNRYieldToObjCmd, NULL, NULL);
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
+ TclNRYieldmObjCmd, NULL, NULL);
#ifdef USE_DTRACE
/*
@@ -8486,13 +8488,29 @@ TclNRYieldObjCmd(
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
-
+ corPtr->nargs = -2;
+
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
}
int
+TclNRYieldmObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ int result;
+
+ result = TclNRYieldObjCmd(clientData, interp, objc, objv);
+ corPtr->nargs = -1;
+ return result;
+}
+
+int
TclNRYieldToObjCmd(
ClientData clientData,
Tcl_Interp *interp,
@@ -8500,7 +8518,6 @@ TclNRYieldToObjCmd(
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;
@@ -8518,10 +8535,9 @@ TclNRYieldToObjCmd(
return TCL_ERROR;
}
- iPtr->numLevels = corPtr->auxNumLevels;
- corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
-
/*
+ * Add the tailcall in the caller env, then just yield.
+ *
* This is essentially code from TclNRTailcallObjCmd
*/
@@ -8544,9 +8560,7 @@ TclNRYieldToObjCmd(
NULL);
iPtr->execEnvPtr = corPtr->eePtr;
- TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
- NULL, NULL, NULL);
- return TCL_OK;
+ return TclNRYieldObjCmd(clientData, interp, objc-1, objv+1);
}
static int
@@ -8716,16 +8730,8 @@ NRInterpCoroutine(
{
CoroutineData *corPtr = clientData;
int nestNumLevels = corPtr->auxNumLevels;
-
- /*
- * objc==0 indicates a call to rewind the coroutine
- */
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
- return TCL_ERROR;
- }
-
+ int nargs = corPtr->nargs;
+
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
@@ -8734,16 +8740,30 @@ NRInterpCoroutine(
return TCL_ERROR;
}
+ if (nargs == -2) {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
+ return TCL_ERROR;
+ } else if (objc == 2) {
+ Tcl_SetObjResult(interp, objv[1]);
+ }
+ } else {
+ if ((nargs != -1) && (nargs != (objc-1))) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("wrong coro nargs; how did we get here? not implemeted!", -1));
+ return TCL_ERROR;
+ }
+ if (objc > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));
+ }
+ }
+
/*
* Swap the interp's environment to make it suitable to run this
* coroutine. TEBC needs no info to resume executing after a suspension:
* the codePtr will be read from the execEnv's saved bottomPtr.
*/
- if (objc == 2) {
- Tcl_SetObjResult(interp, objv[1]);
- }
-
SAVE_CONTEXT(corPtr->caller);
RESTORE_CONTEXT(corPtr->running);
corPtr->auxNumLevels = iPtr->numLevels;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 28b0e3c..965f69b 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.470 2010/04/24 17:07:32 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.471 2010/04/25 13:39:25 msofer Exp $
*/
#ifndef _TCLINT
@@ -1494,6 +1494,9 @@ typedef struct CoroutineData {
/* Where to stash the caller's bottomPointer,
* if the coro is running in the caller's TEBC
* instance. Put a NULL in there otherwise. */
+ int nargs; /* Number of args required for resuming this
+ * coroutine; -2 means "0 or 1" (default), -1
+ * means "any" */
} CoroutineData;
typedef struct ExecEnv {
@@ -2751,6 +2754,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 TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,