* 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:

7 files changed, 337 insertions, 122 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9509848..7c9da84 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.347 2008/08/01 17:07:47 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.348 2008/08/03 17:33:10 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -133,26 +133,7 @@ static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
 static Tcl_NRPostProc   NRCommand;
 static Tcl_NRPostProc   NRRunObjProc;
 
-static Tcl_NRPostProc	TailcallEval;
-static Tcl_NRPostProc	TailcallCleanup;
-
-#define NR_IS_COMMAND(callbackPtr) 			\
-    (callbackPtr					\
-	    && (callbackPtr->procPtr == NRCommand) 	\
-	    && (PTR2INT(callbackPtr->data[1])))
-
-#define NR_CLEAR_COMMAND(interp)			\
-    {							\
-	TEOV_callback *callbackPtr = TOP_CB(interp);	\
-							\
-	while (!NR_IS_COMMAND(callbackPtr)) {		\
-	    callbackPtr = callbackPtr->nextPtr;		\
-	}						\
-	if (callbackPtr) {				\
-	    callbackPtr->data[1] = INT2PTR(0);		\
-	}\
-    }
-
+static Tcl_NRPostProc	AtProcExitCleanup;
 
 /*
  * The following structure define the commands in the Tcl core.
@@ -790,11 +771,13 @@ Tcl_CreateInterp(void)
 	    Tcl_DisassembleObjCmd, NULL, NULL);
 
     /*
-     * Create an unsupported command for tailcalls
+     * Create unsupported commands for atProcExit and tailcall
      */
 
+    Tcl_NRCreateCommand(interp, "::tcl::unsupported::atProcExit",
+	    /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(0), NULL);
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::tailcall",
-	    /*objProc*/ NULL, TclTailcallObjCmd, NULL, NULL);
+	    /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(1), NULL);
 
 #ifdef USE_DTRACE
     /*
@@ -4032,8 +4015,7 @@ TclNREvalObjv(
      * finishes the source command and not just the target.
      */
 
-    TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1),
-	    NULL, NULL);
+    TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
     cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
     
     TclResetCancellation(interp, 0);
