* generic/tclBasic.c: Redesign of [tailcall] to

	* generic/tclCmdAH.c:    (a) fix #3047235
	* generic/tclCompile.h:  (b) enable fix for #3046594
	* generic/tclExecute.c:  (c) enable recursive tailcalls
	* generic/tclInt.h:
	* generic/tclNamesp.c:
	* tests/tailcall.test:

8 files changed, 71 insertions, 87 deletions

diff --git a/ChangeLog b/ChangeLog
index 9c6f136..8105067 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-08-18  Miguel Sofer  <msofer@users.sf.net>
+	* generic/tclBasic.c:    Redesign of [tailcall] to
+	* generic/tclCmdAH.c:    (a) fix #3047235
+	* generic/tclCompile.h:  (b) enable fix for #3046594
+	* generic/tclExecute.c:  (c) enable recursive tailcalls
+	* generic/tclInt.h:
+	* generic/tclNamesp.c:
+	* tests/tailcall.test:
+	
 2010-08-18  Donal K. Fellows  <dkf@users.sf.net>
 
 	* library/safe.tcl (AliasGlob): [Bug 3004191]: Restore safe [glob] to
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5fd559d..5b767fe 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.460 2010/08/11 23:13:50 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.461 2010/08/18 15:44:10 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -4398,13 +4398,6 @@ NRCallTEBC(
     switch (type) {
     case TCL_NR_BC_TYPE:
 	return TclExecuteByteCode(interp, data[1]);
-    case TCL_NR_TAILCALL_TYPE:
-	/* For tailcalls */
-	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;
     case TCL_NR_YIELD_TYPE:
 	if (iPtr->execEnvPtr->corPtr) {
 	    Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
@@ -8294,14 +8287,12 @@ Tcl_NRCmdSwap(
 void
 TclSpliceTailcall(
     Tcl_Interp *interp,
-    TEOV_callback *tailcallPtr,
-    int skip)
+    TEOV_callback *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), and we skip the first command that we
-     * find if requested to do so: it corresponds to [tailcall] itself.
+     * (used by command redirectors).
      */
 
     Interp *iPtr = (Interp *) interp;
@@ -8311,10 +8302,7 @@ TclSpliceTailcall(
   restart:
     for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
 	if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
-	    if (!skip) {
-		break;
-	    }
-	    skip = 0;
+            break;
 	}
     }
     if (!runPtr) {
@@ -8393,9 +8381,8 @@ TclNRTailcallObjCmd(
     TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
     tailcallPtr = TOP_CB(interp);
     TOP_CB(interp) = tailcallPtr->nextPtr;
-
-    TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE),
-	    tailcallPtr, NULL, NULL);
+    iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+    
     return TCL_OK;
 }
 
@@ -8444,6 +8431,26 @@ TclClearTailcall(
     TCLNR_FREE(interp, tailcallPtr);
 }
 
+int
+TclNRBlockTailcall(
+    ClientData data[],
+    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;
+}
+
 
 void
 Tcl_NRAddCallback(
@@ -8612,7 +8619,7 @@ YieldToCallback(
     cbPtr = TOP_CB(interp);
     TOP_CB(interp) = cbPtr->nextPtr;
 
-    TclSpliceTailcall(interp, cbPtr, 0);
+    TclSpliceTailcall(interp, cbPtr);
     return TCL_OK;
 }
 
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 6456bd5..e8a249f 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.124 2010/03/05 14:34:03 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.125 2010/08/18 15:44:12 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -290,13 +290,15 @@ TclNRCatchObjCmd(
 	optionVarNamePtr = objv[3];
     }
 
+    TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
+	    varNamePtr, optionVarNamePtr, NULL);
+    TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
+	    NULL);
+
     /*
      * TIP #280. Make invoking context available to caught script.
      */
 
-    TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
-	    varNamePtr, optionVarNamePtr, NULL);
-
     return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
 }
 
