* generic/tclBasic.c: New redesign of [tailcall]: find

	* generic/tclExecute.c: errors early on, so that errorInfo
	* generic/tclInt.h:     contains the proper info [Bug 3047235]
	* generic/tclNamesp.c:

5 files changed, 123 insertions, 68 deletions

diff --git a/ChangeLog b/ChangeLog
index d2b8e13..605c9b0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,15 @@
 2010-08-18  Miguel Sofer  <msofer@users.sf.net>
+	* generic/tclBasic.c:   New redesign of [tailcall]: find
+	* generic/tclExecute.c: errors early on, so that errorInfo
+	* generic/tclInt.h:     contains the proper info [Bug 3047235]
+	* generic/tclNamesp.c:
+
 	* generic/tclCmdAH.c (TclNRTryObjCmd): block tailcalling out of
-	the body of a non-bc'ed [try], #3046594
+	the body of a non-bc'ed [try], [Bug 3046594]
 
 	* generic/tclBasic.c:    Redesign of [tailcall] to
-	* generic/tclCmdAH.c:    (a) fix #3047235
-	* generic/tclCompile.h:  (b) enable fix for #3046594
+	* generic/tclCmdAH.c:    (a) fix [Bug 3047235]
+	* generic/tclCompile.h:  (b) enable fix for [Bug 3046594]
 	* generic/tclExecute.c:  (c) enable recursive tailcalls
 	* generic/tclInt.h:
 	* generic/tclNamesp.c:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5b767fe..366e45e 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.461 2010/08/18 15:44:10 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.462 2010/08/18 22:33:26 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -165,6 +165,13 @@ static Tcl_NRPostProc	TEOV_RestoreVarFrame;
 static Tcl_NRPostProc	TEOV_RunLeaveTraces;
 static Tcl_NRPostProc	YieldToCallback;
 
+static void	        ClearTailcall(Tcl_Interp *interp,
+			    struct TEOV_callback *tailcallPtr);
+static int              SpliceTailcall(Tcl_Interp *interp,
+	                    struct TEOV_callback *tailcallPtr,
+                            int skip);
+
+
 MODULE_SCOPE const TclStubs tclStubs;
 
 /*
@@ -8284,10 +8291,30 @@ Tcl_NRCmdSwap(
  * FIXME NRE!
  */
 
-void
-TclSpliceTailcall(
+void TclRemoveTailcall(
+    Tcl_Interp *interp)
+{
+    TEOV_callback *runPtr, *tailcallPtr;
+    
+    for (runPtr = TOP_CB(interp); runPtr->nextPtr; runPtr = runPtr->nextPtr) {
+        if (runPtr->nextPtr->procPtr == NRTailcallEval) {
+            break;
+        }
+    }
+    if (!runPtr->nextPtr) {
+        Tcl_Panic("TclRemoveTailcall did not find a tailcall");
+    }
+
+    tailcallPtr = runPtr->nextPtr;
+    runPtr->nextPtr = tailcallPtr->nextPtr;
+    ClearTailcall(interp, tailcallPtr);
+}
+
+static int
+SpliceTailcall(
     Tcl_Interp *interp,
-    TEOV_callback *tailcallPtr)
+    TEOV_callback *tailcallPtr,
+    int skip)
 {
     /*
      * Find the splicing spot: right before the NRCommand of the thing
@@ -8297,13 +8324,27 @@ TclSpliceTailcall(
 
     Interp *iPtr = (Interp *) interp;
     TEOV_callback *runPtr;
-    ExecEnv *eePtr = NULL;
 
-  restart:
-    for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+    runPtr = TOP_CB(interp);
+    if (skip) {
+        while (runPtr && (runPtr != iPtr->varFramePtr->wherePtr)) {
+            if ((runPtr->procPtr) == TclNRBlockTailcall) {
+                ClearTailcall(interp, tailcallPtr);
+                Tcl_SetResult(interp,"tailcall called from within a catch environment",
+                        TCL_STATIC);
+                Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+                        NULL);
+                return TCL_ERROR;
+            }
+            runPtr = runPtr->nextPtr;
+        }
+    }
+
+    restart:
+    for (; runPtr; runPtr = runPtr->nextPtr) {
 	if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
             break;
-	}
+        }
     }
     if (!runPtr) {
 	/*
@@ -8314,24 +8355,20 @@ TclSpliceTailcall(
 	CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
 
 	if (corPtr) {
-	    eePtr = iPtr->execEnvPtr;
-	    iPtr->execEnvPtr = corPtr->callerEEPtr;
+            runPtr = corPtr->callerEEPtr->callbackPtr;
 	    goto restart;
 	}
-	Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
+        
+        Tcl_SetResult(interp,
+                "tailcall cannot find the right splicing spot: should not happen!",
+                TCL_STATIC);
+        Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "UNKNOWN", NULL);
+        return TCL_ERROR;
     }
 
     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;
-    }
+    return TCL_OK;
 }
 
 int
@@ -8354,10 +8391,10 @@ TclNRTailcallObjCmd(
 
     if (!iPtr->varFramePtr->isProcCallFrame ||		/* is not a body */
 	    (iPtr->framePtr != iPtr->varFramePtr)) {	/* or is upleveled */
-	Tcl_SetResult(interp,
-		"tailcall can only be called from a proc or lambda",
-		TCL_STATIC);
-	Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+        Tcl_SetResult(interp,
+                "tailcall can only be called from a proc or lambda",
+                TCL_STATIC);
+        Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
 	return TCL_ERROR;
     }
 