@@ -4190,15 +4172,15 @@ TclNRRunCallbacks(
 
 	if (tebcCall && (callbackPtr->procPtr == NRRunBytecode)) {
 		return TCL_OK;
-	} else if (callbackPtr->procPtr == NRDoTailcall) {
+	} else if (callbackPtr->procPtr == NRAtProcExit) {
 	    if (tebcCall == 1) {
 		return TCL_OK;
 	    } else if (tebcCall == 2) {
 		Tcl_SetResult(interp,
-			"tailcall cannot be invoked recursively", TCL_STATIC);
+			"atProcExit/tailcall cannot be invoked recursively", TCL_STATIC);
 	    } else {
 		Tcl_SetResult(interp,
-			"tailcall can only be called from a proc or lambda", TCL_STATIC);
+			"atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC);
 	    }
 	    TOP_CB(interp) = callbackPtr->nextPtr;
 	    result = TCL_ERROR;
@@ -4289,7 +4271,7 @@ NRRunBytecode(
 }
 
 int
-NRDoTailcall(
+NRAtProcExit(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -7827,12 +7809,6 @@ Tcl_NREvalObjv(
     return TclNREvalObjv(interp, objc, objv, flags, NULL);
 }
 
-void
-TclNRClearCommandFlag(
-    Tcl_Interp *interp)
-{
-    NR_CLEAR_COMMAND(interp);
-}
 
 int
 Tcl_NRCmdSwap(
@@ -7842,11 +7818,7 @@ Tcl_NRCmdSwap(
     Tcl_Obj *const objv[],
     int flags)
 {
-    int result;
-
-    result = TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd);
-    NR_CLEAR_COMMAND(interp);
-    return result;
+    return TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd);
 }
 
 /*****************************************************************************
@@ -7874,7 +7846,7 @@ Tcl_NRCmdSwap(
  */
 
 int
-TclTailcallObjCmd(
+TclNRAtProcExitObjCmd(
     ClientData clientData,
     Tcl_Interp *interp,
     int objc,
@@ -7886,12 +7858,13 @@ TclTailcallObjCmd(
     
     if (objc < 2) {
 	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   */
 	Tcl_SetResult(interp,
-	    "tailcall can only be called from a proc or lambda", TCL_STATIC);
+	    "atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC);
 	return TCL_ERROR;
     }
 
@@ -7905,14 +7878,14 @@ TclTailcallObjCmd(
      * proper place.
      */
 
-    TclNRAddCallback(interp, TailcallEval, listPtr, nsPtr, NULL, NULL);
-    TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL);
+    TclNRAddCallback(interp, NRAtProcExitEval, listPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, NRAtProcExit, clientData, NULL, NULL, NULL);
 
     return TCL_OK;
 }
 
-static int
-TailcallEval(
+int
+NRAtProcExitEval(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -7923,7 +7896,7 @@ TailcallEval(
     int objc;
     Tcl_Obj **objv;
 
-    TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
+    TclNRAddCallback(interp, AtProcExitCleanup, listPtr, NULL, NULL, NULL);
     if (result == TCL_OK) {
 	iPtr->lookupNsPtr = nsPtr;
 	ListObjGetElements(listPtr, objc, objv);
@@ -7944,7 +7917,7 @@ TailcallEval(
 }
 
 static int
-TailcallCleanup(
+AtProcExitCleanup(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 8d1db2c..14d3880 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.98 2008/07/31 00:43:09 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.99 2008/08/03 17:33:10 msofer Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -838,7 +838,9 @@ typedef struct {
  */
 
 MODULE_SCOPE Tcl_NRPostProc   NRRunBytecode;
-MODULE_SCOPE Tcl_NRPostProc   NRDoTailcall;
+MODULE_SCOPE Tcl_NRPostProc   NRAtProcExit;
+MODULE_SCOPE Tcl_NRPostProc   NRAtProcExitEval;
+
 
 /*
  *----------------------------------------------------------------
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
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 31114e9..ecd0300 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.386 2008/07/31 20:01:40 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.387 2008/08/03 17:33:10 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -2029,7 +2029,7 @@ typedef struct InterpList {
  *			other than these should be turned into errors.
  */
 
-#define TCL_ALLOW_EXCEPTIONS	4
+#define TCL_ALLOW_EXCEPTIONS	  4
 #define TCL_EVAL_FILE             2
 #define TCL_EVAL_CTX              8
 
@@ -2534,13 +2534,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
-MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRAtProcExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclAtProcExitObjCmd;
 
 MODULE_SCOPE int        TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
 	                    int flags);
 
-MODULE_SCOPE void       TclNRClearCommandFlag(Tcl_Interp *interp);
-
 MODULE_SCOPE void       TclAdvanceLines(int *line, const char *start,
 			    const char *end);
 MODULE_SCOPE void       TclArgumentEnter(Tcl_Interp* interp,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index daa705b..4f15134 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.95 2008/07/31 14:43:46 msofer Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.96 2008/08/03 17:33:12 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1762,7 +1762,6 @@ AliasNRCmd(
     Tcl_Obj *listPtr;
     List *listRep;
     int flags = TCL_EVAL_INVOKE;
-    int result;
     
     /*
      * Append the arguments to the command prefix and invoke the command in
@@ -1808,9 +1807,7 @@ AliasNRCmd(
     if (isRootEnsemble) {
 	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
     }
-    result = Tcl_NREvalObj(interp, listPtr, flags);
-    TclNRClearCommandFlag(interp);
-    return result;
+    return Tcl_NREvalObj(interp, listPtr, flags);
 }
 
 static int
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index bad1fc7..c9f022d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,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.173 2008/07/31 14:43:47 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.174 2008/08/03 17:33:12 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -6224,7 +6224,7 @@ NsEnsembleImplementationCmdNR(
 				 * target command prefix. */
 	Tcl_Obj *copyPtr;	/* The actual list of words to dispatch to.
 				 * Will be freed by the dispatch engine. */
-	int prefixObjc, copyObjc, result;
+	int prefixObjc, copyObjc;
 	Interp *iPtr = (Interp *) interp;
 
 	/*
@@ -6285,9 +6285,7 @@ NsEnsembleImplementationCmdNR(
 	 * Hand off to the target command.
 	 */
 	
-	result = Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
-	TclNRClearCommandFlag(interp);
-	return result;
+	return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
     }
 
   unknownOrAmbiguousSubcommand:
diff --git a/tests/unsupported.test b/tests/unsupported.test
index 7d09558..fc64e01 100644
--- a/tests/unsupported.test
+++ b/tests/unsupported.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: unsupported.test,v 1.1 2008/08/02 14:12:56 msofer Exp $
+# RCS: @(#) $Id: unsupported.test,v 1.2 2008/08/03 17:33:13 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -17,6 +17,18 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 testConstraint testnrelevels [llength [info commands testnrelevels]]
+testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
+testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
+
+if {[testConstraint atProcExit]} {
+    namespace eval tcl::unsupported namespace export atProcExit
+    namespace import tcl::unsupported::atProcExit
+}
+
+if {[testConstraint tailcall]} {
+    namespace eval tcl::unsupported namespace export tailcall
+    namespace import tcl::unsupported::tailcall
+}
 
 #
 # The tests that risked blowing the C stack on failure have been removed: we
@@ -62,15 +74,119 @@ if {[testConstraint testnrelevels]} {
 }
 
 #
-# Test tailcalls
+# Test atProcExit
 #
 
-testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
+test unsupported-A.1 {atProcExit works} -constraints {atProcExit} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit set ::x 1
+	set x 2
+	set y $x
+	set x 3
+    }
+    proc b {} a
+} -body {
+    list [b] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+    rename b {}
+} -result {3 1 2}
 
-if {[testConstraint tailcall]} {
-    namespace eval tcl::unsupported namespace export tailcall
-    namespace import tcl::unsupported::tailcall
-}
+test unsupported-A.2 {atProcExit} -constraints {atProcExit} -setup {
+    variable x x y x
+    proc a {} {
+	variable x 0 y 0
+	atProcExit set ::x 1
+	set x 2
+	set y $x
+	set x 3
+    }
+} -body {
+    list [a] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+} -result {3 1 2}
+
+test unsupported-A.3 {atProcExit} -constraints {atProcExit} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit lappend ::x 1
+	lappend x 2
+	atProcExit lappend ::x 3
+	lappend y $x
+	lappend x 4
+	return 5
+    }
+} -body {
+    list [a] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+} -result {5 {0 2 4 3 1} {0 {0 2}}}
+
+test unsupported-A.4 {atProcExit errors} -constraints {atProcExit} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit lappend ::x 1
+	lappend x 2
+	atProcExit lappend ::x 3
+	lappend y $x
+	lappend x 4
+	error foo
+    }
+} -body {
+    list [a] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+} -returnCodes error -result foo
+
+test unsupported-A.5 {atProcExit errors} -constraints {atProcExit} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit error foo
+	lappend x 2
+	atProcExit lappend ::x 3
+	lappend y $x
+	lappend x 4
+	return 5
+    }
+} -body {
+    list [a] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+} -result {5 {0 2 4 3} {0 {0 2}}}
+
+test unsupported-A.6 {atProcExit errors} -constraints {atProcExit} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit lappend ::x 1
+	lappend x 2
+	atProcExit error foo
+	lappend y $x
+	lappend x 4
+	return 5
+    }
+} -body {
+    list [a] $x $y 
+} -cleanup {
+    unset x y
+    rename a {}
+} -result {5 {0 2 4} {0 {0 2}}}
+
+
+#
+# Test tailcalls
+#
 
 test unsupported-T.0 {tailcall is constant space} -constraints {tailcall} -setup {
     proc a i {
@@ -117,8 +233,8 @@ test unsupported-T.1 {tailcall} -constraints {tailcall} -body {
 
 
 test unsupported-T.2 {tailcall in non-proc} -constraints {tailcall} -body {
-    list [catch {namespace eval a [list tailcall set x 1]} msg] $msg
-} -result {1 {tailcall can only be called from a proc or lambda}}
+    namespace eval a [list tailcall set x 1]
+} -match glob -result *tailcall* -returnCodes error
 
 test unsupported-T.3 {tailcall falls off tebc} -constraints {tailcall} -body {
     unset -nocomplain x
@@ -233,12 +349,42 @@ test unsupported-T.9 {tailcall factorial} -constraints {tailcall} -setup {
 } -result {1 120 3628800 1307674368000}
 
 
+#
+#  Test both together
+#
+
+test unsupported-AT.1 {atProcExit and tailcall} -constraints {
+    atProcExit tailcall
+} -setup {
+    variable x x y y
+    proc a {} {
+	variable x 0 y 0
+	atProcExit lappend ::x 1
+	lappend x 2
+	atProcExit lappend ::x 3
+	tailcall lappend ::x 6
+	lappend y $x
+	lappend x 4
+	return 5
+    }
+} -body {
+    list [a] $x $y
+} -cleanup {
+    unset x y
+    rename a {}
+} -result {{0 2 3 1 6} {0 2 3 1 6} 0}
+
+
+# cleanup
+::tcltest::cleanupTests
+
 if {[testConstraint tailcall]} {
     namespace forget tcl::unsupported::tailcall
 }
 
-# cleanup
-::tcltest::cleanupTests
+if {[testConstraint atProcExit]} {
+    namespace forget tcl::unsupported::atProcExit
+}
 
 if {[testConstraint testnrelevels]} {
     namespace forget testnre::*