summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c69
-rw-r--r--generic/tclCompile.h6
-rw-r--r--generic/tclExecute.c192
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclInterp.c7
-rw-r--r--generic/tclNamesp.c8
-rw-r--r--tests/unsupported.test168
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::*
generated by cgit v0.12 at 2024-07-19 23:04:16 (GMT)