restricting usage and avoiding panics in [tailcall]

3 files changed, 48 insertions, 155 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b6cb2fd..b9d7efe 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.340 2008/07/31 00:55:15 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.341 2008/07/31 03:42:15 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -4158,8 +4158,12 @@ int
 TclNRRunCallbacks(
     Tcl_Interp *interp,
     int result,
-    struct TEOV_callback *rootPtr,
-    int tebcCall)
+    struct TEOV_callback *rootPtr,  /* All callbacks down to rootPtr not
+				     * inclusive are to be run    */
+    int tebcCall)                   /* Normal callers set this to 0; TEBC sets
+				     * it to 1 when executing a bytecode, to
+				     * 2 when cleaning up after a bytecode
+				     * returns.  */
 {
     Interp *iPtr = (Interp *) interp;
     TEOV_callback *callbackPtr = TOP_CB(interp);
@@ -4181,26 +4185,22 @@ TclNRRunCallbacks(
     while (TOP_CB(interp) != rootPtr) {
 	callbackPtr = TOP_CB(interp);
 
-	if (tebcCall) {
-	    if ((callbackPtr->procPtr == NRRunBytecode) ||
-		    (callbackPtr->procPtr == NRDoTailcall)) {
-		/*
-		 * TEBC pass thru: let the caller tebc handle and get rid of
-		 * this callback.
-		 */
-
+	if (tebcCall && (callbackPtr->procPtr == NRRunBytecode)) {
 		return TCL_OK;
+	} else if (callbackPtr->procPtr == NRDoTailcall) {
+	    if (tebcCall == 1) {
+		return TCL_OK;
+	    } else if (tebcCall == 2) {
+		Tcl_SetResult(interp,
+			"tailcall cannot be invoked recursively", TCL_STATIC);
+	    } else {
+		Tcl_SetResult(interp,
+			"tailcall can only be called from a proc or lambda", TCL_STATIC);
 	    }
-	}
-
-	if (callbackPtr->procPtr == NRDoTailcall) {
-	    /*
-	     * It is an error to schedule a tailcall in this situation.
-	     */
-
-	    Tcl_SetResult(interp,
-		    "tailcall can only be called from a proc or lambda", TCL_STATIC);
+	    TOP_CB(interp) = callbackPtr->nextPtr;
 	    result = TCL_ERROR;
+	    TCLNR_FREE(interp, callbackPtr);
+	    continue;
 	}
 	
 	/*
@@ -7873,9 +7873,7 @@ TclTailcallObjCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *) interp;
-    TEOV_callback *rootPtr = TOP_CB(interp);
-    TEOV_callback *tailPtr;
-    Tcl_Obj *scriptPtr;
+    Tcl_Obj *listPtr;
     Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
     int count;
     
@@ -7883,35 +7881,16 @@ TclTailcallObjCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
     }
 
-    /*
-     * Add a callback to perform the tailcall as LAST item in the CALLER's
-     * callback stack.
-     * Find the first record for the caller:
-     *  1. find the SECOND callback that contains a cmdPtr below the top (note
-     *     that the FIRST one correspond to this TclTailcallObjCmd call)
-     *  2. set the callback for the tailcalled command below that
-     */
-
-    tailPtr = rootPtr;
-    count = NR_IS_COMMAND(tailPtr);
-    while (tailPtr && tailPtr->nextPtr && (count < 2)) {
-	tailPtr = tailPtr->nextPtr;
-	count += NR_IS_COMMAND(tailPtr);
-    }
-
-    if (!iPtr->varFramePtr->isProcCallFrame) {
+    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);
 	return TCL_ERROR;
     }
 
     nsPtr->activationCount++;
-    if (objc == 2) {
-	scriptPtr = objv[1];
-    } else {
-	scriptPtr = Tcl_NewListObj(objc-1, objv+1);
-    }
-    Tcl_IncrRefCount(scriptPtr);
+    listPtr = Tcl_NewListObj(objc-1, objv+1);
+    Tcl_IncrRefCount(listPtr);
 
     /*
      * Add two callbacks: first the one to actually evaluate the tailcalled
@@ -7919,7 +7898,7 @@ TclTailcallObjCmd(
      * proper place.
      */
 
-    TclNRAddCallback(interp, TailcallEval, scriptPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, TailcallEval, listPtr, nsPtr, NULL, NULL);
     TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL);
 
     return TCL_OK;
@@ -7932,13 +7911,16 @@ TailcallEval(
     int result)
 {
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *scriptPtr = data[0];
+    Tcl_Obj *listPtr = data[0];
     Namespace *nsPtr = data[1];
+    int objc;
+    Tcl_Obj **objv;
 
-    TclNRAddCallback(interp, TailcallCleanup, scriptPtr, NULL, NULL, NULL);
+    TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
     if (result == TCL_OK) {
 	iPtr->lookupNsPtr = nsPtr;
-	result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0);
+	ListObjGetElements(listPtr, objc, objv);
+	result = TclNREvalObjv(interp, objc, objv, 0, NULL);
     }
 
     nsPtr->activationCount--;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2a1d232..9ee7ec0 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.391 2008/07/31 00:43:09 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.392 2008/07/31 03:42:15 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -7686,7 +7686,7 @@ TclExecuteByteCode(
 	 */
 
 	bottomPtr = oldBottomPtr;        /* back to old bc */	
-	result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
+	result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 2);
 	
 	NR_DATA_DIG();
 	DECACHE_STACK_INFO();
@@ -7701,23 +7701,15 @@ TclExecuteByteCode(
 		Tcl_DecrRefCount(objPtr);
 	    }
 	    goto nonRecursiveCallReturn;
-	} else {
+	} else 	if (TOP_CB(interp)->procPtr == NRRunBytecode) {
 	    /*
-	     * One of the callbacks requested a new execution: a tailcall!
-	     * Start the new bytecode.
-	     */
-		
-	    if (TOP_CB(interp)->procPtr == NRDoTailcall) {
-#if 1
-		Tcl_Panic("'tailcall tailcall' not yet implemented");//
-#endif
-		Tcl_SetResult(interp,"'tailcall tailcall' not yet implemented",
-			TCL_STATIC);
-		result = TCL_ERROR;
-		goto checkForCatch;
-	    }
-	    goto nonRecursiveCallStart;
+            * One of the callbacks requested a new execution: a tailcall!
+            * Start the new bytecode.
+            */
+
+           goto nonRecursiveCallStart;
 	}
+	Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (2)");
     }
     return result;
 }