@@ -8381,8 +8418,12 @@ TclNRTailcallObjCmd(
     TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
     tailcallPtr = TOP_CB(interp);
     TOP_CB(interp) = tailcallPtr->nextPtr;
-    iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+
+    if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) {
+        return TCL_ERROR;
+    }
     
+    iPtr->varFramePtr->isProcCallFrame |= FRAME_TAILCALLING;
     return TCL_OK;
 }
 
@@ -8399,16 +8440,28 @@ NRTailcallEval(
     int objc;
     Tcl_Obj **objv;
 
-    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;
+
+    if (result != TCL_OK) {
+        /*
+         * Tailcall execution was preempted, eg by an intervening catch or by
+         * a now-gone namespace: cleanup and return.
+         */
+        
+        TailcallCleanup(data, interp, result);
+        return result;
+    }
+
+    /*
+     * Perform the tailcall
+     */
+
+    TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+    iPtr->lookupNsPtr = (Namespace *) nsPtr;
+    ListObjGetElements(listPtr, objc, objv);
+    return TclNREvalObjv(interp, objc, objv, 0, NULL);
 }
 
 static int
@@ -8422,8 +8475,8 @@ TailcallCleanup(
     return result;
 }
 
-void
-TclClearTailcall(
+static void
+ClearTailcall(
     Tcl_Interp *interp,
     TEOV_callback *tailcallPtr)
 {
@@ -8437,17 +8490,6 @@ TclNRBlockTailcall(
     Tcl_Interp *interp,
     int result)
 {
-    Interp *iPtr = (Interp *) interp;
-
-    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);
-	Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
-		NULL);
-    }
     return result;
 }
 
@@ -8619,7 +8661,7 @@ YieldToCallback(
     cbPtr = TOP_CB(interp);
     TOP_CB(interp) = cbPtr->nextPtr;
 
-    TclSpliceTailcall(interp, cbPtr);
+    SpliceTailcall(interp, cbPtr, 0);
     return TCL_OK;
 }
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c3201a5..715c404 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.490 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.491 2010/08/18 22:33:27 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2905,13 +2905,13 @@ TclExecuteByteCode(
 	 * If the CallFrame is marked as tailcalling, keep tailcalling
 	 */
 
-	if (iPtr->varFramePtr->tailcallPtr) {
+	if (iPtr->varFramePtr->isProcCallFrame & FRAME_TAILCALLING) {
 	    if (catchTop == initCatchTop) {
 		goto abnormalReturn;
 	    }
 
-	    TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
-	    iPtr->varFramePtr->tailcallPtr = NULL;
+	    iPtr->varFramePtr->isProcCallFrame &= ~FRAME_TAILCALLING;
+	    TclRemoveTailcall(interp);
 	    Tcl_SetResult(interp,
 		    "tailcall called from within a catch environment",
 		    TCL_STATIC);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2f18375..881dec4 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.480 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.481 2010/08/18 22:33:27 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -1152,10 +1152,10 @@ 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. */
+    struct TEOV_callback *wherePtr;
+				/* The top of the callback stack when this
+				 * frame was pushed; used to find the spot
+				 * where to tailcall to. */
 } CallFrame;
 
 #define FRAME_IS_PROC	0x1
@@ -1168,6 +1168,8 @@ typedef struct CallFrame {
 				 * field contains an Object reference that has
 				 * been confirmed to refer to a class. Part of
 				 * TIP#257. */
+#define FRAME_TAILCALLING 0x10  /* Flag is set while the CallFrame is winding
+				 * down to process a tailcall */
 
 /*
  * TIP #280
@@ -2756,10 +2758,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
 
-MODULE_SCOPE void	TclClearTailcall(Tcl_Interp *interp,
-			    struct TEOV_callback *tailcallPtr);
-MODULE_SCOPE void       TclSpliceTailcall(Tcl_Interp *interp,
-	                    struct TEOV_callback *tailcallPtr);
+MODULE_SCOPE void       TclRemoveTailcall(Tcl_Interp *interp);
+
 MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
 
 
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 401eea4..5bd3c24 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,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.210 2010/08/18 15:44:13 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.211 2010/08/18 22:33:27 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -313,15 +313,27 @@ Tcl_PushCallFrame(
     framePtr->compiledLocals = NULL;
     framePtr->clientData = NULL;
     framePtr->localCachePtr = NULL;
-    framePtr->tailcallPtr = NULL;
 
     /*
+     * Record the top of the callback stack, so that tailcall can identify
+     * the spot where to splice the new command.
+     */
+
+    if (iPtr->execEnvPtr) {
+        framePtr->wherePtr = TOP_CB(interp);
+    } else {
+        framePtr->wherePtr = NULL;
+    }
+    
+    
+    /*
      * Push the new call frame onto the interpreter's stack of procedure call
      * frames making it the current frame.
      */
 
     iPtr->framePtr = framePtr;
     iPtr->varFramePtr = framePtr;
+
     return TCL_OK;
 }
 
@@ -391,10 +403,6 @@ Tcl_PopCallFrame(
 	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
     }
     framePtr->nsPtr = NULL;
-
-    if (framePtr->tailcallPtr) {
-        TclSpliceTailcall(interp, framePtr->tailcallPtr);
-    }
 }
 
 /*