* 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:

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