diff --git a/tests/NRE.test b/tests/NRE.test
index dc306c7..b80eed8 100644
--- a/tests/NRE.test
+++ b/tests/NRE.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: NRE.test,v 1.7 2008/07/31 00:43:10 msofer Exp $
+# RCS: @(#) $Id: NRE.test,v 1.8 2008/07/31 03:42:17 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -512,20 +512,14 @@ test NRE-T.7 {tailcall does return} -constraints {tailcall} -setup {
 	    b
 	    append res c
 	}
-	proc d {} {
-	    variable res
-	    append res d
-	    c
-	    append res d
-	}
     }
 } -body {
-    namespace eval ::foo d
+    namespace eval ::foo c
 } -cleanup {
     namespace delete ::foo
-} -result dcbabcd
+} -result cbabc
 
-test NRE-T.8 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
+test NRE-T.8 {tailcall tailcall} -constraints {tailcall} -setup {
     namespace eval ::foo {
 	variable res {}
 	proc a {} {
@@ -546,89 +540,14 @@ test NRE-T.8 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
 	    b
 	    append res c
 	}
-	proc d {} {
-	    variable res
-	    append res d
-	    c
-	    append res d
-	}
     }
 } -body {
-    namespace eval ::foo d
+    namespace eval ::foo c
 } -cleanup {
     namespace delete ::foo
-} -result dcbacd
-
-test NRE-T.9 {tailcall does return} -constraints {tailcall} -setup {
-    namespace eval ::foo {
-	variable res {}
-	proc a {} {
-	    variable res
-	    append res a
-	    tailcall {set x 1}
-	    append res a
-	}
-	proc b {} {
-	    variable res
-	    append res b
-	    a
-	    append res b
-	}
-	proc c {} {
-	    variable res
-	    append res c
-	    b
-	    append res c
-	}
-	proc d {} {
-	    variable res
-	    append res d
-	    c
-	    append res d
-	}
-    }
-} -body {
-    namespace eval ::foo d
-} -cleanup {
-    namespace delete ::foo
-} -result dcbabcd
-
-test NRE-T.10 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
-    namespace eval ::foo {
-	variable res {}
-	proc a {} {
-	    variable res
-	    append res a
-	    tailcall {tailcall set x 1}
-	    append res a
-	}
-	proc b {} {
-	    variable res
-	    append res b
-	    a
-	    append res b
-	}
-	proc c {} {
-	    variable res
-	    append res c
-	    b
-	    append res c
-	}
-	proc d {} {
-	    variable res
-	    append res d
-	    c
-	    append res d
-	}
-    }
-} -body {
-    namespace eval ::foo d
-} -cleanup {
-    namespace delete ::foo
-} -result dcbacd
-
+} -match glob -result *tailcall* -returnCodes error
 
-test NRE-T.11 {tailcall factorial} -constraints {tailcall} -setup {
+test NRE-T.9 {tailcall factorial} -constraints {tailcall} -setup {
     proc fact {n {b 1}} {
 	if {$n == 1} {
 	    return $b