@@ -313,19 +315,6 @@ CatchObjCmdCallback(
     int rewind = iPtr->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/tclCompile.h b/generic/tclCompile.h
index e73ce73..686f508 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -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: tclCompile.h,v 1.125 2010/04/29 23:39:32 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.126 2010/08/18 15:44:12 msofer Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -869,8 +869,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	NRInterpCoroutine;
 
 #define TCL_NR_BC_TYPE		0
 #define TCL_NR_ATEXIT_TYPE	1
-#define TCL_NR_TAILCALL_TYPE	2
-#define TCL_NR_YIELD_TYPE	3
+#define TCL_NR_YIELD_TYPE	2
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 249d748..c3201a5 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.489 2010/07/19 14:10:43 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.490 2010/08/18 15:44:12 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2851,33 +2851,6 @@ TclExecuteByteCode(
 		    OBP = BP;
 		    goto resumeCoroutine;
 		}
-	    case TCL_NR_TAILCALL_TYPE:
-		/*
-		 * A request to perform a tailcall: just drop this bytecode.
-		 */
-
-#ifdef TCL_COMPILE_DEBUG
-		if (TAUX.traceInstructions) {
-		    fprintf(stdout, "   Tailcall request received\n");
-		}
-#endif /* TCL_COMPILE_DEBUG */
-		iPtr->cmdFramePtr = bcFramePtr->nextPtr;
-		TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
-
-		if (catchTop != initCatchTop) {
-		    TclClearTailcall(interp, param);
-		    iPtr->varFramePtr->tailcallPtr = NULL;
-		    Tcl_SetResult(interp,
-			    "tailcall called from within a catch environment",
-			    TCL_STATIC);
-		    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
-			    NULL);
-		    pc--;
-		    goto gotError;
-		}
-		iPtr->varFramePtr->tailcallPtr = param;
-		TclSpliceTailcall(interp, param, 1);
-		goto abnormalReturn;
 	    case TCL_NR_YIELD_TYPE: {		/* [yield] */
 		CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
 
@@ -6592,7 +6565,6 @@ TclExecuteByteCode(
   returnToCaller:
     if (OBP) {
 	BP = OBP; /* back to old bc */
-    rerunCallbacks:
 	TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
 
 	NR_DATA_DIG();
@@ -6618,15 +6590,6 @@ TclExecuteByteCode(
 		 */
 
 		goto nonRecursiveCallSetup;
-	    case TCL_NR_TAILCALL_TYPE:
-		TOP_CB(iPtr) = callbackPtr->nextPtr;
-		TCLNR_FREE(interp, callbackPtr);
-
-		Tcl_SetResult(interp,
-			"tailcall cannot be invoked recursively", TCL_STATIC);
-		Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "REENTRY", NULL);
-		TRESULT = TCL_ERROR;
-		goto rerunCallbacks;
 	    default:
 		Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
 	    }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3d30581..2f18375 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.479 2010/08/14 17:13:02 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.480 2010/08/18 15:44:12 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -2759,8 +2759,9 @@ 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,
-	                    int skip);
+	                    struct TEOV_callback *tailcallPtr);
+MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
+
 
 /*
  * This structure holds the data for the various iteration callbacks used to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 12fb46e..401eea4 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.209 2010/06/08 12:54:38 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.210 2010/08/18 15:44:13 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -391,6 +391,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 b8a3210..efb5fa4 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.12 2010/01/22 10:22:51 dkf Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.13 2010/08/18 15:44:13 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -323,7 +323,7 @@ test tailcall-8 {tailcall tailcall} -setup {
     namespace eval ::foo c
 } -cleanup {
     namespace delete ::foo
-} -match glob -result *tailcall* -returnCodes error
+} -result cbac
 
 test tailcall-9 {tailcall factorial} -setup {
     proc fact {n {b 1}} {
@@ -557,6 +557,18 @@ test tailcall-12.3b {[Bug 2695587]} {
     }}
 } {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
 
+test tailcall-12.3c {[Bug 3046594]} {
+    apply {{} {
+	list [[subst catch] {tailcall foo} msg opt] $msg [errorcode $opt]
+    }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+
+test tailcall-12.3d {[Bug 3046594]} {
+    apply {{} {
+	list [[subst catch] [list tailcall foo] msg opt] $msg [errorcode $opt]
+    }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+
 test tailcall-13.1 {tailcall and coroutine} -setup {
     set lambda {i {
 	if {$i == 1} {
@@ -573,17 +585,17 @@ test tailcall-13.1 {tailcall and coroutine} -setup {
     unset lambda 
 } -result {0 0 0 0 0 0}
 
-test tailcall-14.1 {directly tailcalling the tailcall command is an error} {
+test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
     list [catch {
 	apply {{} {
 	    apply {{} {
-		tailcall tailcall subst a
+		tailcall tailcall subst ok
 		subst b
 	    }}
 	    subst c
 	}}
     } msg opt] $msg [errorcode $opt]
-} {1 {tailcall cannot be invoked recursively} {TCL TAILCALL REENTRY}}
+} {0 ok NONE}
 test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} {
     list [catch {
 	apply {{} {