From e6e54e79e2d7333a81f91a9525ed518f9d96a0cd Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Thu, 19 Mar 2009 23:31:36 +0000
Subject: 	* generic/tcl.h: 	* generic/tclInt.h: 	*
 generic/tclBasic.c: 	* generic/tclExecute.c: 	* generic/tclNamesp.c
 (Tcl_PopCallFrame): Rewritten tailcall 	implementation,
 ::unsupported::atProcExit is (temporarily?) 	gone. The new approach is much
 simpler, and also closer to being 	correct. This commit fixes [Bug
 2649975] and [Bug 2695587].

	* tests/coroutine.test:    Moved the tests to their own files,
	* tests/tailcall.test:     removed the unsupported.test. Added
	* tests/unsupported.test:  tests for the fixed bugs.
---
 ChangeLog              |  15 +
 generic/tcl.h          |   3 +-
 generic/tclBasic.c     | 102 +++---
 generic/tclExecute.c   | 145 +-------
 generic/tclInt.h       |  49 ++-
 generic/tclNamesp.c    |  31 +-
 tests/coroutine.test   | 544 +++++++++++++++++++++++++++++
 tests/tailcall.test    | 428 +++++++++++++++++++++++
 tests/unsupported.test | 914 -------------------------------------------------
 9 files changed, 1123 insertions(+), 1108 deletions(-)
 create mode 100644 tests/coroutine.test
 create mode 100644 tests/tailcall.test
 delete mode 100644 tests/unsupported.test

diff --git a/ChangeLog b/ChangeLog
index f6e932a..014bcde 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2009-03-19  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tcl.h:
+	* generic/tclInt.h:
+	* generic/tclBasic.c:
+	* generic/tclExecute.c:
+	* generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall
+	implementation, ::unsupported::atProcExit is (temporarily?)
+	gone. The new approach is much simpler, and also closer to being
+	correct. This commit fixes [Bug 2649975] and [Bug 2695587].
+
+	* tests/coroutine.test:    Moved the tests to their own files, 
+	* tests/tailcall.test:     removed the unsupported.test. Added
+	* tests/unsupported.test:  tests for the fixed bugs.
+	
 2009-03-19  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/tailcall.n: Added documentation for tailcall command.
diff --git a/generic/tcl.h b/generic/tcl.h
index 72c4acd..b5bced7 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.288 2009/01/16 20:44:24 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.289 2009/03/19 23:31:36 msofer Exp $
  */
 
 #ifndef _TCL
@@ -887,6 +887,7 @@ typedef struct Tcl_CallFrame {
     char *dummy10;
     char *dummy11;
     char *dummy12;
+    char *dummy13;
 } Tcl_CallFrame;
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 50230ba..739732f 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.387 2009/03/11 10:44:20 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.388 2009/03/19 23:31:37 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -136,8 +136,8 @@ static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
 
 static Tcl_NRPostProc   NRRunObjProc;
 
-static Tcl_NRPostProc	AtProcExitCleanup;
-static Tcl_NRPostProc   NRAtProcExitEval;
+static Tcl_NRPostProc	TailcallCleanup;
+static Tcl_NRPostProc   NRTailcallEval;
 
 /*
  * The following structure define the commands in the Tcl core.
@@ -698,7 +698,7 @@ Tcl_CreateInterp(void)
 #endif
     iPtr->pendingObjDataPtr = NULL;
     iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
-    iPtr->atExitPtr = NULL;
+    iPtr->deferredCallbacks = NULL;
 
     /*
      * Create the core commands. Do it here, rather than calling
@@ -782,14 +782,11 @@ Tcl_CreateInterp(void)
 	    Tcl_DisassembleObjCmd, NULL, NULL);
 
     /*
-     * Create the 'tailcall' command an unsupported command for 'atProcExit'
+     * Create the 'tailcall' command
      */
 
-    Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRAtProcExitObjCmd,
-	    INT2PTR(TCL_NR_TAILCALL_TYPE), NULL);
-
-    Tcl_NRCreateCommand(interp, "::tcl::unsupported::atProcExit", NULL,
-	    TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_ATEXIT_TYPE), NULL);
+    Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRTailcallObjCmd,
+	    NULL, NULL);
 
 #ifdef USE_DTRACE
     /*
@@ -4056,7 +4053,7 @@ TclNREvalObjv(
      * will be filled later when the command is found: save its address at
      * objProcPtr.
      *
-     * data[1] stores a marker for use by tailcalls; it will be reset to 0 by
+     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
      * command redirectors (imports, alias, ensembles) so that tailcalls
      * finishes the source command and not just the target.
      */
@@ -4064,6 +4061,8 @@ TclNREvalObjv(
     TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
     cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
 
+    TclNRSpliceDeferred(interp);
+    
     iPtr->numLevels++;
     result = TclInterpReady(interp);
 
@@ -4220,7 +4219,6 @@ TclNRRunCallbacks(
 	(void) Tcl_GetObjResult(interp);
     }
 
-  restart:
     while (TOP_CB(interp) != rootPtr) {
 	callbackPtr = TOP_CB(interp);
 
@@ -4244,16 +4242,6 @@ TclNRRunCallbacks(
 	result = procPtr(callbackPtr->data, interp, result);
 	TCLNR_FREE(interp, callbackPtr);
     }
-    if (iPtr->atExitPtr) {
-	callbackPtr = iPtr->atExitPtr;
-	while (callbackPtr->nextPtr) {
-	    callbackPtr = callbackPtr->nextPtr;
-	}
-	callbackPtr->nextPtr = rootPtr;
-	TOP_CB(iPtr) = iPtr->atExitPtr;
-	iPtr->atExitPtr = NULL;
-	goto restart;
-    }
     return result;
 }
 
@@ -4286,6 +4274,7 @@ NRCommand(
     if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
 	result = Tcl_LimitCheck(interp);
     }
+
     return result;
 }
 
