summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBasic.c446
-rw-r--r--generic/tclCmdAH.c6
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclExecute.c99
-rw-r--r--generic/tclInt.h38
-rw-r--r--tests/unsupported.test322
7 files changed, 891 insertions, 30 deletions
diff --git a/ChangeLog b/ChangeLog
index 0e863e8..ca1e984 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,12 @@
2008-08-17 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Implementation of [coroutine] and [yield]
+ * generic/tclCmdAH.c: commands (in tcl::unsupported).
+ * generic/tclCompile.h:
+ * generic/tclExecute.c:
+ * generic/tclInt.h:
+ * tests/unsupported.test:
+
* generic/tclTest.c (TestconcatobjCmd):
* generic/tclUtil.c (Tcl_ConcatObj):
* tests/util.test (util-4.7):
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 8f6c1af..6d91c02 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.354 2008/08/14 10:32:19 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.355 2008/08/17 19:37:10 msofer Exp $
*/
#include "tclInt.h"
@@ -777,6 +777,7 @@ Tcl_CreateInterp(void)
Tcl_DisassembleObjCmd, NULL, NULL);
/*
+ * Create unsupported commands for tailcall, coroutine and yield
* Create unsupported commands for atProcExit and tailcall
*/
@@ -787,6 +788,11 @@ Tcl_CreateInterp(void)
/*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_TAILCALL_TYPE),
NULL);
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::coroutine",
+ /*objProc*/ NULL, TclNRCoroutineObjCmd, NULL, NULL);
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::yield",
+ /*objProc*/ NULL, TclNRYieldObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -3679,7 +3685,8 @@ TclInterpReady(
return TCL_ERROR;
}
- if (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG)) {
+ if (iPtr->execEnvPtr->rewind ||
+ (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) {
return TCL_ERROR;
}
@@ -4186,6 +4193,7 @@ TclNRRunCallbacks(
restart:
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
+
procPtr = callbackPtr->procPtr;
if (tebcCall && (procPtr == NRCallTEBC)) {
@@ -4282,7 +4290,10 @@ NRCallTEBC(
function is only called when no tebc is above.
*/
int type = PTR2INT(data[0]);
-
+ Interp *iPtr = ((Interp *) interp);
+
+ NRE_ASSERT(result == TCL_OK);
+
switch (type) {
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
@@ -4292,6 +4303,13 @@ NRCallTEBC(
Tcl_SetResult(interp,
"atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC);
return TCL_ERROR;
+ case TCL_NR_YIELD_TYPE:
+ if (iPtr->execEnvPtr->corPtr) {
+ Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC);
+ }
+ return TCL_ERROR;
default:
Tcl_Panic("unknown call type to TEBC");
}
@@ -8023,6 +8041,428 @@ Tcl_NRAddCallback(
}
TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3);
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRCoroutineObjCmd -- (and friends)
+ *
+ * This object-based function is invoked to process the "coroutine" Tcl
+ * command. It is heavily based on "apply".
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * A new procedure gets created.
+ *
+ * ** FIRST EXPERIMENTAL IMPLEMENTATION **
+ *
+ * It is fairly amateurish and not up to our standards - mainly in terms of
+ * error messages and [info] interaction. Just to test the infrastructure in
+ * teov and tebc.
+ *----------------------------------------------------------------------
+ */
+
+static int NRInterpCoroutine(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int RewindCoroutine(CoroutineData *corPtr, int result);
+static void DeleteCoroutine(ClientData clientData);
+static void PlugCoroutineChains(CoroutineData *corPtr);
+
+static int NRCoroutineFirstCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int NRCoroutineExitCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int NRCoroutineCallerCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
+
+
+
+static const CorContext NULL_CONTEXT = {NULL, NULL, NULL};
+
+#define SAVE_CONTEXT(context) \
+ (context).framePtr = iPtr->framePtr; \
+ (context).varFramePtr = iPtr->varFramePtr; \
+ (context).cmdFramePtr = iPtr->cmdFramePtr
+
+#define RESTORE_CONTEXT(context) \
+ iPtr->framePtr = (context).framePtr; \
+ iPtr->varFramePtr = (context).varFramePtr; \
+ iPtr->cmdFramePtr = (context).cmdFramePtr
+
+#define iPtr ((Interp *) interp)
+
+int
+TclNRYieldObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
+ return TCL_ERROR;
+ }
+
+ if (!iPtr->execEnvPtr->corPtr) {
+ Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ Tcl_SetObjResult(interp, objv[1]);
+ }
+
+ TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
+ NULL, NULL, NULL);
+ return TCL_OK;
+}
+
+static int
+RewindCoroutine(
+ CoroutineData *corPtr,
+ int result)
+{
+ Tcl_Obj *objPtr;
+ Tcl_Interp *interp = corPtr->eePtr->interp;
+ Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
+
+ NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
+ NRE_ASSERT(corPtr->eePtr != NULL);
+ NRE_ASSERT(corPtr->eePtr->bottomPtr != NULL);
+ NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);
+
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+
+ corPtr->eePtr->rewind = 1;
+ result = NRInterpCoroutine((ClientData) corPtr, interp, 1, &objPtr);
+
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
+
+ Tcl_DecrRefCount(objPtr);
+ result = Tcl_RestoreInterpState(interp, state);
+ return result;
+}
+
+static void
+DeleteCoroutine(
+ ClientData clientData)
+{
+ CoroutineData *corPtr = (CoroutineData *) clientData;
+
+ if (COR_IS_SUSPENDED(corPtr)) {
+ (void) RewindCoroutine(corPtr, TCL_OK);
+ }
+}
+
+static void
+PlugCoroutineChains(
+ CoroutineData *corPtr)
+{
+ Tcl_Interp *interp = corPtr->eePtr->interp;
+ /*
+ * Called to plug the coroutine's running environment into the caller's,
+ * so that the frame chains are uninterrupted. Note that the levels and
+ * numlevels may be wrong - we should fix them for the whole chain and not
+ * just the base! This probably breaks Tip 280 and should be fixed, or at
+ * least rethought as some of 280's functionality makes doubtful sense in
+ * presence of coroutines (maybe the cmdFrame should be attached to the
+ * execEnv and not the interp?)
+ */
+
+ corPtr->base.framePtr->callerPtr = corPtr->caller.framePtr;
+ corPtr->base.framePtr->callerVarPtr = corPtr->caller.varFramePtr;
+
+ corPtr->base.cmdFramePtr->nextPtr = corPtr->caller.cmdFramePtr;
+ corPtr->base.cmdFramePtr->level = (iPtr->cmdFramePtr == NULL?
+ 1 : iPtr->cmdFramePtr->level + 1);
+ corPtr->base.cmdFramePtr->numLevels = iPtr->numLevels;
+}
+
+static int
+NRCoroutineFirstCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+
+ {
+ CmdFrame *tmpPtr = iPtr->cmdFramePtr;
+
+ if (corPtr->eePtr) {
+ while (tmpPtr->nextPtr != corPtr->caller.cmdFramePtr) {
+ tmpPtr = tmpPtr->nextPtr;
+ }
+ corPtr->base.cmdFramePtr = tmpPtr;
+ }
+ }
+
+ return result;
+}
+
+static int
+NRCoroutineCallerCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Command *cmdPtr = corPtr->cmdPtr;
+
+ /*
+ * This is the last callback in the caller execEnv, right before switching
+ * to the coroutine's
+ */
+
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr);
+
+ if (!corPtr->eePtr) {
+ /*
+ * The execEnv was wound down but not deleted for our sake. We finish
+ * the job here. The caller context has already been restored.
+ */
+
+ NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr);
+ NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
+ NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
+ ckfree((char *) corPtr);
+ return result;
+ }
+
+ NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
+ SAVE_CONTEXT(corPtr->running);
+ RESTORE_CONTEXT(corPtr->caller);
+
+ if (cmdPtr->flags & CMD_IS_DELETED) {
+ /*
+ * The command was deleted while it was running: wind down the execEnv,
+ * this will do the complete cleanup. RewindCoroutine will restore both
+ * the caller's context and interp state.
+ */
+
+ return RewindCoroutine(corPtr, result);
+ }
+
+ return result;
+}
+
+static int
+NRCoroutineExitCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Command *cmdPtr = corPtr->cmdPtr;
+
+ /*
+ * This runs at the bottom of the Coroutine's execEnv: it will be executed
+ * when the coroutine returns or is wound down, but not when it yields. It
+ * deletes the coroutine and restores the caller's environment.
+ */
+
+ NRE_ASSERT(interp == corPtr->eePtr->interp);
+ NRE_ASSERT(TOP_CB(interp) == NULL);
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
+ NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
+ NRE_ASSERT(TOP_CB(interp) == NULL);
+ NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)
+ || ((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineFirstCallback) &&
+ (corPtr->callerEEPtr->callbackPtr->nextPtr->procPtr == NRCoroutineCallerCallback)));
+
+ NRE_ASSERT(iPtr->framePtr->compiledLocals == NULL);
+ TclPopStackFrame(interp);
+
+ cmdPtr->deleteProc = NULL;
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ TclCleanupCommandMacro(cmdPtr);
+
+ corPtr->eePtr->corPtr = NULL;
+ TclDeleteExecEnv(corPtr->eePtr);
+ corPtr->eePtr = NULL;
+
+ /* RESTORE_CONTEXT(corPtr->caller); AUTOMATIC! */
+
+ NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
+ NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
+ iPtr->varFramePtr = corPtr->caller.varFramePtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+
+ return result;
+}
+
+static int
+NRInterpCoroutine(
+ ClientData clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ CoroutineData *corPtr = (CoroutineData *) clientData;
+
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
+ return TCL_ERROR;
+ }
+
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
+ "\" is already running", NULL);
+ return TCL_ERROR;
+ }
+
+
+ /*
+ * 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);
+ PlugCoroutineChains(corPtr);
+
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, NULL);
+
+ iPtr->execEnvPtr = corPtr->eePtr;
+ return TclExecuteByteCode(interp, NULL);
+}
+
+int
+TclNRCoroutineObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Command *cmdPtr;
+ CoroutineData *corPtr;
+ Tcl_Obj *cmdObjPtr;
+ CallFrame *framePtr, **framePtrPtr;
+ TEOV_callback *rootPtr = TOP_CB(interp);
+ char *fullName;
+ const char *procName;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+ Tcl_DString ds;
+
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
+ * something in tclUtil.c to find the FQ name.
+ */
+
+ fullName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, fullName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+
+ if (nsPtr == NULL) {
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
+ "\": unknown namespace", NULL);
+ return TCL_ERROR;
+ }
+ if (procName == NULL) {
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
+ "\": bad procedure name", NULL);
+ return TCL_ERROR;
+ }
+ if ((nsPtr != iPtr->globalNsPtr)
+ && (procName != NULL) && (procName[0] == ':')) {
+ Tcl_AppendResult(interp, "can't create procedure \"", procName,
+ "\" in non-global namespace with name starting with \":\"",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData));
+ corPtr->eePtr = TclCreateExecEnv(interp);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ corPtr->eePtr->corPtr = corPtr;
+ corPtr->stackLevel = NULL;
+
+ Tcl_DStringInit(&ds);
+ if (nsPtr != iPtr->globalNsPtr) {
+ Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
+ Tcl_DStringAppend(&ds, "::", 2);
+ }
+ Tcl_DStringAppend(&ds, procName, -1);
+
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
+ /*objProc*/ NULL, NRInterpCoroutine, (ClientData) corPtr,
+ DeleteCoroutine);
+ Tcl_DStringFree(&ds);
+
+ corPtr->cmdPtr = cmdPtr;
+ cmdPtr->refCount++;
+
+ /*
+ * Be sure not to pass a canonical list for the command so that we insure
+ * the body is bytecompiled: we need a TEBC instance to handle [yield]
+ */
+
+ cmdObjPtr = Tcl_NewListObj(objc-2, &objv[2]);
+ TclGetString(cmdObjPtr);
+ TclFreeIntRep(cmdObjPtr);
+ cmdObjPtr->typePtr = NULL;
+ Tcl_IncrRefCount(cmdObjPtr);
+
+ /*
+ * Set up the callback in caller execEnv and switch to the new
+ * execEnv. Switch now so that the CallFrame is allocated on the new
+ * execEnv's stack. Then push a CallFrame and CmdFrame.
+ */
+
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, NULL);
+ TclNRAddCallback(interp, NRCoroutineFirstCallback, corPtr, NULL, NULL, NULL);
+ SAVE_CONTEXT(corPtr->caller);
+
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+ framePtrPtr = &framePtr;
+ if (TCL_OK != TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ NULL, 0)) {
+ corPtr->eePtr->corPtr = NULL;
+ TclDeleteExecEnv(corPtr->eePtr);
+ ckfree((char *) corPtr);
+ return TCL_ERROR;
+ }
+ framePtr->objc = objc-2;
+ framePtr->objv = &objv[2];
+
+ SAVE_CONTEXT(corPtr->base);
+ corPtr->running = NULL_CONTEXT;
+
+ /*
+ * Eval things in 'uplevel #0', except for the very first command lookup
+ * which should be looked up in caller's context.
+ *
+ * A better approach would use the lambda infrastructure, but it is a bit
+ * clumsy for now: we have the "lambda is a nameless proc" hack, we'd need
+ * the cleaner "proc is a named lambda" to do this properly.
+ */
+
+ iPtr->varFramePtr = iPtr->rootFramePtr;
+ iPtr->lookupNsPtr = iPtr->framePtr->nsPtr;
+
+ TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL);
+ return TclNRRunCallbacks(interp, TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
+}
+
/*
* Local Variables:
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 868b0b8..8e26dcf 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.101 2008/07/31 20:01:39 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.102 2008/08/17 19:37:11 msofer Exp $
*/
#include "tclInt.h"
@@ -278,13 +278,13 @@ CatchObjCmdCallback(
int objc = PTR2INT(data[0]);
Tcl_Obj *varNamePtr = data[1];
Tcl_Obj *optionVarNamePtr = data[2];
-
+ int rewind = ((Interp *) interp)->execEnvPtr->rewind;
/*
* We disable catch in interpreters where the limit has been exceeded.
*/
- if (Tcl_LimitExceeded(interp)) {
+ if (rewind || Tcl_LimitExceeded(interp)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"catch\" body line %d)", interp->errorLine));
return TCL_ERROR;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 044a978..c7539ba 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.105 2008/08/14 10:49:08 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.106 2008/08/17 19:37:11 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -842,6 +842,7 @@ MODULE_SCOPE Tcl_NRPostProc NRCallTEBC;
#define TCL_NR_BC_TYPE 0
#define TCL_NR_ATEXIT_TYPE 1
#define TCL_NR_TAILCALL_TYPE 2
+#define TCL_NR_YIELD_TYPE 3
/*
*----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index cc7e4bc..65795bd 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.405 2008/08/16 14:27:28 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.406 2008/08/17 19:37:11 msofer Exp $
*/
#include "tclInt.h"
@@ -804,7 +804,11 @@ TclCreateExecEnv(
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
+ eePtr->interp = interp;
eePtr->callbackPtr = NULL;
+ eePtr->corPtr = NULL;
+ eePtr->bottomPtr = NULL;
+ eePtr->rewind = 0;
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
@@ -882,6 +886,9 @@ TclDeleteExecEnv(
if (eePtr->callbackPtr) {
Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
}
+ if (eePtr->corPtr) {
+ Tcl_Panic("Deleting execEnv with existing coroutine");
+ }
ckfree((char *) eePtr);
}
@@ -1826,6 +1833,28 @@ TclExecuteByteCode(
TEOV_callback *atExitPtr = NULL;
int isTailcall = 0;
+ if (!codePtr) {
+ /*
+ * Reawakening a suspended coroutine: the [yield] command
+ * is returning.
+ */
+
+ NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr);
+ NRE_ASSERT(iPtr->execEnvPtr->corPtr != NULL);
+ NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr);
+ NRE_ASSERT(COR_IS_SUSPENDED(iPtr->execEnvPtr->corPtr));
+
+ initLevel = 0;
+ nested = 1;
+
+ oldBottomPtr = iPtr->execEnvPtr->bottomPtr;
+ iPtr->execEnvPtr->corPtr->stackLevel = &initLevel;
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ }
+ goto returnToCaller;
+ }
+
nonRecursiveCallStart:
if (nested) {
TEOV_callback *callbackPtr = TOP_CB(interp);
@@ -1848,13 +1877,12 @@ TclExecuteByteCode(
* variables, swap codePtr and start running the new one.
*/
- NR_DATA_BURY();
codePtr = param;
break;
case TCL_NR_ATEXIT_TYPE: {
/*
* A request to perform a command at exit: put it in the stack
- * and continue eexec'ing the current bytecode
+ * and continue exec'ing the current bytecode
*/
TEOV_callback *newPtr = TOP_CB(interp);
@@ -1868,11 +1896,8 @@ TclExecuteByteCode(
#endif
newPtr->nextPtr = bottomPtr->atExitPtr;
bottomPtr->atExitPtr = newPtr;
- while (cleanup--) {
- Tcl_Obj *objPtr = POP_OBJECT();
- Tcl_DecrRefCount(objPtr);
- }
- goto nonRecursiveCallReturn;
+ oldBottomPtr = bottomPtr;
+ goto returnToCaller;
}
case TCL_NR_TAILCALL_TYPE: {
/*
@@ -1915,6 +1940,37 @@ TclExecuteByteCode(
}
goto abnormalReturn;
}
+ case TCL_NR_YIELD_TYPE: { /*[yield] */
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ if (!corPtr) {
+ Tcl_SetResult(interp,
+ "yield can only be called in a coroutine", TCL_STATIC);
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
+ NRE_ASSERT(corPtr->stackLevel != NULL);
+ NRE_ASSERT(bottomPtr == corPtr->eePtr->bottomPtr);
+ if (corPtr->stackLevel != &initLevel) {
+ Tcl_SetResult(interp,
+ "cannot yield: C stack busy", TCL_STATIC);
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /*
+ * Save our state, restore the caller's execEnv and return
+ */
+
+ NR_DATA_BURY();
+ esPtr->tosPtr = tosPtr;
+ corPtr->stackLevel = NULL; /* mark suspended */
+ iPtr->execEnvPtr->bottomPtr = bottomPtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ return TCL_OK;
+ }
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
@@ -1929,8 +1985,13 @@ TclExecuteByteCode(
auxObjList = NULL;
initLevel = 1;
NR_DATA_INIT(); /* record this level's data */
+
+ if (iPtr->execEnvPtr->corPtr && !iPtr->execEnvPtr->corPtr->stackLevel) {
+ iPtr->execEnvPtr->corPtr->stackLevel = &initLevel;
+ }
nonRecursiveCallReturn:
+ iPtr->execEnvPtr->bottomPtr = bottomPtr;
bcFramePtr = (CmdFrame *) (bottomPtr + 1);
initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1;
initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth);
@@ -1965,6 +2026,11 @@ TclExecuteByteCode(
TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr);
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
+
} else {
/*
* Returning from a non-recursive call. State is already completely
@@ -1973,7 +2039,12 @@ TclExecuteByteCode(
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
-
+
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
+
if (result == TCL_OK) {
/*
* Reset the interp's result to avoid possible duplications of
@@ -2731,7 +2802,11 @@ TclExecuteByteCode(
pc += pcAdjustment;
goto nonRecursiveCallStart;
}
+
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+ NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr->nextPtr);
+
+ iPtr->execEnvPtr->bottomPtr = bottomPtr;
if (result == TCL_OK) {
Tcl_Obj *objPtr;
@@ -7591,6 +7666,9 @@ TclExecuteByteCode(
*/
checkForCatch:
+ if (iPtr->execEnvPtr->rewind) {
+ goto abnormalReturn;
+ }
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
@@ -7747,6 +7825,7 @@ TclExecuteByteCode(
TclCleanupByteCode(codePtr);
}
+ returnToCaller:
if (oldBottomPtr) {
/*
* Restore the state to what it was previous to this bytecode, deal
@@ -7759,7 +7838,6 @@ TclExecuteByteCode(
result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
NR_DATA_DIG();
- DECACHE_STACK_INFO();
if (TOP_CB(interp) == bottomPtr->rootPtr) {
/*
* The bytecode is returning, all callbacks were run. Run atExit
@@ -7856,6 +7934,7 @@ TclExecuteByteCode(
iPtr->atExitPtr = atExitPtr;
}
+ iPtr->execEnvPtr->bottomPtr = NULL;
return result;
}
#undef iPtr
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8992044..c40220f 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.390 2008/08/13 23:08:38 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.391 2008/08/17 19:37:12 msofer Exp $
*/
#ifndef _TCLINT
@@ -1330,15 +1330,38 @@ typedef struct ExecStack {
* currently active execution stack.
*/
+typedef struct CorContext {
+ struct CallFrame *framePtr;
+ struct CallFrame *varFramePtr;
+ struct CmdFrame *cmdFramePtr;
+} CorContext;
+
+typedef struct CoroutineData {
+ struct Command *cmdPtr;
+ struct ExecEnv *eePtr;
+ struct ExecEnv *callerEEPtr;
+ CorContext caller;
+ CorContext running;
+ CorContext base;
+ int *stackLevel;
+} CoroutineData;
+
typedef struct ExecEnv {
ExecStack *execStackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1"
* objs. */
+ struct Tcl_Interp *interp;
struct TEOV_callback *callbackPtr;
/* Top callback in TEOV's stack */
+ struct CoroutineData *corPtr;
+ struct BottomData *bottomPtr;
+ int rewind;
} ExecEnv;
+#define COR_IS_SUSPENDED(corPtr) \
+ ((corPtr)->stackLevel == NULL)
+
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
* interpreter contains a LiteralTable. It is used to reduce the storage
@@ -2523,13 +2546,14 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
+
/*
*----------------------------------------------------------------
- * Procedures shared among Tcl modules but not used by the outside world:
+ * Procedures shared among Tcl modules but not used by the outside world,
+ * introduced by/for NRE.
*----------------------------------------------------------------
*/
-/* Introduced by/for NRE */
MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
@@ -2540,6 +2564,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRAtProcExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
+
+/*
+ *----------------------------------------------------------------
+ * Procedures shared among Tcl modules but not used by the outside world:
+ *----------------------------------------------------------------
+ */
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
int flags);
diff --git a/tests/unsupported.test b/tests/unsupported.test
index c043ae2..48cd130 100644
--- a/tests/unsupported.test
+++ b/tests/unsupported.test
@@ -1,4 +1,4 @@
-# Commands covered: proc, apply, [interp alias], [namespce import], tailcall
+# Commands covered: tailcall, atProcExit, coroutine, yield
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unsupported.test,v 1.3 2008/08/04 14:59:53 msofer Exp $
+# RCS: @(#) $Id: unsupported.test,v 1.4 2008/08/17 19:37:13 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -19,15 +19,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
+testConstraint coroutine [llength [info commands ::tcl::unsupported::yield]]
-if {[testConstraint atProcExit]} {
- namespace eval tcl::unsupported namespace export atProcExit
- namespace import tcl::unsupported::atProcExit
-}
-
-if {[testConstraint tailcall]} {
- namespace eval tcl::unsupported namespace export tailcall
- namespace import tcl::unsupported::tailcall
+if {[namespace exists tcl::unsupported]} {
+ namespace eval tcl::unsupported namespace export *
+ namespace import tcl::unsupported::*
}
#
@@ -424,10 +420,311 @@ test unsupported-AT.1 {atProcExit and tailcall} -constraints {
rename a {}
} -result {{0 2 3 1 6} {0 2 3 1 6} 0}
+#
+# Test coroutines
+#
+
+if {[testConstraint coroutine]} {
+ namespace import tcl::unsupported::coroutine
+ namespace import tcl::unsupported::yield
+}
+
+set lambda [list {{start 0} {stop 10}} {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ yield [expr {$i*$stop}]
+ incr i
+ }
+}]
+
+
+test unsupported-C.1.1 {coroutine basic} -constraints {coroutine} \
+-setup {
+ coroutine foo ::apply $lambda
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [foo]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ unset res
+} -result {0 10 20}
+
+test unsupported-C.1.2 {coroutine basic} -constraints {coroutine} \
+-setup {
+ coroutine foo ::apply $lambda 2 8
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [foo]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ unset res
+} -result {16 24 32}
+
+test unsupported-C.1.3 {yield returns new arg} -constraints {coroutine} \
+-setup {
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ set stop [yield [expr {$i*$stop}]]
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 2} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [foo $k]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ unset res
+} -result {20 6 12}
+
+test unsupported-C.1.4 {yield in nested proc} -constraints {coroutine} \
+-setup {
+ proc moo {} {
+ upvar 1 i i stop stop
+ yield [expr {$i*$stop}]
+ }
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ moo
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 0} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [foo $k]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ rename moo {}
+ unset body res
+} -result {0 10 20}
+
+test unsupported-C.1.5 {just yield} -constraints {coroutine} \
+-body {
+ coroutine foo yield
+ list [foo] [catch foo msg] $msg
+} -cleanup {
+ unset msg
+} -result {{} 1 {invalid command name "foo"}}
+
+test unsupported-C.1.6 {just yield} -constraints {coroutine} \
+-body {
+ coroutine foo [list yield]
+ list [foo] [catch foo msg] $msg
+} -cleanup {
+ unset msg
+} -result {{} 1 {invalid command name "foo"}}
+
+test unsupported-C.1.7 {yield in nested uplevel} -constraints {coroutine} \
+-setup {
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ uplevel 0 [list yield [expr {$i*$stop}]]
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 0} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [eval foo $k]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ unset body res
+} -result {0 10 20}
+
+test unsupported-C.1.8 {yield in nested uplevel} -constraints {coroutine} \
+-setup {
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ uplevel 0 yield [expr {$i*$stop}]
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 0} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [eval foo $k]
+ }
+ set res
+} -cleanup {
+ rename foo {}
+ unset body res
+} -result {0 10 20}
+
+test unsupported-C.1.9 {yield in nested eval} -constraints {coroutine} \
+-setup {
+ proc moo {} {
+ upvar 1 i i stop stop
+ yield [expr {$i*$stop}]
+ }
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ eval moo
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 0} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [foo $k]
+ }
+ set res
+} -cleanup {
+ rename moo {}
+ unset body res
+} -returnCodes error -result {cannot yield: C stack busy}
+
+test unsupported-C.1.10 {yield in nested eval} -constraints {coroutine} \
+-setup {
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ eval yield
+ incr i
+ }
+ }
+ coroutine foo ::apply [list {{start 0} {stop 10}} $body]
+ set res {}
+} -body {
+ for {set k 1} {$k < 4} {incr k} {
+ lappend res [eval foo $k]
+ }
+ set res
+} -cleanup {
+ unset body res
+} -returnCodes error -result {cannot yield: C stack busy}
+
+test unsupported-C.1.11 {yield outside coroutine} -constraints {coroutine} \
+-setup {
+ proc moo {} {
+ upvar 1 i i stop stop
+ yield [expr {$i*$stop}]
+ }
+} -body {
+ variable i 5 stop 6
+ moo
+} -cleanup {
+ rename moo {}
+ unset i stop
+} -returnCodes error -result {yield can only be called in a coroutine}
+
+test unsupported-C.1.12 {proc as coroutine} -constraints {coroutine} \
+-setup {
+ set body {
+ # init
+ set i $start
+ set imax $stop
+ yield
+
+ while {$i < $imax} {
+ uplevel 0 [list yield [expr {$i*$stop}]]
+ incr i
+ }
+ }
+ proc moo {{start 0} {stop 10}} $body
+ coroutine foo moo 2 8
+} -body {
+ list [foo] [foo]
+} -cleanup {
+ unset body
+ rename moo {}
+ rename foo {}
+} -result {16 24}
+
+test unsupported-C.2.1 {self deletion on return} -constraints {coroutine} \
+-body {
+ coroutine foo set x 3
+ foo
+} -returnCodes error -result {invalid command name "foo"}
+
+test unsupported-C.2.2 {self deletion on return} -constraints {coroutine} \
+-body {
+ coroutine foo ::apply [list {} {yield; yield 1; return 2}]
+ list [foo] [foo] [catch foo msg] $msg
+} -result {1 2 1 {invalid command name "foo"}}
+
+test unsupported-C.2.3 {self deletion on error return} -constraints {coroutine} \
+-body {
+ coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
+ list [foo] [catch foo msg] $msg [catch foo msg] $msg
+} -result {1 1 ouch! 1 {invalid command name "foo"}}
+
+test unsupported-C.2.4 {self deletion on other return} -constraints {coroutine} \
+-body {
+ coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
+ list [foo] [catch foo msg] $msg [catch foo msg] $msg
+} -result {1 100 ouch! 1 {invalid command name "foo"}}
+
+test unsupported-C.2.5 {deletion of suspended coroutine} -constraints {coroutine} \
+-body {
+ coroutine foo ::apply [list {} {yield; yield 1; return 2}]
+ list [foo] [rename foo {}] [catch foo msg] $msg
+} -result {1 {} 1 {invalid command name "foo"}}
+
+test unsupported-C.2.6 {deletion of running coroutine} -constraints {coroutine} \
+-body {
+ coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
+ list [foo] [catch foo msg] $msg
+} -result {1 1 {invalid command name "foo"}}
+
+
# cleanup
::tcltest::cleanupTests
+
+unset -nocomplain lambda
+
if {[testConstraint tailcall]} {
namespace forget tcl::unsupported::tailcall
}
@@ -436,6 +733,11 @@ if {[testConstraint atProcExit]} {
namespace forget tcl::unsupported::atProcExit
}
+if {[testConstraint coroutine]} {
+ namespace forget tcl::unsupported::coroutine
+ namespace forget tcl::unsupported::yield
+}
+
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre