* generic/tclBasic.c: New implementation for [tailcall]:

	* generic/tclCmdAH.c:    it now schedules the command and returns
	* generic/tclCmdMZ.c:    TCL_RETURN. This fixes all issues with
	* generic/tclExecute.c:  [catch] and [try] - [Bug 3046594],
	* generic/tclInt.h:      [Bug 3047235] and [Bug 3048771]. Thanks
	* generic/tclNamesp.c:   dgp for exploring the dark corners.
	* tests/tailcall.test:   More thorough testing is required.

8 files changed, 136 insertions, 180 deletions

diff --git a/ChangeLog b/ChangeLog
index 3bc7ec7..8205243 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-08-30  Miguel Sofer  <msofer@users.sf.net>
+	* generic/tclBasic.c:    New implementation for [tailcall]:
+	* generic/tclCmdAH.c:    it now schedules the command and returns 
+	* generic/tclCmdMZ.c:    TCL_RETURN. This fixes all issues with
+	* generic/tclExecute.c:  [catch] and [try] - [Bug 3046594],  
+	* generic/tclInt.h:      [Bug 3047235] and [Bug 3048771]. Thanks
+	* generic/tclNamesp.c:   dgp for exploring the dark corners. 
+	* tests/tailcall.test:   More thorough testing is required.
+
 2010-08-30  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* win/Makefile.in:   [Freq 2965056]: Windows build with -DUNICODE
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5216f96..6769211 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.463 2010/08/22 18:53:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.464 2010/08/30 14:02:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -167,10 +167,6 @@ 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;
 
@@ -8291,30 +8287,10 @@ Tcl_NRCmdSwap(
  * FIXME NRE!
  */
 
-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(
+void
+TclSpliceTailcall(
     Tcl_Interp *interp,
-    TEOV_callback *tailcallPtr,
-    int skip)
+    TEOV_callback *tailcallPtr)
 {
     /*
      * Find the splicing spot: right before the NRCommand of the thing
@@ -8322,53 +8298,19 @@ SpliceTailcall(
      * (used by command redirectors).
      */
 
-    Interp *iPtr = (Interp *) interp;
     TEOV_callback *runPtr;
 
-    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) {
+    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) {
-            runPtr = corPtr->callerEEPtr->callbackPtr;
-	    goto restart;
-	}
-        
-        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;
+        Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
     }
 
     tailcallPtr->nextPtr = runPtr->nextPtr;
     runPtr->nextPtr = tailcallPtr;
-    return TCL_OK;
 }
 
 int
@@ -8379,18 +8321,13 @@ TclNRTailcallObjCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *listPtr, *nsObjPtr;
-    Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
-    Tcl_Namespace *ns1Ptr;
-    TEOV_callback *tailcallPtr;
 
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+    if (objc < 1) {
+	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 */
+    if (!iPtr->varFramePtr->isProcCallFrame) {	/* or is upleveled */
         Tcl_SetResult(interp,
                 "tailcall can only be called from a proc or lambda",
                 TCL_STATIC);
@@ -8398,33 +8335,45 @@ TclNRTailcallObjCmd(
 	return TCL_ERROR;
     }
 
-    listPtr = Tcl_NewListObj(objc-1, objv+1);
-    Tcl_IncrRefCount(listPtr);
+    /*
+     * Invocation without args just clears a scheduled tailcall; invocation
+     * with an argument replaces any previously scheduled tailcall.
+     */
 
-    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
-    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
-	    || (nsPtr != ns1Ptr)) {
-	Tcl_Panic("Tailcall failed to find the proper namespace");
+    if (iPtr->varFramePtr->tailcallPtr) {
+        ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+        iPtr->varFramePtr->tailcallPtr = NULL;
     }
-    Tcl_IncrRefCount(nsObjPtr);
 
     /*
      * Create the callback to actually evaluate the tailcalled
-     * command, then pass it to tebc so that it is stashed at the proper
-     * place. Being lazy: exploit the TclNRAddCallBack macro to build the
-     * callback.
+     * command, then set it in the varFrame so that PopCallFrame can use it
+     * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
+     * build the callback.
      */
 
-    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
-    tailcallPtr = TOP_CB(interp);
-    TOP_CB(interp) = tailcallPtr->nextPtr;
+    if (objc > 1) {
+        Tcl_Obj *listPtr, *nsObjPtr;
+        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+        Tcl_Namespace *ns1Ptr;
+        TEOV_callback *tailcallPtr;
+        
+        listPtr = Tcl_NewListObj(objc-1, objv+1);
+        Tcl_IncrRefCount(listPtr);
 
-    if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) {
-        return TCL_ERROR;
+        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);
+
+        TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
+        tailcallPtr = TOP_CB(interp);
+        TOP_CB(interp) = tailcallPtr->nextPtr;
+        iPtr->varFramePtr->tailcallPtr = tailcallPtr;
     }
-    
-    iPtr->varFramePtr->isProcCallFrame |= FRAME_TAILCALLING;
-    return TCL_OK;
+    return TCL_RETURN;
 }
 
 int
@@ -8484,15 +8433,6 @@ ClearTailcall(
     TCLNR_FREE(interp, tailcallPtr);
 }
 
-int
-TclNRBlockTailcall(
-    ClientData data[],
-    Tcl_Interp *interp,
-    int result)
-{
-    return result;
-}
-
 
 void
 Tcl_NRAddCallback(
@@ -8661,7 +8601,7 @@ YieldToCallback(
     cbPtr = TOP_CB(interp);
     TOP_CB(interp) = cbPtr->nextPtr;
 
-    SpliceTailcall(interp, cbPtr, 0);
+    TclSpliceTailcall(interp, cbPtr);
     return TCL_OK;
 }
 
@@ -9042,7 +8982,6 @@ TclNRCoroutineObjCmd(
 
     TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
 	    NULL, NULL, NULL);
-    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
     iPtr->lookupNsPtr = nsPtr;
     TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
 
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index e8a249f..7ef3bec 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.125 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.126 2010/08/30 14:02:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -292,8 +292,6 @@ TclNRCatchObjCmd(
 
     TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
 	    varNamePtr, optionVarNamePtr, NULL);
-    TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
-	    NULL);
 
     /*
      * TIP #280. Make invoking context available to caught script.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index b844dae..7690649 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.213 2010/08/18 15:54:06 msofer Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.214 2010/08/30 14:02:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -4274,13 +4274,11 @@ TclNRTryObjCmd(
     }
 
     /*
-     * Execute the body; block tailcalling out of it.
+     * Execute the body.
      */
 
     Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
 	    (ClientData)objv, INT2PTR(objc));
-    TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
-	    NULL);    
     return TclNREvalObjEx(interp, bodyObj, 0,
 	    ((Interp *) interp)->cmdFramePtr, 1);
 }
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 4970443..2664558 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.492 2010/08/22 18:53:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.493 2010/08/30 14:02:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2901,25 +2901,6 @@ TclExecuteByteCode(
 	iPtr->cmdFramePtr = bcFramePtr->nextPtr;
 	TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
 
-	/*
-	 * If the CallFrame is marked as tailcalling, keep tailcalling
-	 */
-
-	if (iPtr->varFramePtr->isProcCallFrame & FRAME_TAILCALLING) {
-	    if (catchTop == initCatchTop) {
-		goto abnormalReturn;
-	    }
-
-	    iPtr->varFramePtr->isProcCallFrame &= ~FRAME_TAILCALLING;
-	    TclRemoveTailcall(interp);
-	    Tcl_SetResult(interp,
-		    "tailcall called from within a catch environment",
-		    TCL_STATIC);
-	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
-	    pc--;
-	    goto gotError;
-	}
-
 	if (iPtr->execEnvPtr->rewind) {
 	    TRESULT = TCL_ERROR;
 	    goto abnormalReturn;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 881dec4..1fb8869 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.481 2010/08/18 22:33:27 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.482 2010/08/30 14:02:10 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -1152,10 +1152,8 @@ typedef struct CallFrame {
 				 * meaning of the value is, which we do not
 				 * specify. */
     LocalCache *localCachePtr;
-    struct TEOV_callback *wherePtr;
-				/* The top of the callback stack when this
-				 * frame was pushed; used to find the spot
-				 * where to tailcall to. */
+    struct TEOV_callback *tailcallPtr;
+				/* NULL if no tailcall is scheduled */
 } CallFrame;
 
 #define FRAME_IS_PROC	0x1
@@ -1168,8 +1166,6 @@ 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
@@ -2758,10 +2754,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
 
-MODULE_SCOPE void       TclRemoveTailcall(Tcl_Interp *interp);
-
-MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
-
+MODULE_SCOPE void  TclSpliceTailcall(Tcl_Interp *interp,
+	               struct TEOV_callback *tailcallPtr);
 
 /*
  * This structure holds the data for the various iteration callbacks used to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5bd3c24..6961fd5 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.211 2010/08/18 22:33:27 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.212 2010/08/30 14:02:10 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -313,18 +313,7 @@ Tcl_PushCallFrame(
     framePtr->compiledLocals = NULL;
     framePtr->clientData = NULL;
     framePtr->localCachePtr = 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;
-    }
-    
+    framePtr->tailcallPtr = NULL;
     
     /*
      * Push the new call frame onto the interpreter's stack of procedure call
@@ -403,6 +392,10 @@ Tcl_PopCallFrame(
 	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
     }
     framePtr->nsPtr = NULL;
+
+    if (framePtr->tailcallPtr) {
+        TclSpliceTailcall(interp, framePtr->tailcallPtr);
+    }
 }
 
 /*
diff --git a/tests/tailcall.test b/tests/tailcall.test
index efb5fa4..46e2471 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.13 2010/08/18 15:44:13 msofer Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.14 2010/08/30 14:02:10 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -384,6 +384,20 @@ test tailcall-11b {tailcall and uplevel} -setup {
     unset -nocomplain ::x
 } -match glob -result *tailcall* -returnCodes error
 
+test tailcall-11c {tailcall and uplevel} -setup {
+    proc a {} {
+	uplevel 1 {tailcall lappend ::x 2}
+	set ::x 1
+    }
+    proc b {} {set ::x 0; a; lappend ::x 3}
+} -body {
+    list [b] $::x
+} -cleanup {
+    rename a {}
+    rename b {}
+    unset -nocomplain ::x
+} -result {{0 3 2} {0 3 2}}
+
 test tailcall-12.1 {[Bug 2649975]} -setup {
     proc dump {{text {}}} {
 	set text [uplevel 1 [list subst $text]]
@@ -545,47 +559,77 @@ test tailcall-12.2 {[Bug 2649975]} -setup {
 1: exiting from foo's alpha
 }
 
-test tailcall-12.3a {[Bug 2695587]} {
+test tailcall-12.3a0 {[Bug 2695587]} -body {
     apply {{} {
-	list [catch [list tailcall foo] msg opt] $msg [errorcode $opt]
+	catch [list tailcall foo]
     }}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -returnCodes 1 -result {invalid command name "foo"}
 
-test tailcall-12.3b {[Bug 2695587]} {
+test tailcall-12.3a1 {[Bug 2695587]} -body {
     apply {{} {
-	list [catch {tailcall foo} msg opt] $msg [errorcode $opt]
+	catch [list tailcall foo]
+	tailcall
     }}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -result {}
 
-test tailcall-12.3c {[Bug 3046594]} {
+test tailcall-12.3a2 {[Bug 2695587]} -body {
     apply {{} {
-	list [[subst catch] {tailcall foo} msg opt] $msg [errorcode $opt]
+	catch [list tailcall foo]
+	tailcall moo
     }}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -returnCodes 1 -result {invalid command name "moo"}
 
-test tailcall-12.3d {[Bug 3046594]} {
+test tailcall-12.3a3 {[Bug 2695587]} -body {
+    set x 0
     apply {{} {
-	list [[subst catch] [list tailcall foo] msg opt] $msg [errorcode $opt]
+	catch [list tailcall foo]
+	tailcall lappend x 1
     }}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+    set x
+} -cleanup {
+    unset x
+} -result {0 1} 
 
-test tailcall-13.1 {tailcall and coroutine} -setup {
-    set lambda {i {
-	if {$i == 1} {
-	    depthDiff
-	}
-	if {[incr i] > 10} {
-	    return [depthDiff]
-	}
-	tailcall coroutine foo ::apply $::lambda $i
+test tailcall-12.3b0 {[Bug 2695587]} -body {
+    apply {{} {
+	set catch catch
+	$catch [list tailcall foo]
     }}
-} -body {
-    coroutine moo ::apply $::lambda 0
+} -returnCodes 1 -result {invalid command name "foo"}
+
+test tailcall-12.3b1 {[Bug 2695587]} -body {
+    apply {{} {
+	set catch catch
+	$catch [list tailcall foo]
+	tailcall
+    }}
+} -result {}
+
+test tailcall-12.3b2 {[Bug 2695587]} -body {
+    apply {{} {
+	set catch catch
+	$catch [list tailcall foo]
+	tailcall moo
+    }}
+} -returnCodes 1 -result {invalid command name "moo"}
+
+test tailcall-12.3b3 {[Bug 2695587]} -body {
+    set x 0
+    apply {{} {
+	set catch catch
+	$catch [list tailcall foo]
+	tailcall lappend x 1
+    }}
+    set x
 } -cleanup {
-    unset lambda 
-} -result {0 0 0 0 0 0}
+    unset x
+} -result {0 1} 
+
+# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed)
+# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that
+# standard catch behaviour is required.
 
-test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
+test tailcall-13.1 {directly tailcalling the tailcall command is ok} {
     list [catch {
 	apply {{} {
 	    apply {{} {
@@ -596,7 +640,7 @@ test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
 	}}
     } msg opt] $msg [errorcode $opt]
 } {0 ok NONE}
-test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} {
+test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} {
     list [catch {
 	apply {{} {
 	    apply {{} {