* generic/tclBasic.c: new unsupported command atProcExit

	* generic/tclCompile.h:    that shares the implementation with
	* generic/tclExecute.c:    tailcall. Fixed a segfault in
	* generic/tclInt.h:        tailcalls. Tests added.
	* generic/tclInterp.c:
	* generic/tclNamesp.c:
	* tests/unsupported.test:

1 files changed, 146 insertions, 46 deletions

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0645d53..3f8f4a7 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.393 2008/07/31 14:43:44 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.394 2008/08/03 17:33:10 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -178,6 +178,8 @@ typedef struct BottomData {
     ByteCode *codePtr;		 /* These fields remain constant until it     */
     CmdFrame *cmdFramePtr;       /* returns.                                  */
                                  /* ------------------------------------------*/
+    TEOV_callback *atExitPtr;    /* This field is used on return FROM here    */
+                                 /* ------------------------------------------*/
     unsigned char *pc;           /* These fields are used on return TO this   */
     ptrdiff_t *catchTop;         /* this level: they record the state when  a */
     int cleanup;     		 /* new codePtr was received for NR execution */
@@ -186,9 +188,10 @@ typedef struct BottomData {
 
 #define NR_DATA_INIT()				\
     bottomPtr->prevBottomPtr = oldBottomPtr;	\
-    bottomPtr->rootPtr = TOP_CB(iPtr);	\
-    bottomPtr->codePtr = codePtr;	\
-    bottomPtr->cmdFramePtr = iPtr->cmdFramePtr
+    bottomPtr->rootPtr = TOP_CB(iPtr);		\
+    bottomPtr->codePtr = codePtr;		\
+    bottomPtr->cmdFramePtr = iPtr->cmdFramePtr;	\
+    bottomPtr->atExitPtr = NULL
 
 #define NR_DATA_BURY()				\
     bottomPtr->pc = pc;				\
@@ -207,6 +210,8 @@ typedef struct BottomData {
     tosPtr = esPtr->tosPtr;				\
     iPtr->cmdFramePtr = bottomPtr->cmdFramePtr; 
 
+static Tcl_NRPostProc NRRestoreInterpState;
+
 #define PUSH_AUX_OBJ(objPtr)					\
     objPtr->internalRep.twoPtrValue.ptr2 = auxObjList;		\
     auxObjList = objPtr
@@ -1707,6 +1712,22 @@ TclIncrObj(
  *----------------------------------------------------------------------
  */
 
+static int
+NRRestoreInterpState(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    /* FIXME
+     * Save the current state somewhere for instrospection of what happened in
+     * the atExit handlers?
+     */
+
+    Tcl_InterpState state = data[0];
+    
+    return Tcl_RestoreInterpState(interp, state);
+}
+
 int
 TclExecuteByteCode(
     Tcl_Interp *interp,		/* Token for command interpreter. */
@@ -1804,6 +1825,8 @@ TclExecuteByteCode(
      */
 
     int nested = 0;
+    TEOV_callback *atExitPtr = NULL;
+    int isTailcall = 0;
     
     nonRecursiveCallStart:
     if (nested) {
@@ -1811,12 +1834,15 @@ TclExecuteByteCode(
 	Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
 	ByteCode *newCodePtr = callbackPtr->data[0];
 
+	isTailcall = PTR2INT(callbackPtr->data[0]);
+	
 	NRE_ASSERT(result==TCL_OK);
 	NRE_ASSERT(callbackPtr != bottomPtr->rootPtr);	
 
 	TOP_CB(interp) = callbackPtr->nextPtr;
 	TCLNR_FREE(interp, callbackPtr);
 
+	NR_DATA_BURY();
 	if (procPtr == NRRunBytecode) {
 	    /*
 	     * A request to run a bytecode: record this level's state
@@ -1825,49 +1851,58 @@ TclExecuteByteCode(
 	    
 	    NR_DATA_BURY();
 	    codePtr = newCodePtr;
-	} else if (procPtr == NRDoTailcall) {
+	} else if (procPtr == NRAtProcExit) {
 	    /*
-	     * A request to perform a tailcall: schedule the tailcall callback
-	     * at its proper place, then just drop the present bytecode.
+	     * A request to perform a command at exit: schedule the command at
+	     * its proper place, then continue or just drop the present bytecode if
+	     * this is a tailcall.
 	     */
 
-	    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? */
+	    TEOV_callback *newPtr = TOP_CB(interp);
 
-		result = TCL_ERROR;
-		Tcl_SetResult(interp,"Tailcall called from within a catch environment",
-			TCL_STATIC);
-		goto checkForCatch;
-	    }
+	    TOP_CB(interp) = newPtr->nextPtr;
 
-	    TOP_CB(interp) = tailcallPtr->nextPtr;
+	    if (!isTailcall) {	    
 #ifdef TCL_COMPILE_DEBUG
-	    if (traceInstructions) {
-		fprintf(stdout, "   Tailcall: request received\n");
-	    }
-#endif
-	    if (bottomPtr->prevBottomPtr) {
-		while (tmpPtr->nextPtr != bottomPtr->prevBottomPtr->rootPtr) {
-		    tmpPtr = tmpPtr->nextPtr;
+		if (traceInstructions) {
+		    fprintf(stdout, "   atProcExit request received\n");
 		}
-		tailcallPtr->nextPtr = tmpPtr->nextPtr;
-		tmpPtr->nextPtr = tailcallPtr;
-		goto abnormalReturn; /* drop a level */
+#endif
+		newPtr->nextPtr = bottomPtr->atExitPtr;
+		bottomPtr->atExitPtr = newPtr;
+		goto nonRecursiveCallReturn;
 	    } 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;
-		goto checkForCatch;
+		
+#ifdef TCL_COMPILE_DEBUG
+		if (traceInstructions) {
+		    fprintf(stdout, "   Tailcall request received\n");
+		}
+#endif
+		if (catchTop != initCatchTop) {
+		    isTailcall = 0;
+		    result = TCL_ERROR;
+		    Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+			    TCL_STATIC);
+		    goto checkForCatch;
+		}
+		
+		newPtr->nextPtr = NULL;
+		if (!bottomPtr->atExitPtr) {
+		    newPtr->nextPtr = NULL;
+		    bottomPtr->atExitPtr = newPtr;
+		} else {
+		    /*
+		     * There are already atExit callbacks: run last. 
+		     */
+		    
+		    TEOV_callback *tmpPtr = bottomPtr->atExitPtr;
+		    
+		    while (tmpPtr->nextPtr) {
+			tmpPtr = tmpPtr->nextPtr;
+		    }
+		    tmpPtr->nextPtr = newPtr;
+		}
+		goto abnormalReturn;
 	    }
 	} else {
 	    Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (1)");
@@ -7677,6 +7712,7 @@ TclExecuteByteCode(
     TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
 
     oldBottomPtr = bottomPtr->prevBottomPtr;
+    atExitPtr = bottomPtr->atExitPtr;
     TclStackFree(interp, bottomPtr);     /* free my stack */
 
     if (--codePtr->refCount <= 0) {
@@ -7685,19 +7721,53 @@ TclExecuteByteCode(
 
     if (oldBottomPtr) {
 	/*
-	 * Restore the state to what it was previous to this bytecode.
+	 * Restore the state to what it was previous to this bytecode, deal
+	 * with atExit handlers and tailcalls.
 	 */
 
-	bottomPtr = oldBottomPtr;        /* back to old bc */	
+	bottomPtr = oldBottomPtr;        /* back to old bc */
+
+      rerunCallbacks:
 	result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 2);
 	
 	NR_DATA_DIG();
 	DECACHE_STACK_INFO();
 	if (TOP_CB(interp) == bottomPtr->rootPtr) {
 	    /*
-	     * The bytecode is returning, all callbacks were run. Remove the
-	     * caller's arguments and keep processing the caller.
+	     * The bytecode is returning, all callbacks were run. Run atExit
+	     * handlers, remove the caller's arguments and keep processing the
+	     * caller. 
 	     */
+
+	    if (atExitPtr) {
+		/*
+		 * Find the last one
+		 */
+
+		TEOV_callback *lastPtr = atExitPtr;
+		while (lastPtr->nextPtr) {
+		    lastPtr = lastPtr->nextPtr;
+		}
+		NRE_ASSERT(lastPtr->nextPtr == NULL);
+		if (!isTailcall) {
+		    /* save the interp state, arrange for restoring it after
+		       running the callbacks.*/
+
+		    TclNRAddCallback(interp, NRRestoreInterpState,
+			    Tcl_SaveInterpState(interp, result), NULL,
+			    NULL, NULL);
+		}
+		
+		/*
+		 * splice in the atExit callbacks and rerun all callbacks
+		 */
+
+		lastPtr->nextPtr = TOP_CB(interp);
+		TOP_CB(interp) = atExitPtr;
+		isTailcall = 0;
+		atExitPtr = NULL;
+		goto rerunCallbacks;
+	    }
 	    
 	    while (cleanup--) {
 		Tcl_Obj *objPtr = POP_OBJECT();
@@ -7706,15 +7776,45 @@ TclExecuteByteCode(
 	    goto nonRecursiveCallReturn;
 	} else 	if (TOP_CB(interp)->procPtr == NRRunBytecode) {
 	    /*
-            * One of the callbacks requested a new execution: a tailcall!
-            * Start the new bytecode.
-            */
+	     * One of the callbacks requested a new execution: a tailcall!
+	     * Start the new bytecode.
+	     */
 
 	    NRE_ASSERT(result == TCL_OK);
            goto nonRecursiveCallStart;
 	}
 	Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (2)");
     }
+
+
+    if (atExitPtr) {
+	/*
+	 * Find the last one
+	 */
+	
+	TEOV_callback *lastPtr = atExitPtr;
+	while (lastPtr->nextPtr) {
+	    lastPtr = lastPtr->nextPtr;
+	}
+	NRE_ASSERT(lastPtr->nextPtr == NULL);
+	if (!isTailcall) {
+	    /* save the interp state, arrange for restoring it after
+	       running the callbacks.*/
+	    
+	    Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
+	    
+	    TclNRAddCallback(interp, NRRestoreInterpState, state, NULL,
+		    NULL, NULL);
+	}
+	
+	/*
+	 * splice in the atExit callbacks and rerun all callbacks
+	 */
+	
+	lastPtr->nextPtr = TOP_CB(interp);
+	TOP_CB(interp) = atExitPtr;
+    }
+
     return result;
 }
 #undef iPtr