@@ -4327,11 +4316,10 @@ NRCallTEBC(
     switch (type) {
     case TCL_NR_BC_TYPE:
 	return TclExecuteByteCode(interp, data[1]);
-    case TCL_NR_ATEXIT_TYPE:
     case TCL_NR_TAILCALL_TYPE:
-	/* For atProcExit and tailcalls */
+	/* For tailcalls */
 	Tcl_SetResult(interp,
-		"atProcExit/tailcall can only be called from a proc or lambda",
+		"tailcall can only be called from a proc or lambda",
 		TCL_STATIC);
 	return TCL_ERROR;
     case TCL_NR_YIELD_TYPE:
@@ -5767,6 +5755,20 @@ TclNREvalObjEx(
 	 * UpdateStringOfList from the internal rep).
 	 */
 
+	/*
+	 * Shimmer protection! Always pass an unshared obj. The caller could
+	 * incr the refCount of objPtr AFTER calling us! To be completely safe
+	 * we always make a copy. The callback takes care od the refCounts for
+	 * both listPtr and objPtr.
+	 *
+	 * FIXME OPT: preserve just the internal rep?
+	 */
+
+	Tcl_IncrRefCount(objPtr);
+	listPtr = TclListObjCopy(interp, objPtr);
+	Tcl_IncrRefCount(listPtr);
+	TclDecrRefCount(objPtr);
+	
 	if (word != INT_MIN) {
 	    /*
 	     * TIP #280 Structures for tracking lines. As we know that this is
@@ -5795,26 +5797,14 @@ TclNREvalObjEx(
 	    eoFramePtr->framePtr = iPtr->framePtr;
 	    eoFramePtr->nextPtr = iPtr->cmdFramePtr;
 
-	    eoFramePtr->cmd.listPtr = objPtr;
+	    eoFramePtr->cmd.listPtr = listPtr;
 	    eoFramePtr->data.eval.path = NULL;
 
 	    iPtr->cmdFramePtr = eoFramePtr;
 	}
 
-	/*
-	 * Shimmer protection! Always pass an unshared obj. The caller could
-	 * incr the refCount of objPtr AFTER calling us! To be completely safe
-	 * we always make a copy. The callback takes care od the refCounts for
-	 * both listPtr and objPtr.
-	 *
-	 * FIXME OPT: preserve just the internal rep?
-	 */
-
-	Tcl_IncrRefCount(objPtr);
-	listPtr = TclListObjCopy(interp, objPtr);
-	Tcl_IncrRefCount(listPtr);
-	TclNRAddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr,
-		listPtr, NULL);
+	TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+		NULL, NULL);
 
 	ListObjGetElements(listPtr, objc, objv);
 	return TclNREvalObjv(interp, objc, objv, flags, NULL);
@@ -5991,9 +5981,8 @@ TEOEx_ListCallback(
     int result)
 {
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *objPtr = data[0];
+    Tcl_Obj *listPtr = data[0];
     CmdFrame *eoFramePtr = data[1];
-    Tcl_Obj *listPtr = data[2];
 
     /*
      * Remove the cmdFrame
@@ -6003,7 +5992,6 @@ TEOEx_ListCallback(
 	iPtr->cmdFramePtr = eoFramePtr->nextPtr;
 	TclStackFree(interp, eoFramePtr);
     }
-    TclDecrRefCount(objPtr);
     TclDecrRefCount(listPtr);
 
     return result;
@@ -7992,25 +7980,26 @@ Tcl_NRCmdSwap(
  */
 
 int
-TclNRAtProcExitObjCmd(
+TclNRTailcallObjCmd(
     ClientData clientData,
     Tcl_Interp *interp,
     int objc,
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *) interp;
+    TEOV_callback *tailcallPtr;
     Tcl_Obj *listPtr;
     Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
-
+    
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
 	return TCL_ERROR;
     }
-
+    
     if (!iPtr->varFramePtr->isProcCallFrame ||	      /* is not a body ... */
 	    (iPtr->framePtr != iPtr->varFramePtr)) {  /* or is upleveled   */
 	Tcl_SetResult(interp,
-		"atProcExit/tailcall can only be called from a proc or lambda",
+		"tailcall can only be called from a proc or lambda",
 		TCL_STATIC);
 	return TCL_ERROR;
     }
@@ -8023,15 +8012,21 @@ TclNRAtProcExitObjCmd(
      * Add two callbacks: first the one to actually evaluate the tailcalled
      * command, then the one that signals TEBC to stash the first at its
      * proper place.
+     *
+     * Being lazy: add the callback, then remove it (to exploit the
+     * TclNRAddCallBack macro to build the callback)
      */
 
-    TclNRAddCallback(interp, NRAtProcExitEval, listPtr, nsPtr, NULL, NULL);
-    TclNRAddCallback(interp, NRCallTEBC, clientData, NULL, NULL, NULL);
+    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+    tailcallPtr = TOP_CB(interp);
+    TOP_CB(interp) = tailcallPtr->nextPtr;
+
+    TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), tailcallPtr, NULL, NULL);
     return TCL_OK;
 }
 
 int
