* generic/tclBasic.c: Improved tailcalls and tests.

	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclTest.c:
	* tests/NRE.test:

4 files changed, 109 insertions, 70 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fd93641..fa42894 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.338 2008/07/30 17:54:23 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.339 2008/07/31 00:43:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -130,7 +130,8 @@ static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
 static Tcl_NRPostProc   NRCommand;
 static Tcl_NRPostProc   NRRunObjProc;
 
-static Tcl_NRPostProc	EvalTailcall;
+static Tcl_NRPostProc	TailcallEval;
+static Tcl_NRPostProc	TailcallCleanup;
 
 #define NR_IS_COMMAND(callbackPtr) 			\
     (callbackPtr					\
@@ -4180,7 +4181,7 @@ TclNRRunCallbacks(
 
 	if (tebcCall) {
 	    if ((callbackPtr->procPtr == NRRunBytecode) ||
-		    (callbackPtr->procPtr == NRDropCommand)) {
+		    (callbackPtr->procPtr == NRDoTailcall)) {
 		/*
 		 * TEBC pass thru: let the caller tebc handle and get rid of
 		 * this callback.
@@ -4190,6 +4191,16 @@ TclNRRunCallbacks(
 	    }
 	}
 
+	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);
+	    result = TCL_ERROR;
+	}
+	
 	/*
 	 * IMPLEMENTATION REMARKS (FIXME)
 	 *
@@ -4273,7 +4284,7 @@ NRRunBytecode(
 }
 
 int
-NRDropCommand(
+NRDoTailcall(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -5666,7 +5677,7 @@ TclNREvalObjEx(
      * evaluation of canonical lists, compileation and bytecode execution and
      * finally direct evaluation. Precisely one of these blocks will be run.
      */
-    
+
     if ((objPtr->typePtr == &tclListType) &&	   /* is a list... */
 	    ((objPtr->bytes == NULL ||		   /* ...without a string rep */
 		    listRepPtr->canonicalFlag))) { /* ...or that is canonical */
@@ -5810,7 +5821,7 @@ TclNREvalObjEx(
 	     * the easy dynamic branch. No need to perform more complex
 	     * invokations.
 	     */
-	    
+
 	    int pc = 0;
 	    CmdFrame *ctxPtr = (CmdFrame *)
 		TclStackAlloc(interp, sizeof(CmdFrame));
@@ -5841,7 +5852,7 @@ TclNREvalObjEx(
 		/*
 		 * Absolute context to reuse.
 		 */
-		
+
 		iPtr->invokeCmdFramePtr = ctxPtr;
 		iPtr->evalFlags |= TCL_EVAL_CTX;
 		
@@ -5862,7 +5873,7 @@ TclNREvalObjEx(
 	return result;
     }
 }
-    
+
 static int
 TEOEx_ByteCodeCallback(
     ClientData data[],
@@ -7886,26 +7897,11 @@ TclTailcallObjCmd(
 	count += NR_IS_COMMAND(tailPtr);
     }
 
-#if 1
     if (!iPtr->varFramePtr->isProcCallFrame) {
-	/* FIXME! Why error? Just look if we have a TEOV above! */
 	Tcl_SetResult(interp,
 	    "tailcall can only be called from a proc or lambda", TCL_STATIC);
 	return TCL_ERROR;
     }
-#else
-    if (!tailPtr->nextPtr) {
-	/* FIXME! Is this the behaviour we want? */
-	Tcl_SetResult(interp,
-	    "cannot tailcall: not running a command", TCL_STATIC);
-	return TCL_ERROR;
-    }
-#endif
-
-    /*
-     * Temporarily put NULL as the TOP_BC, register a callback, then
-     * replug things back the way they were.
-     */
 
     nsPtr->activationCount++;
     if (objc == 2) {
@@ -7913,18 +7909,22 @@ TclTailcallObjCmd(
     } else {
 	scriptPtr = Tcl_NewListObj(objc-1, objv+1);
     }
+    Tcl_IncrRefCount(scriptPtr);
+
+    /*
+     * Add two callbacks: first the one to actually evaluate the tailcalled
+     * command, then the one that signals TEBC to stash the first at its
+     * proper place.
+     */
 
-    TOP_CB(iPtr) = tailPtr->nextPtr;
-    TclNRAddCallback(interp, EvalTailcall, scriptPtr, nsPtr, NULL, NULL);
-    tailPtr->nextPtr = TOP_CB(iPtr);
-    TOP_CB(iPtr) = rootPtr;
+    TclNRAddCallback(interp, TailcallEval, scriptPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL);
 
-    TclNRAddCallback(interp, NRDropCommand, NULL, NULL, NULL, NULL);
     return TCL_OK;
 }
 
 static int
-EvalTailcall(
+TailcallEval(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -7933,6 +7933,7 @@ EvalTailcall(
     Tcl_Obj *scriptPtr = data[0];
     Namespace *nsPtr = data[1];
 
+    TclNRAddCallback(interp, TailcallCleanup, scriptPtr, NULL, NULL, NULL);
     if (result == TCL_OK) {
 	iPtr->lookupNsPtr = nsPtr;
 	result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0);
@@ -7950,6 +7951,16 @@ EvalTailcall(
     }
     return result;
 }
+
+static int
+TailcallCleanup(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_DecrRefCount((Tcl_Obj *) data[0]);
+    return result;
+}
 
 void
 Tcl_NRAddCallback(
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c5ab71d..8d1db2c 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.97 2008/07/29 05:30:25 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.98 2008/07/31 00:43:09 msofer Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -838,7 +838,7 @@ typedef struct {
  */
 
 MODULE_SCOPE Tcl_NRPostProc   NRRunBytecode;
-MODULE_SCOPE Tcl_NRPostProc   NRDropCommand;
+MODULE_SCOPE Tcl_NRPostProc   NRDoTailcall;
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 9574e0f..2a1d232 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.390 2008/07/29 20:53:21 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.391 2008/07/31 00:43:09 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1815,28 +1815,59 @@ TclExecuteByteCode(
 	TCLNR_FREE(interp, callbackPtr);
 
 	if (procPtr == NRRunBytecode) {
-	    NR_DATA_BURY(); /* this level's state variables */
+	    /*
+	     * A request to run a bytecode: record this level's state
+	     * variables, swap codePtr and start running the new one.
+	     */
+	    
+	    NR_DATA_BURY();
 	    codePtr = newCodePtr;
-	} else if (procPtr == NRDropCommand) {
+	} else if (procPtr == NRDoTailcall) {
 	    /*
-	     * A request to perform a tailcall: just drop this
-	     * bytecode as it is; the tailCall has been scheduled in
-	     * the callbacks.
+	     * A request to perform a tailcall: schedule the tailcall callback
+	     * at its proper place, then just drop the present bytecode.
 	     */
+
+	    TEOV_callback *tailcallPtr = TOP_CB(interp);
+	    TEOV_callback *tmpPtr = tailcallPtr;
+	    
+	    if (catchTop != initCatchTop) {
+		/* FIXME!! If we catch it, the tailcall callback is still in
+		 * and will be run when we return! Should we fish it out? */
+
+		result = TCL_ERROR;
+		Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+			TCL_STATIC);
+		goto checkForCatch;
+	    }
+
+	    TOP_CB(interp) = tailcallPtr->nextPtr;
 #ifdef TCL_COMPILE_DEBUG
 	    if (traceInstructions) {
 		fprintf(stdout, "   Tailcall: request received\n");
 	    }
 #endif
-	    if (catchTop != initCatchTop) {
+	    if (bottomPtr->prevBottomPtr) {
+		while (tmpPtr->nextPtr != bottomPtr->prevBottomPtr->rootPtr) {
+		    tmpPtr = tmpPtr->nextPtr;
+		}
+		tailcallPtr->nextPtr = tmpPtr->nextPtr;
+		tmpPtr->nextPtr = tailcallPtr;
+		goto abnormalReturn; /* drop a level */
+	    } else {
+		/*
+		 * This will fall off TEBC; how do we know where to put it? It
+		 * should be after all cleanup of the current command is done,
+		 * but we do not know where that is.
+		 */
+
+		Tcl_SetResult(interp,
+			"tailcall would fall off tebc!", TCL_STATIC);
 		result = TCL_ERROR;
-		Tcl_SetResult(interp,"Tailcall called from within a catch environment",
-			TCL_STATIC);
 		goto checkForCatch;
 	    }
-	    goto abnormalReturn; /* drop a level */
 	} else {
-	    Tcl_Panic("TEBC: TRCB sent us a record we cannot handle! (1)");
+	    Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (1)");
 	}
     }
     nested = 1;
@@ -7661,8 +7692,8 @@ TclExecuteByteCode(
 	DECACHE_STACK_INFO();
 	if (TOP_CB(interp) == bottomPtr->rootPtr) {
 	    /*
-	     * The bytecode is returning, remove the caller's arguments and
-	     * keep processing the caller.
+	     * The bytecode is returning, all callbacks were run. Remove the
+	     * caller's arguments and keep processing the caller.
 	     */
 	    
 	    while (cleanup--) {
@@ -7672,32 +7703,20 @@ TclExecuteByteCode(
 	    goto nonRecursiveCallReturn;
 	} else {
 	    /*
-	     * A request for a new execution: a tailcall. Remove the caller's
-	     * arguments and start the new bytecode.
-	     *
-	     * FIXME KNOWNBUG: we get a pointer smash if we do remove the
-	     * arguments, a leak otherwise: tailcalls are not yet quite
-	     * there. Chose to leave the leak for now.
+	     * One of the callbacks requested a new execution: a tailcall!
+	     * Start the new bytecode.
 	     */
 		
-	    TEOV_callback *callbackPtr = TOP_CB(interp);
-	    Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
-
-	    if (procPtr == NRRunBytecode) {
-		goto nonRecursiveCallStart;
-	    } else if (procPtr == NRDropCommand) {
-		/* FIXME: 'tailcall tailcall' not yet working */
-		Tcl_Panic("Tailcalls from within tailcalls are not yet implemented");
-		if (catchTop != initCatchTop) {
-		    result = TCL_ERROR;
-		    Tcl_SetResult(interp,"Tailcall called from within a catch environment",
-			    TCL_STATIC);
-		    goto checkForCatch;
-		}
-		goto abnormalReturn; /* drop a level */
-	    } else {
-		Tcl_Panic("TEBC: TEOV sent us a record we cannot handle! (2)");		
+	    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;
 	}
     }
     return result;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 4ce4277..1cb6714 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,11 +14,12 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTest.c,v 1.119 2008/07/29 05:30:38 msofer Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.120 2008/07/31 00:43:10 msofer Exp $
  */
 
 #define TCL_TEST
 #include "tclInt.h"
+#include "tclNRE.h"
 
 /*
  * Required for Testregexp*Cmd
@@ -6545,7 +6546,9 @@ TestNRELevels(
     static ptrdiff_t *refDepth = NULL;
     ptrdiff_t depth;
     Tcl_Obj *levels[5];
-
+    int i = 0;
+    TEOV_callback *cbPtr = ((Interp *) interp)->execEnvPtr->callbackPtr;
+    
     if (refDepth == NULL) {
 	refDepth = &depth;
     }
@@ -6558,8 +6561,14 @@ TestNRELevels(
     levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
     levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr
 		    - iPtr->execEnvPtr->execStackPtr->stackWords));
+
+    while (cbPtr) {
+	i++;
+	cbPtr = cbPtr->nextPtr;
+    }
+    levels[5] = Tcl_NewIntObj(i);
     
-    Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels));
+    Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
     return TCL_OK;
 }