From 90bd6886192a7f8aba161a9c45eb000b9e59e69c Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Sat, 5 Dec 2009 21:30:05 +0000
Subject: 	* generic/tclBasic.c:  Fixed things so that you can tailcall 
 * generic/tclNamesp.c: properly out of a coroutine. 	* tests/tailcall.test:

	* generic/tclInterp.c: Fixed tailcalls for same-interp aliases (no
	test)
---
 ChangeLog           |  9 +++++++++
 generic/tclBasic.c  |  3 ++-
 generic/tclInterp.c |  4 ++--
 generic/tclNamesp.c | 25 ++++++++++++++++++++++++-
 tests/tailcall.test | 19 ++++++++++++++++++-
 5 files changed, 55 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 24089ba..c8acf07 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2009-12-05  Miguel Sofer  <msofer@users.sf.net>
+ 
+	* generic/tclBasic.c:  Fixed things so that you can tailcall 
+	* generic/tclNamesp.c: properly out of a coroutine.
+	* tests/tailcall.test:
+
+	* generic/tclInterp.c: Fixed tailcalls for same-interp aliases (no
+	test)
+	
 2009-12-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* library/safe.tcl (::safe::AliasEncoding): Make the safe encoding
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b0cc7f6..ce330b1 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.410 2009/11/18 21:59:50 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.411 2009/12/05 21:30:05 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -8783,6 +8783,7 @@ TclNRCoroutineObjCmd(
     corPtr->auxNumLevels = iPtr->numLevels;
 
     TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
+    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
     return TclNRRunCallbacks(interp,
 	    TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
 }
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 3c841d9..edf31ff 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.106 2009/10/06 16:55:59 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.107 2009/12/05 21:30:05 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1805,7 +1805,7 @@ AliasNRCmd(
      */
 
     if (isRootEnsemble) {
-	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+	TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
     }
     iPtr->evalFlags |= TCL_EVAL_REDIRECT;
     return Tcl_NREvalObj(interp, listPtr, flags);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5d08bcb..99f3f1a 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
  * 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.195 2009/11/16 18:00:11 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.196 2009/12/05 21:30:05 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -517,13 +517,27 @@ Tcl_PopCallFrame(
 	 */
 
 	TEOV_callback *tailcallPtr, *runPtr;
+	ExecEnv *eePtr = NULL;
+
 	
+	restart:
 	for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
 	    if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
 		break;
 	    }
 	}
 	if (!runPtr) {
+	    /*
+	     * If we are tailcalling out of a coroutine, the splicing spot is
+	     * in the caller's execEnv: go find it!
+	     */
+	    
+	    CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+	    if (corPtr) {
+		eePtr = iPtr->execEnvPtr;		
+		iPtr->execEnvPtr = corPtr->callerEEPtr;
+		goto restart;
+	    }
 	    Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
 	}
 
@@ -531,6 +545,15 @@ Tcl_PopCallFrame(
 	
 	tailcallPtr->nextPtr = runPtr->nextPtr;
 	runPtr->nextPtr = tailcallPtr;
+
+	if (eePtr) {
+	    /*
+	     * Restore the right execEnv if it was swapped for tailcalling out
+	     * of a coroutine.
+	     */
+	    
+	    iPtr->execEnvPtr = eePtr;
+	}
     }
 }
 
diff --git a/tests/tailcall.test b/tests/tailcall.test
index 335492a..5918bfe 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -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: tailcall.test,v 1.9 2009/06/25 19:24:16 dgp Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.10 2009/12/05 21:30:06 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -560,6 +560,23 @@ test tailcall-12.3b {[Bug 2695587]} -setup {
     rename a {}
 } -result {1 {Tailcall called from within a catch environment}}
 
+test tailcall-13.1 {tailcall and coroutine} -setup {
+    set lambda {i {
+	if {$i == 0} {
+	    depthDiff
+	}
+	if {[incr i] > 10} {
+	    return [depthDiff]
+	}
+	tailcall coroutine foo ::apply $::lambda $i
+    }}
+} -body {
+    coroutine moo ::apply $::lambda 0
+} -cleanup {
+    unset lambda 
+} -result {0 0 0 0 0 0}
+ 
+
 
 if {[testConstraint testnrelevels]} {
     namespace forget testnre::*
-- 
cgit v0.12