-NRAtProcExitEval(
+NRTailcallEval(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -8039,11 +8034,12 @@ NRAtProcExitEval(
     Interp *iPtr = (Interp *) interp;
     Tcl_Obj *listPtr = data[0];
     Namespace *nsPtr = data[1];
+    int omit = PTR2INT(data[2]);
     int objc;
     Tcl_Obj **objv;
 
-    TclNRAddCallback(interp, AtProcExitCleanup, listPtr, NULL, NULL, NULL);
-    if (result == TCL_OK) {
+    TclNRDeferCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
+    if (!omit && (result == TCL_OK)) {
 	iPtr->lookupNsPtr = nsPtr;
 	ListObjGetElements(listPtr, objc, objv);
 	result = TclNREvalObjv(interp, objc, objv, 0, NULL);
@@ -8063,7 +8059,7 @@ NRAtProcExitEval(
 }
 
 static int
-AtProcExitCleanup(
+TailcallCleanup(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e98545e..49862ae 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.428 2009/02/25 14:56:07 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.429 2009/03/19 23:31:37 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -177,8 +177,6 @@ typedef struct BottomData {
     TEOV_callback *rootPtr;	/* State when this bytecode execution began: */
     ByteCode *codePtr;		/* constant until it returns                 */
 				/* ------------------------------------------*/
-    TEOV_callback *atExitPtr;	/* This field is used on return FROM here    */
-				/* ------------------------------------------*/
     const unsigned char *pc;	/* These fields are used on return TO this   */
     ptrdiff_t *catchTop;	/* this level: they record the state when  a */
     int cleanup;		/* new codePtr was received for NR execution */
@@ -189,7 +187,6 @@ typedef struct BottomData {
     bottomPtr->prevBottomPtr = oldBottomPtr;	\
     bottomPtr->rootPtr = TOP_CB(iPtr);		\
     bottomPtr->codePtr = codePtr;		\
-    bottomPtr->atExitPtr = NULL
 
 #define NR_DATA_BURY()				\
     bottomPtr->pc = pc;				\
@@ -207,8 +204,6 @@ typedef struct BottomData {
     esPtr = iPtr->execEnvPtr->execStackPtr;		\
     tosPtr = esPtr->tosPtr
 
-static Tcl_NRPostProc NRRestoreInterpState;
-
 #define PUSH_AUX_OBJ(objPtr)					\
     objPtr->internalRep.twoPtrValue.ptr2 = auxObjList;		\
     auxObjList = objPtr
@@ -1722,22 +1717,6 @@ TclIncrObj(
  *----------------------------------------------------------------------
  */
 
-static int
-NRRestoreInterpState(
-    ClientData data[],
-    Tcl_Interp *interp,
-    int result)
-{
-    /* FIXME
-     * Save the current state somewhere for instrospection of what happened in
-     * the atExit handlers?
-     */
-
-    Tcl_InterpState state = data[0];
-
-    return Tcl_RestoreInterpState(interp, state);
-}
-
 int
 TclExecuteByteCode(
     Tcl_Interp *interp,		/* Token for command interpreter. */
@@ -1835,8 +1814,6 @@ TclExecuteByteCode(
      */
 
     int nested = 0;
-    TEOV_callback *atExitPtr = NULL;
-    int isTailcall = 0;
 
     if (!codePtr) {
 	/*
@@ -1884,65 +1861,28 @@ TclExecuteByteCode(
 
 		codePtr = param;
 		break;
-	    case TCL_NR_ATEXIT_TYPE: {
-		/*
-		 * A request to perform a command at exit: put it in the stack
-		 * and continue exec'ing the current bytecode
-		 */
-
-		TEOV_callback *newPtr = TOP_CB(interp);
-
-		TOP_CB(interp) = newPtr->nextPtr;
-
-#ifdef TCL_COMPILE_DEBUG
-		if (traceInstructions) {
-		    fprintf(stdout, "   atProcExit request received\n");
-		}
-#endif
-		newPtr->nextPtr = bottomPtr->atExitPtr;
-		bottomPtr->atExitPtr = newPtr;
-		oldBottomPtr = bottomPtr;
-		goto returnToCaller;
-	    }
 	    case TCL_NR_TAILCALL_TYPE: {
 		/*
-		 * A request to perform a tailcall: put it at the front of the
-		 * atExit stack and abandon the current bytecode.
+		 * A request to perform a tailcall: just drop this bytecode.
 		 */
 
-		TEOV_callback *newPtr = TOP_CB(interp);
-
-		TOP_CB(interp) = newPtr->nextPtr;
-		isTailcall = 1;
 #ifdef TCL_COMPILE_DEBUG
 		if (traceInstructions) {
 		    fprintf(stdout, "   Tailcall request received\n");
 		}
 #endif
+		TEOV_callback *tailcallPtr = param;
+
+		iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+		
 		if (catchTop != initCatchTop) {
-		    isTailcall = 0;
+		    tailcallPtr->data[2] = INT2PTR(1);
 		    result = TCL_ERROR;
 		    Tcl_SetResult(interp,"Tailcall called from within a catch environment",
 			    TCL_STATIC);
+		    pc--;
 		    goto checkForCatch;
 		}
-
-		newPtr->nextPtr = NULL;
-		if (!bottomPtr->atExitPtr) {
-		    newPtr->nextPtr = NULL;
-		    bottomPtr->atExitPtr = newPtr;
-		} else {
-		    /*
-		     * There are already atExit callbacks: run last.
-		     */
-
-		    TEOV_callback *tmpPtr = bottomPtr->atExitPtr;
-
-		    while (tmpPtr->nextPtr) {
-			tmpPtr = tmpPtr->nextPtr;
-		    }
-		    tmpPtr->nextPtr = newPtr;
-		}
 		goto abnormalReturn;
 	    }
 	    case TCL_NR_YIELD_TYPE: { /*[yield] */
@@ -1954,6 +1894,7 @@ TclExecuteByteCode(
 			    TCL_STATIC);
 		    Tcl_SetErrorCode(interp, "COROUTINE_ILLEGAL_YIELD", NULL);
 		    result = TCL_ERROR;
+		    pc--;
 		    goto checkForCatch;
 		}
 		NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
@@ -1964,6 +1905,7 @@ TclExecuteByteCode(
 			    TCL_STATIC);
 		    Tcl_SetErrorCode(interp, "COROUTINE_CANT_YIELD", NULL);
 		    result = TCL_ERROR;
+		    pc--;
 		    goto checkForCatch;
 		}
 
@@ -7823,7 +7765,6 @@ TclExecuteByteCode(
     TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
 
     oldBottomPtr = bottomPtr->prevBottomPtr;
-    atExitPtr = bottomPtr->atExitPtr;
     iPtr->cmdFramePtr = bcFramePtr->nextPtr;
     TclStackFree(interp, bottomPtr);	/* free my stack */
 
@@ -7835,7 +7776,7 @@ TclExecuteByteCode(
     if (oldBottomPtr) {
 	/*
 	 * Restore the state to what it was previous to this bytecode, deal
-	 * with atExit handlers and tailcalls.
+	 * with tailcalls.
 	 */
 
 	bottomPtr = oldBottomPtr;	/* back to old bc */
@@ -7846,43 +7787,10 @@ TclExecuteByteCode(
 	NR_DATA_DIG();
 	if (TOP_CB(interp) == bottomPtr->rootPtr) {
 	    /*
-	     * The bytecode is returning, all callbacks were run. Run atExit
-	     * handlers, remove the caller's arguments and keep processing the
-	     * caller.
+	     * The bytecode is returning, all callbacks were run. Remove the
+	     * caller's arguments and keep processing the caller.
 	     */
 
-	    if (atExitPtr) {
-		/*
-		 * Find the last one
-		 */
-
-		TEOV_callback *lastPtr = atExitPtr;
-		while (lastPtr->nextPtr) {
-		    lastPtr = lastPtr->nextPtr;
-		}
-		NRE_ASSERT(lastPtr->nextPtr == NULL);
-		if (!isTailcall) {
-		    /*
-		     * Save the interp state, arrange for restoring it after
-		     * running the callbacks.
-		     */
-
-		    TclNRAddCallback(interp, NRRestoreInterpState,
-			    Tcl_SaveInterpState(interp, result), NULL,
-			    NULL, NULL);
-		}
-
-		/*
-		 * splice in the atExit callbacks and rerun all callbacks
-		 */
-
-		lastPtr->nextPtr = TOP_CB(interp);
-		TOP_CB(interp) = atExitPtr;
-		isTailcall = 0;
-		atExitPtr = NULL;
-		goto rerunCallbacks;
-	    }
-
 	    while (cleanup--) {
 		Tcl_Obj *objPtr = POP_OBJECT();
 		Tcl_DecrRefCount(objPtr);
@@ -7903,7 +7811,6 @@ TclExecuteByteCode(
 		     */
 
 		    goto nonRecursiveCallStart;
-		case TCL_NR_ATEXIT_TYPE:
 		case TCL_NR_TAILCALL_TYPE:
 		    TOP_CB(iPtr) = callbackPtr->nextPtr;
 		    TCLNR_FREE(interp, callbackPtr);
@@ -7919,32 +7826,6 @@ TclExecuteByteCode(
 	}
     }
 
-
-    if (atExitPtr) {
-	if (!isTailcall) {
-	    /*
-	     * Save the interp state, arrange for restoring it after running
-	     * the callbacks. Put the callback at the bottom of the atExit
-	     * stack.
-	     */
-
-	    Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
-	    TEOV_callback *lastPtr = atExitPtr;
-
-	    while (lastPtr->nextPtr) {
-		lastPtr = lastPtr->nextPtr;
-	    }
-	    NRE_ASSERT(lastPtr->nextPtr == NULL);
-
-	    TclNRAddCallback(interp, NRRestoreInterpState, state, NULL,
-		    NULL, NULL);
-	    lastPtr->nextPtr = TOP_CB(iPtr);
-	    TOP_CB(iPtr) = TOP_CB(iPtr)->nextPtr;
-	    lastPtr->nextPtr->nextPtr = NULL;
-	}
-	iPtr->atExitPtr = atExitPtr;
-    }
-
     iPtr->execEnvPtr->bottomPtr = NULL;
     return result;
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3f7a2dc..48473bd 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.418 2009/03/09 09:12:39 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.419 2009/03/19 23:31:37 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -1056,6 +1056,13 @@ typedef struct CallFrame {
 				 * meaning of the value is, which we do not
 				 * specify. */
     LocalCache *localCachePtr;
+    struct TEOV_callback *tailcallPtr;
+                                /* The callback implementing the call to be
+				 * executed by the command that pushed this
+				 * frame. It can be TAILCALL_NONE to signal
+				 * that we are tailcalling a frame further up
+				 * the stack. 
+				 */
 } CallFrame;
 
 #define FRAME_IS_PROC	0x1
@@ -2006,10 +2013,13 @@ typedef struct Interp {
 				 * tclOOInt.h and tclOO.c for real definition
 				 * and setup. */
 
-    struct TEOV_callback *atExitPtr;
-				/* Callbacks to be run after a command exited;
-				 * this is only set for atProcExirt or
-				 * tailcalls that fall back out of tebc. */
+    struct TEOV_callback *deferredCallbacks;
+                                /* Callbacks that are set previous to a call
+				 * to some Eval function but that actually
+				 * belong to the command that is about to be
+				 * called - ie, they should be run *before*
+				 * any tailcall is invoked.
+				 */
 
 #ifdef TCL_COMPILE_STATS
     /*
@@ -2589,7 +2599,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRAtProcExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 
@@ -4208,6 +4218,33 @@ typedef struct TEOV_callback {
 	TOP_CB(interp) = callbackPtr;					\
     }
 
+#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) {	\
+	TEOV_callback *callbackPtr;					\
+	TCLNR_ALLOC((interp), (callbackPtr));				\
+	callbackPtr->procPtr = (postProcPtr);				\
+	callbackPtr->data[0] = (ClientData)(data0);			\
+	callbackPtr->data[1] = (ClientData)(data1);			\
+	callbackPtr->data[2] = (ClientData)(data2);			\
+	callbackPtr->data[3] = (ClientData)(data3);			\
+	callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks;	\
+	((Interp *)interp)->deferredCallbacks = callbackPtr;		\
+    }
+
+#define TclNRSpliceCallbacks(interp,topPtr) {	\
+	TEOV_callback *bottomPtr = topPtr;	\
+	while (bottomPtr->nextPtr) {		\
+	    bottomPtr = bottomPtr->nextPtr;	\
+	}					\
+	bottomPtr->nextPtr = TOP_CB(interp);	\
+	TOP_CB(interp) = topPtr;		\
+    }
+
+#define TclNRSpliceDeferred(interp)					\
+    if (((Interp *)interp)->deferredCallbacks) {			\
+	TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
+	((Interp *)interp)->deferredCallbacks = NULL;			\
+    }
+
 #if NRE_USE_SMALL_ALLOC
 #define TCLNR_ALLOC(interp, ptr) \
     TclSmallAllocEx(interp, sizeof(TEOV_callback), (ptr))
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 20b28eb..8caf7db 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,10 +23,11 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.189 2009/02/10 22:50:07 nijtmans Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.190 2009/03/19 23:31:37 msofer Exp $
  */
 
 #include "tclInt.h"
+#include "tclCompile.h" /* just for NRCommand */
 
 /*
  * Thread-local storage used to avoid having a global lock on data that is not
@@ -428,7 +429,8 @@ Tcl_PushCallFrame(
     framePtr->compiledLocals = NULL;
     framePtr->clientData = NULL;
     framePtr->localCachePtr = NULL;
-
+    framePtr->tailcallPtr = NULL;
+    
     /*
      * Push the new call frame onto the interpreter's stack of procedure call
      * frames making it the current frame.
@@ -454,6 +456,7 @@ Tcl_PushCallFrame(
  *	Modifies the call stack of the interpreter. Resets various fields of
  *	the popped call frame. If a namespace has been deleted and has no more
  *	activations on the call stack, the namespace is destroyed.
+ *      Schedules a tailcall if one is present. 
  *
  *----------------------------------------------------------------------
  */
@@ -505,6 +508,30 @@ Tcl_PopCallFrame(
 	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
     }
     framePtr->nsPtr = NULL;
+
+    if (framePtr->tailcallPtr) {
+	/*
+	 * Find the splicing spot: right before the NRCommand of the thing being
+	 * tailcalled. Note that we skip NRCommands marked in data[1] (used by
+	 * command redirectors) 
+	 */
+
+	TEOV_callback *tailcallPtr, *runPtr;
+	
+	for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+	    if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
+		break;
+	    }
+	}
+	if (!runPtr) {
+	    Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
+	}
+
+	tailcallPtr = framePtr->tailcallPtr;
+	
+	tailcallPtr->nextPtr = runPtr->nextPtr;
+	runPtr->nextPtr = tailcallPtr;
+    }
 }
 
 /*
diff --git a/tests/coroutine.test b/tests/coroutine.test
new file mode 100644
index 0000000..fd3a3a1
--- /dev/null
+++ b/tests/coroutine.test
@@ -0,0 +1,544 @@
+# Commands covered:  coroutine, yield, [info coroutine]
+#
+# This file contains a collection of tests for experimental commands that are
+# found in ::tcl::unsupported. The tests will migrate to normal test files
+# if/when the commands find their way into the core.
+#
+# Copyright (c) 2008 by Miguel Sofer.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: coroutine.test,v 1.1 2009/03/19 23:31:37 msofer Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+
+testConstraint testnrelevels [llength [info commands testnrelevels]]
+
+if {[testConstraint testnrelevels]} {
+    namespace eval testnre {
+	#
+	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
+	# cmdFrame level, callFrame level, tosPtr and callback depth 
+	#
+	variable last [testnrelevels] 
+	proc depthDiff {} {
+	    variable last
+	    set depth [testnrelevels]
+	    set res {}
+	    foreach t $depth l $last {
+		lappend res [expr {$t-$l}]
+	    }
+	    set last $depth
+	    return $res
+	}
+	proc setabs {} {
+	    uplevel 1 variable abs -[lindex [testnrelevels] 0]
+	}
+
+	variable body0 {
+	    set x [depthDiff]
+	    if {[incr i] > 10} {
+		variable abs
+		incr abs [lindex [testnrelevels] 0]
+		return [list [lrange $x 0 3] $abs]
+	    }
+	}
+	proc makebody txt {
+	    variable body0
+	    return "$body0; $txt"
+	}
+	namespace export *
+    }
+    namespace import testnre::*
+}
+
+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 coroutine-1.1 {coroutine basic} -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 coroutine-1.2 {coroutine basic} -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 coroutine-1.3 {yield returns new arg} -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 coroutine-1.4 {yield in nested proc} -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 coroutine-1.5 {just yield} -body {
+    coroutine foo yield
+    list [foo] [catch foo msg] $msg
+} -cleanup {
+    unset msg
+} -result {{} 1 {invalid command name "foo"}}
+
+test coroutine-1.6 {just yield} -body {
+    coroutine foo [list yield]
+    list [foo] [catch foo msg] $msg
+} -cleanup {
+    unset msg
+} -result {{} 1 {invalid command name "foo"}}
+
+test coroutine-1.7 {yield in nested uplevel} -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 coroutine-1.8 {yield in nested uplevel} -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 coroutine-1.9 {yield in nested eval} -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
+} -result {0 10 20}
+
+test coroutine-1.10 {yield in nested eval} -setup {
+    set body {
+	# init
+	set i    $start
+	set imax $stop
+	yield
+	
+	while {$i < $imax} {
+	    eval 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 {
+    unset body res
+} -result {0 10 20}
+
+test coroutine-1.11 {yield outside 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 coroutine-1.12 {proc as 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 coroutine-2.1 {self deletion on return} -body {
+    coroutine foo set x 3
+    foo
+} -returnCodes error -result {invalid command name "foo"}
+
+test coroutine-2.2 {self deletion on return} -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 coroutine-2.3 {self deletion on error return} -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 coroutine-2.4 {self deletion on other return} -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 coroutine-2.5 {deletion of suspended 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 coroutine-2.6 {deletion of running 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"}}
+
+test coroutine-3.1 {info level computation} -setup {
+    proc a {} {while 1 {yield [info level]}}
+    proc b {} foo
+} -body {
+    # note that coroutines execute in uplevel #0
+    set l0 [coroutine foo a]
+    set l1 [foo]
+    set l2 [b]
+    list $l0 $l1 $l2
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {1 1 1}
+
+test coroutine-3.2 {info frame computation} -setup {
+    proc a {} {while 1 {yield [info frame]}}
+    proc b {} foo
+} -body {
+    set l0 [coroutine foo a]
+    set l1 [foo]
+    set l2 [b]
+    expr {$l2 - $l1}
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result 1
+
+test coroutine-3.3 {info coroutine} -setup {
+    proc a {} {info coroutine}
+    proc b {} a
+} -body {
+    b
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {}
+
+test coroutine-3.4 {info coroutine} -setup {
+    proc a {} {info coroutine}
+    proc b {} a
+} -body {
+    coroutine foo b
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result ::foo
+
+test coroutine-3.5 {info coroutine} -setup {
+    proc a {} {info coroutine}
+    proc b {} {rename [info coroutine] {}; a}
+} -body {
+    coroutine foo b
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {}
+
+
+test coroutine-4.1 {bug #2093188} -setup {
+    proc foo {} {
+	set v 1
+	trace add variable v {write unset} bar
+	yield
+	set v 2
+	yield
+	set v 3
+    }
+    proc bar args {lappend ::res $args}
+    coroutine a foo
+} -body {
+    list [a] [a] $::res
+} -cleanup {
+    rename foo {}
+    rename bar {}
+    unset ::res
+} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
+
+test coroutine-4.2 {bug #2093188} -setup {
+    proc foo {} {
+	set v 1
+	trace add variable v {read unset} bar
+	yield
+	set v 2
+	set v
+	yield
+	set v 3
+    }
+    proc bar args {lappend ::res $args}
+    coroutine a foo
+} -body {
+    list [a] [a] $::res
+} -cleanup {
+    rename foo {}
+    rename bar {}
+    unset ::res
+} -result {{} 3 {{v {} read} {v {} unset}}}
+
+test coroutine-4.3 {bug #2093947} -setup {
+    proc foo {} {
+	set v 1
+	trace add variable v {write unset} bar
+	yield
+	set v 2
+	yield
+	set v 3
+    }
+    proc bar args {lappend ::res $args}
+} -body {
+    coroutine a foo
+    a
+    a
+    coroutine a foo
+    a
+    rename a {}
+    set ::res
+} -cleanup {
+    rename foo {}
+    rename bar {}
+    unset ::res
+} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
+
+test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
+-setup {
+    proc nestedYield {{val {}}} {
+	yield $val
+    }
+    proc getNumLevel {} {
+	# remove the level for this proc's call
+	expr {[lindex [testnrelevels] 1] - 1}
+    }
+    proc relativeLevel base {
+	# remove the level for this proc's call	
+	expr {[getNumLevel] - $base - 1}
+    }
+    proc foo {} {
+	while 1 {
+	    nestedYield
+	}
+    }
+    set res {}
+} -body {
+    set base [getNumLevel]
+    lappend res [relativeLevel $base]
+    eval {coroutine a foo}
+
+    # back to base level
+    lappend res [relativeLevel $base]
+    a
+    lappend res [relativeLevel $base]
+    eval a
+    lappend res [relativeLevel $base]
+    eval {eval a}
+    lappend res [relativeLevel $base]
+    rename a {}
+    lappend res [relativeLevel $base]
+    set res
+} -cleanup {
+    rename foo {}
+    rename nestedYield {}
+    rename getNumLevel {}
+    rename relativeLevel {}
+    unset res
+} -result {0 0 0 0 0 0}
+
+test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
+-setup {
+    proc nestedYield {{val {}}} {
+	yield $val
+    }
+    proc getNumLevel {} {
+	# remove the level for this proc's call
+	expr {[lindex [testnrelevels] 1] - 1}
+    }
+    proc relativeLevel base {
+	# remove the level for this proc's call	
+	expr {[getNumLevel] - $base - 1}
+    }
+    proc foo base {
+	while 1 {
+	    set base [nestedYield [relativeLevel $base]]
+	}
+    }
+    set res {}
+} -body {
+    lappend res [eval {coroutine a foo [getNumLevel]}]
+    lappend res [a [getNumLevel]]
+    lappend res [eval {a [getNumLevel]}]
+    lappend res [eval {eval {a [getNumLevel]}}]
+    set base [lindex $res 0]
+    foreach x $res[set res {}] {
+	lappend res [expr {$x-$base}]
+    }
+    set res
+} -cleanup {
+    rename a {}
+    rename foo {}
+    rename nestedYield {}
+    rename getNumLevel {}
+    rename relativeLevel {}
+    unset res
+} -result {0 0 0 0}
+
+
+
+# cleanup
+::tcltest::cleanupTests
+
+
+unset -nocomplain lambda
+
+if {[testConstraint testnrelevels]} {
+    namespace forget testnre::*
+    namespace delete testnre
+}
+
+return
diff --git a/tests/tailcall.test b/tests/tailcall.test
new file mode 100644
index 0000000..a3cf88e
--- /dev/null
+++ b/tests/tailcall.test
@@ -0,0 +1,428 @@
+# Commands covered:  tailcall
+#
+# This file contains a collection of tests for experimental commands that are
+# found in ::tcl::unsupported. The tests will migrate to normal test files
+# if/when the commands find their way into the core.
+#
+# Copyright (c) 2008 by Miguel Sofer.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tailcall.test,v 1.1 2009/03/19 23:31:37 msofer Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+
+testConstraint testnrelevels [llength [info commands testnrelevels]]
+
+#
+# The tests that risked blowing the C stack on failure have been removed: we
+# can now actually measure using testnrelevels.
+#
+
+if {[testConstraint testnrelevels]} {
+    namespace eval testnre {
+	#
+	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
+	# cmdFrame level, callFrame level, tosPtr and callback depth 
+	#
+	variable last [testnrelevels] 
+	proc depthDiff {} {
+	    variable last
+	    set depth [testnrelevels]
+	    set res {}
+	    foreach t $depth l $last {
+		lappend res [expr {$t-$l}]
+	    }
+	    set last $depth
+	    return $res
+	}
+	proc setabs {} {
+	    uplevel 1 variable abs -[lindex [testnrelevels] 0]
+	}
+
+	variable body0 {
+	    set x [depthDiff]
+	    if {[incr i] > 10} {
+		variable abs
+		incr abs [lindex [testnrelevels] 0]
+		return [list [lrange $x 0 3] $abs]
+	    }
+	}
+	proc makebody txt {
+	    variable body0
+	    return "$body0; $txt"
+	}
+	namespace export *
+    }
+    namespace import testnre::*
+}
+
+test tailcall-0 {tailcall is constant space} -constraints testnrelevels -setup {
+    proc a i {
+	if {[incr i] > 10} {
+	    return [depthDiff]
+	}
+	depthDiff
+	tailcall a $i
+    }
+} -body {
+    a 0
+} -cleanup {
+    rename a {}
+} -result {0 0 0 0 0 0}
+
+test tailcall-1 {tailcall} -body {
+    namespace eval a {
+	variable x *::a
+	proc xset {} {
+	    set tmp {}
+	    set ns {[namespace current]}
+	    set level [info level]
+	    for {set i 0} {$i <= [info level]} {incr i} {
+		uplevel #$i "set x $i$ns"
+		lappend tmp "$i [info level $i]"
+	    }
+	    lrange $tmp 1 end
+	}
+	proc foo {} {tailcall xset; set x noreach}
+    }
+    namespace eval b {
+	variable x *::b
+	proc xset args {error b::xset}
+	proc moo {} {set x 0; variable y [::a::foo]; set x}
+    }
+    variable x *::
+    proc xset args {error ::xset}
+    list [::b::moo] | $x $a::x $b::x | $::b::y 
+} -cleanup {
+    unset x
+    rename xset {}
+    namespace delete a b
+} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
+
+
+test tailcall-2 {tailcall in non-proc} -body {
+    namespace eval a [list tailcall set x 1]
+} -match glob -result *tailcall* -returnCodes error
+
+test tailcall-3 {tailcall falls off tebc} -body {
+    unset -nocomplain x
+    proc foo {} {tailcall set x 1}
+    list [catch foo msg] $msg [set x]
+} -cleanup {
+    rename foo {}
+    unset x
+} -result {0 1 1}
+
+test tailcall-4 {tailcall falls off tebc} -body {
+    set x 2
+    proc foo {} {tailcall set x 1}
+    foo
+    set x
+} -cleanup {
+    rename foo {}
+    unset x
+} -result 1
+
+test tailcall-5 {tailcall falls off tebc} -body {
+    set x 2
+    namespace eval bar {
+	variable x 3
+	proc foo {} {tailcall set x 1}
+    }
+    bar::foo
+    list $x $bar::x
+} -cleanup {
+    unset x
+    namespace delete bar
+} -result {1 3}
+
+test tailcall-6 {tailcall does remove callframes} -body {
+    proc foo {} {info level}
+    proc moo {} {tailcall foo}
+    proc boo {} {expr {[moo] - [info level]}}
+    boo
+} -cleanup {
+    rename foo {}
+    rename moo {}
+    rename boo {}
+} -result 1
+
+test tailcall-7 {tailcall does return} -setup {
+    namespace eval ::foo {
+	variable res {}
+	proc a {} {
+	    variable res
+	    append res a
+	    tailcall set x 1
+	    append res a
+	}
+	proc b {} {
+	    variable res
+	    append res b
+	    a
+	    append res b
+	}
+	proc c {} {
+	    variable res
+	    append res c
+	    b
+	    append res c
+	}
+    }
+} -body {
+    namespace eval ::foo c
+} -cleanup {
+    namespace delete ::foo
+} -result cbabc
+
+test tailcall-8 {tailcall tailcall} -setup {
+    namespace eval ::foo {
+	variable res {}
+	proc a {} {
+	    variable res
+	    append res a
+	    tailcall tailcall set x 1
+	    append res a
+	}
+	proc b {} {
+	    variable res
+	    append res b
+	    a
+	    append res b
+	}
+	proc c {} {
+	    variable res
+	    append res c
+	    b
+	    append res c
+	}
+    }
+} -body {
+    namespace eval ::foo c
+} -cleanup {
+    namespace delete ::foo
+} -match glob -result *tailcall* -returnCodes error
+
+test tailcall-9 {tailcall factorial} -setup {
+    proc fact {n {b 1}} {
+	if {$n == 1} {
+	    return $b
+	}
+	tailcall fact [expr {$n-1}] [expr {$n*$b}]
+    }
+} -body {
+    list [fact 1] [fact 5] [fact 10] [fact 15]
+} -cleanup {
+    rename fact {}
+} -result {1 120 3628800 1307674368000}
+
+test tailcall-10 {tailcall and eval} -constraints {knownBug} -setup {
+    proc a {} {
+	eval [list tailcall lappend ::x 2]
+	set ::x 1
+    }
+} -body {
+    list [a] $::x
+} -cleanup {
+    unset -nocomplain ::x
+} -result {1 2}
+
+test tailcall-11 {tailcall and uplevel} -constraints {knownBug} -setup {
+    proc a {} {
+	uplevel 1 [list tailcall set ::x 2]
+	set ::x 1
+    }
+} -body {
+    list [a] $::x
+} -cleanup {
+    unset -nocomplain ::x
+} -result {1 2}
+
+# cleanup
+::tcltest::cleanupTests
+
+
+test tailcall-12.1 {[Bug 2649975]} -setup {
+    proc dump {{text {}}} {
+	set text [uplevel 1 [list subst $text]]
+	set l [expr {[info level] -1}]
+	if {$text eq {}} {
+	    set text [info level $l]
+	}
+	puts "$l: $text"
+    }
+    # proc dump args {}
+    proc bravo {} {
+	upvar 1 v w
+	dump {inside bravo, v -> $w}
+	set v "procedure bravo"
+	#uplevel 1 [list delta ::betty]
+	uplevel 1 {delta ::betty}
+	return $::resolution
+    }
+    proc delta name {
+	upvar 1 v w
+	dump {inside delta, v -> $w}
+	set v "procedure delta"
+	tailcall foxtrot
+    }
+    proc foxtrot {} {
+	upvar 1 v w
+	dump {inside foxtrot, v -> $w}
+	global resolution
+	set ::resolution $w
+    }
+    set v "global level"
+} -body {
+    set result [bravo]
+    if {$result ne $v} {
+	puts "v should have been found at $v but was found in $result"
+    }
+} -cleanup {
+    unset v
+    rename dump {}
+    rename bravo {}
+    rename delta {}
+    rename foxtrot {}
+} -output {1: inside bravo, v -> global level
+1: inside delta, v -> global level
+1: inside foxtrot, v -> global level
+}
+
+test tailcall-12.2 {[Bug 2649975]} -setup {
+    proc dump {{text {}}} {
+	set text [uplevel 1 [list subst $text]]
+	set l [expr {[info level] -1}]
+	if {$text eq {}} {
+	    set text [info level $l]
+	}
+	puts "$l: $text"
+    }
+    # proc dump args {}
+    set v "global level"
+    oo::class create foo { # like connection
+	method alpha {} {  # like connections 'tables' method
+	    dump
+	    upvar 1 v w
+	    dump {inside foo's alpha, v resolves to $w}
+	    set v "foo's method alpha"
+	    dump {foo's alpha is calling [self] bravo - v should resolve at global level}
+	    set result [uplevel 1 [list [self] bravo]]
+	    dump {exiting from foo's alpha}
+	    return $result
+	}
+	method bravo {} {  # like connections 'foreach' method
+	    dump
+	    upvar 1 v w
+	    dump {inside foo's bravo, v resolves to $w}
+	    set v "foo's method bravo"
+	    dump {foo's bravo is calling charlie to create barney}
+	    set barney [my charlie ::barney]
+	    dump {foo's bravo is calling bravo on $barney}
+	    dump {v should resolve at global scope there}
+	    set result [uplevel 1 [list $barney bravo]]
+	    dump {exiting from foo's bravo}
+	    return $result
+	}
+	method charlie {name} {  # like tdbc prepare
+	    dump
+	    set v "foo's method charlie"
+	    dump {tailcalling bar's constructor}
+	    tailcall ::bar create $name
+	}
+    }
+    oo::class create bar { # like statement
+	method  bravo {} {   # like statement foreach method
+	    dump
+	    upvar 1 v w
+	    dump {inside bar's bravo, v is resolving to $w}
+	    set v "bar's method bravo"
+	    dump {calling delta to construct betty - v should resolve global there}
+	    uplevel 1 [list [self] delta ::betty]
+	    dump {exiting from bar's bravo}
+	    return [::betty whathappened]
+	}
+	method delta {name} {    # like statement execute method
+	    dump
+	    upvar 1 v w
+	    dump {inside bar's delta, v is resolving to $w}
+	    set v "bar's method delta"
+	    dump {tailcalling to construct $name as instance of grill}
+	    dump {v should resolve at global level in grill's constructor}
+	    dump {grill's constructor should run at level [info level]}
+	    tailcall grill create $name
+	}
+    }
+    oo::class create grill {
+	variable resolution
+	constructor {} {
+	    dump
+	    upvar 1 v w
+	    dump "in grill's constructor, v resolves to $w"
+	    set resolution $w
+	}
+	method whathappened {} {
+	    return $resolution
+	}
+    }
+    foo create fred
+} -body {
+    set result [fred alpha]
+    if {$result ne "global level"} {
+	puts "v should have been found at global level but was found in $result"
+    }
+} -cleanup {
+    unset result
+    rename fred {}
+    rename dump {}
+    rename foo {}
+    rename bar {}
+    rename grill {}
+} -output {1: fred alpha
+1: inside foo's alpha, v resolves to global level
+1: foo's alpha is calling ::fred bravo - v should resolve at global level
+1: ::fred bravo
+1: inside foo's bravo, v resolves to global level
+1: foo's bravo is calling charlie to create barney
+2: my charlie ::barney
+2: tailcalling bar's constructor
+1: foo's bravo is calling bravo on ::barney
+1: v should resolve at global scope there
+1: ::barney bravo
+1: inside bar's bravo, v is resolving to global level
+1: calling delta to construct betty - v should resolve global there
+1: ::barney delta ::betty
+1: inside bar's delta, v is resolving to global level
+1: tailcalling to construct ::betty as instance of grill
+1: v should resolve at global level in grill's constructor
+1: grill's constructor should run at level 1
+1: grill create ::betty
+1: in grill's constructor, v resolves to global level
+1: exiting from bar's bravo
+1: exiting from foo's bravo
+1: exiting from foo's alpha
+}
+
+test tailcall-12.3 {[Bug 2695587]} -setup {
+    proc a {} {
+	list [catch {tailcall foo} msg] $msg
+    }
+} -body {
+    a
+} -cleanup {
+    rename a {}
+} -result {1 {Tailcall called from within a catch environment}}
+
+
+if {[testConstraint testnrelevels]} {
+    namespace forget testnre::*
+    namespace delete testnre
+}
+
+# cleanup
+::tcltest::cleanupTests
diff --git a/tests/unsupported.test b/tests/unsupported.test
deleted file mode 100644
index 0c706b8..0000000
--- a/tests/unsupported.test
+++ /dev/null
@@ -1,914 +0,0 @@
-# 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
-# if/when the commands find their way into the core.
-#
-# Copyright (c) 2008 by Miguel Sofer.
-#
-# 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.15 2008/10/14 18:49:47 dgp Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
-    namespace import -force ::tcltest::*
-}
-
-testConstraint testnrelevels [llength [info commands testnrelevels]]
-testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
-
-if {[namespace exists tcl::unsupported]} {
-    namespace eval tcl::unsupported namespace export *
-    namespace import tcl::unsupported::*
-}
-
-#
-# The tests that risked blowing the C stack on failure have been removed: we
-# can now actually measure using testnrelevels.
-#
-
-if {[testConstraint testnrelevels]} {
-    namespace eval testnre {
-	#
-	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
-	# cmdFrame level, callFrame level, tosPtr and callback depth 
-	#
-	variable last [testnrelevels] 
-	proc depthDiff {} {
-	    variable last
-	    set depth [testnrelevels]
-	    set res {}
-	    foreach t $depth l $last {
-		lappend res [expr {$t-$l}]
-	    }
-	    set last $depth
-	    return $res
-	}
-	proc setabs {} {
-	    uplevel 1 variable abs -[lindex [testnrelevels] 0]
-	}
-
-	variable body0 {
-	    set x [depthDiff]
-	    if {[incr i] > 10} {
-		variable abs
-		incr abs [lindex [testnrelevels] 0]
-		return [list [lrange $x 0 3] $abs]
-	    }
-	}
-	proc makebody txt {
-	    variable body0
-	    return "$body0; $txt"
-	}
-	namespace export *
-    }
-    namespace import testnre::*
-}
-
-#
-# Test atProcExit
-#
-
-test unsupported-A.1 {atProcExit works} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit set ::x 1
-	set x 2
-	set y $x
-	set x 3
-    }
-    proc b {} a
-} -body {
-    list [b] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-    rename b {}
-} -result {3 1 2}
-
-test unsupported-A.2 {atProcExit} -constraints {atProcExit} -setup {
-    variable x x y x
-    proc a {} {
-	variable x 0 y 0
-	atProcExit set ::x 1
-	set x 2
-	set y $x
-	set x 3
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {3 1 2}
-
-test unsupported-A.3 {atProcExit} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4 3 1} {0 {0 2}}}
-
-test unsupported-A.4 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	error foo
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -returnCodes error -result foo
-
-test unsupported-A.5 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit error foo
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4 3} {0 {0 2}}}
-
-test unsupported-A.6 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit error foo
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4} {0 {0 2}}}
-
-test unsupported-A.7 {atProcExit non-proc} -constraints {atProcExit} -body {
-    atProcExit set x 2
-    set x 1
-} -cleanup {
-    unset -nocomplain x
-} -match glob -result *atProcExit* -returnCodes error
-
-test unsupported-A.8 {atProcExit and eval} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	eval atProcExit lappend ::x 2
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-A9 {atProcExit and uplevel} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	uplevel 1 [list atProcExit set ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-
-#
-# Test tailcalls
-#
-
-test unsupported-T.0 {tailcall is constant space} -constraints testnrelevels -setup {
-    proc a i {
-	if {[incr i] > 10} {
-	    return [depthDiff]
-	}
-	depthDiff
-	tailcall a $i
-    }
-} -body {
-    a 0
-} -cleanup {
-    rename a {}
-} -result {0 0 0 0 0 0}
-
-test unsupported-T.1 {tailcall} -body {
-    namespace eval a {
-	variable x *::a
-	proc xset {} {
-	    set tmp {}
-	    set ns {[namespace current]}
-	    set level [info level]
-	    for {set i 0} {$i <= [info level]} {incr i} {
-		uplevel #$i "set x $i$ns"
-		lappend tmp "$i [info level $i]"
-	    }
-	    lrange $tmp 1 end
-	}
-	proc foo {} {tailcall xset; set x noreach}
-    }
-    namespace eval b {
-	variable x *::b
-	proc xset args {error b::xset}
-	proc moo {} {set x 0; variable y [::a::foo]; set x}
-    }
-    variable x *::
-    proc xset args {error ::xset}
-    list [::b::moo] | $x $a::x $b::x | $::b::y 
-} -cleanup {
-    unset x
-    rename xset {}
-    namespace delete a b
-} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
-
-
-test unsupported-T.2 {tailcall in non-proc} -body {
-    namespace eval a [list tailcall set x 1]
-} -match glob -result *tailcall* -returnCodes error
-
-test unsupported-T.3 {tailcall falls off tebc} -body {
-    unset -nocomplain x
-    proc foo {} {tailcall set x 1}
-    list [catch foo msg] $msg [set x]
-} -cleanup {
-    rename foo {}
-    unset x
-} -result {0 1 1}
-
-test unsupported-T.4 {tailcall falls off tebc} -body {
-    set x 2
-    proc foo {} {tailcall set x 1}
-    foo
-    set x
-} -cleanup {
-    rename foo {}
-    unset x
-} -result 1
-
-test unsupported-T.5 {tailcall falls off tebc} -body {
-    set x 2
-    namespace eval bar {
-	variable x 3
-	proc foo {} {tailcall set x 1}
-    }
-    bar::foo
-    list $x $bar::x
-} -cleanup {
-    unset x
-    namespace delete bar
-} -result {1 3}
-
-test unsupported-T.6 {tailcall does remove callframes} -body {
-    proc foo {} {info level}
-    proc moo {} {tailcall foo}
-    proc boo {} {expr {[moo] - [info level]}}
-    boo
-} -cleanup {
-    rename foo {}
-    rename moo {}
-    rename boo {}
-} -result 1
-
-test unsupported-T.7 {tailcall does return} -setup {
-    namespace eval ::foo {
-	variable res {}
-	proc a {} {
-	    variable res
-	    append res a
-	    tailcall set x 1
-	    append res a
-	}
-	proc b {} {
-	    variable res
-	    append res b
-	    a
-	    append res b
-	}
-	proc c {} {
-	    variable res
-	    append res c
-	    b
-	    append res c
-	}
-    }
-} -body {
-    namespace eval ::foo c
-} -cleanup {
-    namespace delete ::foo
-} -result cbabc
-
-test unsupported-T.8 {tailcall tailcall} -setup {
-    namespace eval ::foo {
-	variable res {}
-	proc a {} {
-	    variable res
-	    append res a
-	    tailcall tailcall set x 1
-	    append res a
-	}
-	proc b {} {
-	    variable res
-	    append res b
-	    a
-	    append res b
-	}
-	proc c {} {
-	    variable res
-	    append res c
-	    b
-	    append res c
-	}
-    }
-} -body {
-    namespace eval ::foo c
-} -cleanup {
-    namespace delete ::foo
-} -match glob -result *tailcall* -returnCodes error
-
-test unsupported-T.9 {tailcall factorial} -setup {
-    proc fact {n {b 1}} {
-	if {$n == 1} {
-	    return $b
-	}
-	tailcall fact [expr {$n-1}] [expr {$n*$b}]
-    }
-} -body {
-    list [fact 1] [fact 5] [fact 10] [fact 15]
-} -cleanup {
-    rename fact {}
-} -result {1 120 3628800 1307674368000}
-
-test unsupported-T.10 {tailcall and eval} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	eval [list tailcall lappend ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-T.11 {tailcall and uplevel} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	uplevel 1 [list tailcall set ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-#
-#  Test both together
-#
-
-test unsupported-AT.1 {atProcExit and tailcall} -constraints {
-    atProcExit
-} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	tailcall lappend ::x 6
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {{0 2 3 1 6} {0 2 3 1 6} 0}
-
-#
-# Test coroutines
-#
-
-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} -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} -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} -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} -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} -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} -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} -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} -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} -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
-} -result {0 10 20}
-
-test unsupported-C.1.10 {yield in nested eval} -setup {
-    set body {
-	# init
-	set i    $start
-	set imax $stop
-	yield
-	
-	while {$i < $imax} {
-	    eval 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 {
-    unset body res
-} -result {0 10 20}
-
-test unsupported-C.1.11 {yield outside 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} -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} -body {
-    coroutine foo set x 3
-    foo
-} -returnCodes error -result {invalid command name "foo"}
-
-test unsupported-C.2.2 {self deletion on return} -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} -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} -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} -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} -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"}}
-
-test unsupported-C.3.1 {info level computation} -setup {
-    proc a {} {while 1 {yield [info level]}}
-    proc b {} foo
-} -body {
-    # note that coroutines execute in uplevel #0
-    set l0 [coroutine foo a]
-    set l1 [foo]
-    set l2 [b]
-    list $l0 $l1 $l2
-} -cleanup {
-    rename a {}
-    rename b {}
-} -result {1 1 1}
-
-test unsupported-C.3.2 {info frame computation} -setup {
-    proc a {} {while 1 {yield [info frame]}}
-    proc b {} foo
-} -body {
-    set l0 [coroutine foo a]
-    set l1 [foo]
-    set l2 [b]
-    expr {$l2 - $l1}
-} -cleanup {
-    rename a {}
-    rename b {}
-} -result 1
-
-test unsupported-C.3.3 {info coroutine} -setup {
-    proc a {} {info coroutine}
-    proc b {} a
-} -body {
-    b
-} -cleanup {
-    rename a {}
-    rename b {}
-} -result {}
-
-test unsupported-C.3.4 {info coroutine} -setup {
-    proc a {} {info coroutine}
-    proc b {} a
-} -body {
-    coroutine foo b
-} -cleanup {
-    rename a {}
-    rename b {}
-} -result ::foo
-
-test unsupported-C.3.5 {info coroutine} -setup {
-    proc a {} {info coroutine}
-    proc b {} {rename [info coroutine] {}; a}
-} -body {
-    coroutine foo b
-} -cleanup {
-    rename a {}
-    rename b {}
-} -result {}
-
-
-test unsupported-C.4.1 {bug #2093188} -setup {
-    proc foo {} {
-	set v 1
-	trace add variable v {write unset} bar
-	yield
-	set v 2
-	yield
-	set v 3
-    }
-    proc bar args {lappend ::res $args}
-    coroutine a foo
-} -body {
-    list [a] [a] $::res
-} -cleanup {
-    rename foo {}
-    rename bar {}
-    unset ::res
-} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
-
-test unsupported-C.4.2 {bug #2093188} -setup {
-    proc foo {} {
-	set v 1
-	trace add variable v {read unset} bar
-	yield
-	set v 2
-	set v
-	yield
-	set v 3
-    }
-    proc bar args {lappend ::res $args}
-    coroutine a foo
-} -body {
-    list [a] [a] $::res
-} -cleanup {
-    rename foo {}
-    rename bar {}
-    unset ::res
-} -result {{} 3 {{v {} read} {v {} unset}}}
-
-test unsupported-C.4.3 {bug #2093947} -setup {
-    proc foo {} {
-	set v 1
-	trace add variable v {write unset} bar
-	yield
-	set v 2
-	yield
-	set v 3
-    }
-    proc bar args {lappend ::res $args}
-} -body {
-    coroutine a foo
-    a
-    a
-    coroutine a foo
-    a
-    rename a {}
-    set ::res
-} -cleanup {
-    rename foo {}
-    rename bar {}
-    unset ::res
-} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
-
-test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelevels} \
--setup {
-    proc nestedYield {{val {}}} {
-	yield $val
-    }
-    proc getNumLevel {} {
-	# remove the level for this proc's call
-	expr {[lindex [testnrelevels] 1] - 1}
-    }
-    proc relativeLevel base {
-	# remove the level for this proc's call	
-	expr {[getNumLevel] - $base - 1}
-    }
-    proc foo {} {
-	while 1 {
-	    nestedYield
-	}
-    }
-    set res {}
-} -body {
-    set base [getNumLevel]
-    lappend res [relativeLevel $base]
-    eval {coroutine a foo}
-
-    # back to base level
-    lappend res [relativeLevel $base]
-    a
-    lappend res [relativeLevel $base]
-    eval a
-    lappend res [relativeLevel $base]
-    eval {eval a}
-    lappend res [relativeLevel $base]
-    rename a {}
-    lappend res [relativeLevel $base]
-    set res
-} -cleanup {
-    rename foo {}
-    rename nestedYield {}
-    rename getNumLevel {}
-    rename relativeLevel {}
-    unset res
-} -result {0 0 0 0 0 0}
-
-test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \
--setup {
-    proc nestedYield {{val {}}} {
-	yield $val
-    }
-    proc getNumLevel {} {
-	# remove the level for this proc's call
-	expr {[lindex [testnrelevels] 1] - 1}
-    }
-    proc relativeLevel base {
-	# remove the level for this proc's call	
-	expr {[getNumLevel] - $base - 1}
-    }
-    proc foo base {
-	while 1 {
-	    set base [nestedYield [relativeLevel $base]]
-	}
-    }
-    set res {}
-} -body {
-    lappend res [eval {coroutine a foo [getNumLevel]}]
-    lappend res [a [getNumLevel]]
-    lappend res [eval {a [getNumLevel]}]
-    lappend res [eval {eval {a [getNumLevel]}}]
-    set base [lindex $res 0]
-    foreach x $res[set res {}] {
-	lappend res [expr {$x-$base}]
-    }
-    set res
-} -cleanup {
-    rename a {}
-    rename foo {}
-    rename nestedYield {}
-    rename getNumLevel {}
-    rename relativeLevel {}
-    unset res
-} -result {0 0 0 0}
-
-
-
-# cleanup
-::tcltest::cleanupTests
-
-
-unset -nocomplain lambda
-
-if {[testConstraint atProcExit]} {
-    namespace forget tcl::unsupported::atProcExit
-}
-
-if {[testConstraint testnrelevels]} {
-    namespace forget testnre::*
-    namespace delete testnre
-}
-
-return
-- 
cgit v0.12