* generic/tclBasic.c: Fix for (among others) [Bug 2699087]

	* generic/tclCmdAH.c:   Tailcalls now perform properly even from
	* generic/tclExecute.c: within [eval]ed scripts.
	* generic/tclInt.h:     More tests missing, as well as proper
	exploration and testing of the interaction with "redirectors" like
	interp-alias (suspect that it does not happen in constant space)
	and pure-eval commands.

4 files changed, 78 insertions, 31 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 739732f..c40cd49 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.388 2009/03/19 23:31:37 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.389 2009/03/21 09:42:06 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -7988,8 +7988,9 @@ TclNRTailcallObjCmd(
 {
     Interp *iPtr = (Interp *) interp;
     TEOV_callback *tailcallPtr;
-    Tcl_Obj *listPtr;
-    Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
+    Tcl_Obj *listPtr, *nsObjPtr;
+    Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+    Tcl_Namespace *ns1Ptr;
     
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8004,10 +8005,16 @@ TclNRTailcallObjCmd(
 	return TCL_ERROR;
     }
 
-    nsPtr->activationCount++;
     listPtr = Tcl_NewListObj(objc-1, objv+1);
     Tcl_IncrRefCount(listPtr);
 
+    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
+	    || (nsPtr != ns1Ptr)) {
+	Tcl_Panic("Tailcall failed to find the proper namespace");
+    }
+    Tcl_IncrRefCount(nsObjPtr);
+    
     /*
      * Add two callbacks: first the one to actually evaluate the tailcalled
      * command, then the one that signals TEBC to stash the first at its
@@ -8017,7 +8024,7 @@ TclNRTailcallObjCmd(
      * TclNRAddCallBack macro to build the callback)
      */
 
-    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
     tailcallPtr = TOP_CB(interp);
     TOP_CB(interp) = tailcallPtr->nextPtr;
 
@@ -8033,27 +8040,19 @@ NRTailcallEval(
 {
     Interp *iPtr = (Interp *) interp;
     Tcl_Obj *listPtr = data[0];
-    Namespace *nsPtr = data[1];
-    int omit = PTR2INT(data[2]);
+    Tcl_Obj *nsObjPtr = data[1];
+    Tcl_Namespace *nsPtr;
     int objc;
     Tcl_Obj **objv;
 
-    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);
-    }
-
-    nsPtr->activationCount--;
-    if ((nsPtr->flags & NS_DYING)
-	    && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
-	/*
-	 * FIXME NRE tailcall: is this the proper way to manage this? This is
-	 * like what CallFrames do.
-	 */
-
-	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
+    TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL, NULL);
+    if (result == TCL_OK) {
+	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+	if (result == TCL_OK) {
+	    iPtr->lookupNsPtr = (Namespace *) nsPtr;
+	    ListObjGetElements(listPtr, objc, objv);
+	    result = TclNREvalObjv(interp, objc, objv, 0, NULL);
+	}
     }
     return result;
 }
@@ -8065,8 +8064,19 @@ TailcallCleanup(
     int result)
 {
     Tcl_DecrRefCount((Tcl_Obj *) data[0]);
+    Tcl_DecrRefCount((Tcl_Obj *) data[1]);
     return result;
 }
+
+void
+TclClearTailcall(
+    Tcl_Interp *interp,
+    TEOV_callback *tailcallPtr)
+{
+    TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
+    TCLNR_FREE(interp, tailcallPtr);
+}
+
 
 void
 Tcl_NRAddCallback(
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c8829f8..a00fff8 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.115 2009/02/03 23:34:33 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.116 2009/03/21 09:42:06 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -302,12 +302,26 @@ CatchObjCmdCallback(
     Tcl_Interp *interp,
     int result)
 {
+    Interp *iPtr = (Interp *) interp;
     int objc = PTR2INT(data[0]);
     Tcl_Obj *varNamePtr = data[1];
     Tcl_Obj *optionVarNamePtr = data[2];
     int rewind = ((Interp *) interp)->execEnvPtr->rewind;
 
     /*
+     * catch has to disable any tailcall
+     */
+
+    if (iPtr->varFramePtr->tailcallPtr) {
+	TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+	iPtr->varFramePtr->tailcallPtr = NULL;
+	result = TCL_ERROR;
+	Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+		TCL_STATIC);
+    }	
+
+
+    /*
      * We disable catch in interpreters where the limit has been exceeded.
      */
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 99bf84e..b00848a 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.432 2009/03/21 06:55:31 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.433 2009/03/21 09:42:07 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1871,18 +1871,15 @@ TclExecuteByteCode(
 		    fprintf(stdout, "   Tailcall request received\n");
 		}
 #endif
-		TEOV_callback *tailcallPtr = param;
-
-		iPtr->varFramePtr->tailcallPtr = tailcallPtr;
-		
 		if (catchTop != initCatchTop) {
-		    tailcallPtr->data[2] = INT2PTR(1);
+		    TclClearTailcall(interp, param);
 		    result = TCL_ERROR;
 		    Tcl_SetResult(interp,"Tailcall called from within a catch environment",
 			    TCL_STATIC);
 		    pc--;
 		    goto checkForCatch;
 		}
+		iPtr->varFramePtr->tailcallPtr = param;
 		goto abnormalReturn;
 	    }
 	    case TCL_NR_YIELD_TYPE: { /*[yield] */
@@ -1995,6 +1992,15 @@ TclExecuteByteCode(
 	 */
 
 	if (iPtr->varFramePtr->tailcallPtr) {
+	    if (catchTop != initCatchTop) {
+		TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+		iPtr->varFramePtr->tailcallPtr = NULL;
+		result = TCL_ERROR;
+		Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+			TCL_STATIC);
+		pc--;
+		goto checkForCatch;
+	    }
 	    goto abnormalReturn;
 	}
     
@@ -7759,6 +7765,19 @@ TclExecuteByteCode(
 
     abnormalReturn:
 	TCL_DTRACE_INST_LAST();
+
+	/*
+	 * Winding down: insure that all pending cleanups are done before
+	 * dropping out of this bytecode. 
+	 */
+	if (TOP_CB(interp) != bottomPtr->rootPtr) {
+	    result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
+	
+	    if (TOP_CB(interp) != bottomPtr->rootPtr) {
+		Tcl_Panic("Abnormal return with busy callback stack");
+	    }
+	}
+	
 	/*
 	 * Clear all expansions and same-level NR calls.
 	 *
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 48473bd..3c45cc1 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.419 2009/03/19 23:31:37 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.420 2009/03/21 09:42:07 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -2603,6 +2603,10 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 
+MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
+	            struct TEOV_callback *tailcallPtr);
+
+
 /*
  *----------------------------------------------------------------
  * Procedures shared among Tcl modules but not used by the outside world: