summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog15
-rw-r--r--generic/tcl.h3
-rw-r--r--generic/tclBasic.c102
-rw-r--r--generic/tclExecute.c145
-rw-r--r--generic/tclInt.h49
-rw-r--r--generic/tclNamesp.c31
-rw-r--r--tests/coroutine.test (renamed from tests/unsupported.test)430
-rw-r--r--tests/tailcall.test428
8 files changed, 609 insertions, 594 deletions
diff --git a/ChangeLog b/ChangeLog
index f6e932a..014bcde 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2009-03-19 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tcl.h:
+ * generic/tclInt.h:
+ * generic/tclBasic.c:
+ * generic/tclExecute.c:
+ * generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall
+ implementation, ::unsupported::atProcExit is (temporarily?)
+ gone. The new approach is much simpler, and also closer to being
+ correct. This commit fixes [Bug 2649975] and [Bug 2695587].
+
+ * tests/coroutine.test: Moved the tests to their own files,
+ * tests/tailcall.test: removed the unsupported.test. Added
+ * tests/unsupported.test: tests for the fixed bugs.
+
2009-03-19 Donal K. Fellows <dkf@users.sf.net>
* doc/tailcall.n: Added documentation for tailcall command.
diff --git a/generic/tcl.h b/generic/tcl.h
index 72c4acd..b5bced7 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.288 2009/01/16 20:44:24 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.289 2009/03/19 23:31:36 msofer Exp $
*/
#ifndef _TCL
@@ -887,6 +887,7 @@ typedef struct Tcl_CallFrame {
char *dummy10;
char *dummy11;
char *dummy12;
+ char *dummy13;
} Tcl_CallFrame;
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 50230ba..739732f 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.387 2009/03/11 10:44:20 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.388 2009/03/19 23:31:37 msofer Exp $
*/
#include "tclInt.h"
@@ -136,8 +136,8 @@ static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc NRRunObjProc;
-static Tcl_NRPostProc AtProcExitCleanup;
-static Tcl_NRPostProc NRAtProcExitEval;
+static Tcl_NRPostProc TailcallCleanup;
+static Tcl_NRPostProc NRTailcallEval;
/*
* The following structure define the commands in the Tcl core.
@@ -698,7 +698,7 @@ Tcl_CreateInterp(void)
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
- iPtr->atExitPtr = NULL;
+ iPtr->deferredCallbacks = NULL;
/*
* Create the core commands. Do it here, rather than calling
@@ -782,14 +782,11 @@ Tcl_CreateInterp(void)
Tcl_DisassembleObjCmd, NULL, NULL);
/*
- * Create the 'tailcall' command an unsupported command for 'atProcExit'
+ * Create the 'tailcall' command
*/
- Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRAtProcExitObjCmd,
- INT2PTR(TCL_NR_TAILCALL_TYPE), NULL);
-
- Tcl_NRCreateCommand(interp, "::tcl::unsupported::atProcExit", NULL,
- TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_ATEXIT_TYPE), NULL);
+ Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRTailcallObjCmd,
+ NULL, NULL);
#ifdef USE_DTRACE
/*
@@ -4056,7 +4053,7 @@ TclNREvalObjv(
* will be filled later when the command is found: save its address at
* objProcPtr.
*
- * data[1] stores a marker for use by tailcalls; it will be reset to 0 by
+ * data[1] stores a marker for use by tailcalls; it will be set to 1 by
* command redirectors (imports, alias, ensembles) so that tailcalls
* finishes the source command and not just the target.
*/
@@ -4064,6 +4061,8 @@ TclNREvalObjv(
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
+ TclNRSpliceDeferred(interp);
+
iPtr->numLevels++;
result = TclInterpReady(interp);
@@ -4220,7 +4219,6 @@ TclNRRunCallbacks(
(void) Tcl_GetObjResult(interp);
}
- restart:
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
@@ -4244,16 +4242,6 @@ TclNRRunCallbacks(
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
}
- if (iPtr->atExitPtr) {
- callbackPtr = iPtr->atExitPtr;
- while (callbackPtr->nextPtr) {
- callbackPtr = callbackPtr->nextPtr;
- }
- callbackPtr->nextPtr = rootPtr;
- TOP_CB(iPtr) = iPtr->atExitPtr;
- iPtr->atExitPtr = NULL;
- goto restart;
- }
return result;
}
@@ -4286,6 +4274,7 @@ NRCommand(
if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
result = Tcl_LimitCheck(interp);
}
+
return result;
}
@@ -4327,11 +4316,10 @@ NRCallTEBC(
switch (type) {
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
- case TCL_NR_ATEXIT_TYPE:
case TCL_NR_TAILCALL_TYPE:
- /* For atProcExit and tailcalls */
+ /* For tailcalls */
Tcl_SetResult(interp,
- "atProcExit/tailcall can only be called from a proc or lambda",
+ "tailcall can only be called from a proc or lambda",
TCL_STATIC);
return TCL_ERROR;
case TCL_NR_YIELD_TYPE:
@@ -5767,6 +5755,20 @@ TclNREvalObjEx(
* UpdateStringOfList from the internal rep).
*/
+ /*
+ * Shimmer protection! Always pass an unshared obj. The caller could
+ * incr the refCount of objPtr AFTER calling us! To be completely safe
+ * we always make a copy. The callback takes care od the refCounts for
+ * both listPtr and objPtr.
+ *
+ * FIXME OPT: preserve just the internal rep?
+ */
+
+ Tcl_IncrRefCount(objPtr);
+ listPtr = TclListObjCopy(interp, objPtr);
+ Tcl_IncrRefCount(listPtr);
+ TclDecrRefCount(objPtr);
+
if (word != INT_MIN) {
/*
* TIP #280 Structures for tracking lines. As we know that this is
@@ -5795,26 +5797,14 @@ TclNREvalObjEx(
eoFramePtr->framePtr = iPtr->framePtr;
eoFramePtr->nextPtr = iPtr->cmdFramePtr;
- eoFramePtr->cmd.listPtr = objPtr;
+ eoFramePtr->cmd.listPtr = listPtr;
eoFramePtr->data.eval.path = NULL;
iPtr->cmdFramePtr = eoFramePtr;
}
- /*
- * Shimmer protection! Always pass an unshared obj. The caller could
- * incr the refCount of objPtr AFTER calling us! To be completely safe
- * we always make a copy. The callback takes care od the refCounts for
- * both listPtr and objPtr.
- *
- * FIXME OPT: preserve just the internal rep?
- */
-
- Tcl_IncrRefCount(objPtr);
- listPtr = TclListObjCopy(interp, objPtr);
- Tcl_IncrRefCount(listPtr);
- TclNRAddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr,
- listPtr, NULL);
+ TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+ NULL, NULL);
ListObjGetElements(listPtr, objc, objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
@@ -5991,9 +5981,8 @@ TEOEx_ListCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *objPtr = data[0];
+ Tcl_Obj *listPtr = data[0];
CmdFrame *eoFramePtr = data[1];
- Tcl_Obj *listPtr = data[2];
/*
* Remove the cmdFrame
@@ -6003,7 +5992,6 @@ TEOEx_ListCallback(
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
TclStackFree(interp, eoFramePtr);
}
- TclDecrRefCount(objPtr);
TclDecrRefCount(listPtr);
return result;
@@ -7992,25 +7980,26 @@ Tcl_NRCmdSwap(
*/
int
-TclNRAtProcExitObjCmd(
+TclNRTailcallObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
+ TEOV_callback *tailcallPtr;
Tcl_Obj *listPtr;
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
-
+
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,
- "atProcExit/tailcall can only be called from a proc or lambda",
+ "tailcall can only be called from a proc or lambda",
TCL_STATIC);
return TCL_ERROR;
}
@@ -8023,15 +8012,21 @@ TclNRAtProcExitObjCmd(
* 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.
+ *
+ * Being lazy: add the callback, then remove it (to exploit the
+ * TclNRAddCallBack macro to build the callback)
*/
- TclNRAddCallback(interp, NRAtProcExitEval, listPtr, nsPtr, NULL, NULL);
- TclNRAddCallback(interp, NRCallTEBC, clientData, NULL, NULL, NULL);
+ TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+ tailcallPtr = TOP_CB(interp);
+ TOP_CB(interp) = tailcallPtr->nextPtr;
+
+ TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), tailcallPtr, NULL, NULL);
return TCL_OK;
}
int
-NRAtProcExitEval(
+NRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -8039,11 +8034,12 @@ NRAtProcExitEval(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0];
Namespace *nsPtr = data[1];
+ int omit = PTR2INT(data[2]);
int objc;
Tcl_Obj **objv;
- TclNRAddCallback(interp, AtProcExitCleanup, listPtr, NULL, NULL, NULL);
- if (result == TCL_OK) {
+ TclNRDeferCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
+ if (!omit && (result == TCL_OK)) {
iPtr->lookupNsPtr = nsPtr;
ListObjGetElements(listPtr, objc, objv);
result = TclNREvalObjv(interp, objc, objv, 0, NULL);
@@ -8063,7 +8059,7 @@ NRAtProcExitEval(
}
static int
-AtProcExitCleanup(
+TailcallCleanup(
ClientData data[],
Tcl_Interp *interp,
int result)
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e98545e..49862ae 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.428 2009/02/25 14:56:07 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.429 2009/03/19 23:31:37 msofer Exp $
*/
#include "tclInt.h"
@@ -177,8 +177,6 @@ typedef struct BottomData {
TEOV_callback *rootPtr; /* State when this bytecode execution began: */
ByteCode *codePtr; /* constant until it returns */
/* ------------------------------------------*/
- TEOV_callback *atExitPtr; /* This field is used on return FROM here */
- /* ------------------------------------------*/
const 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 */
@@ -189,7 +187,6 @@ typedef struct BottomData {
bottomPtr->prevBottomPtr = oldBottomPtr; \
bottomPtr->rootPtr = TOP_CB(iPtr); \
bottomPtr->codePtr = codePtr; \
- bottomPtr->atExitPtr = NULL
#define NR_DATA_BURY() \
bottomPtr->pc = pc; \
@@ -207,8 +204,6 @@ typedef struct BottomData {
esPtr = iPtr->execEnvPtr->execStackPtr; \
tosPtr = esPtr->tosPtr
-static Tcl_NRPostProc NRRestoreInterpState;
-
#define PUSH_AUX_OBJ(objPtr) \
objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \
auxObjList = objPtr
@@ -1722,22 +1717,6 @@ 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. */
@@ -1835,8 +1814,6 @@ TclExecuteByteCode(
*/
int nested = 0;
- TEOV_callback *atExitPtr = NULL;
- int isTailcall = 0;
if (!codePtr) {
/*
@@ -1884,65 +1861,28 @@ TclExecuteByteCode(
codePtr = param;
break;
- case TCL_NR_ATEXIT_TYPE: {
- /*
- * A request to perform a command at exit: put it in the stack
- * and continue exec'ing the current bytecode
- */
-
- TEOV_callback *newPtr = TOP_CB(interp);
-
- TOP_CB(interp) = newPtr->nextPtr;
-
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " atProcExit request received\n");
- }
-#endif
- newPtr->nextPtr = bottomPtr->atExitPtr;
- bottomPtr->atExitPtr = newPtr;
- oldBottomPtr = bottomPtr;
- goto returnToCaller;
- }
case TCL_NR_TAILCALL_TYPE: {
/*
- * A request to perform a tailcall: put it at the front of the
- * atExit stack and abandon the current bytecode.
+ * A request to perform a tailcall: just drop this bytecode.
*/
- TEOV_callback *newPtr = TOP_CB(interp);
-
- TOP_CB(interp) = newPtr->nextPtr;
- isTailcall = 1;
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " Tailcall request received\n");
}
#endif
+ TEOV_callback *tailcallPtr = param;
+
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+
if (catchTop != initCatchTop) {
- isTailcall = 0;
+ tailcallPtr->data[2] = INT2PTR(1);
result = TCL_ERROR;
Tcl_SetResult(interp,"Tailcall called from within a catch environment",
TCL_STATIC);
+ pc--;
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;
}
case TCL_NR_YIELD_TYPE: { /*[yield] */
@@ -1954,6 +1894,7 @@ TclExecuteByteCode(
TCL_STATIC);
Tcl_SetErrorCode(interp, "COROUTINE_ILLEGAL_YIELD", NULL);
result = TCL_ERROR;
+ pc--;
goto checkForCatch;
}
NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
@@ -1964,6 +1905,7 @@ TclExecuteByteCode(
TCL_STATIC);
Tcl_SetErrorCode(interp, "COROUTINE_CANT_YIELD", NULL);
result = TCL_ERROR;
+ pc--;
goto checkForCatch;
}
@@ -7823,7 +7765,6 @@ TclExecuteByteCode(
TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
oldBottomPtr = bottomPtr->prevBottomPtr;
- atExitPtr = bottomPtr->atExitPtr;
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclStackFree(interp, bottomPtr); /* free my stack */
@@ -7835,7 +7776,7 @@ TclExecuteByteCode(
if (oldBottomPtr) {
/*
* Restore the state to what it was previous to this bytecode, deal
- * with atExit handlers and tailcalls.
+ * with tailcalls.
*/
bottomPtr = oldBottomPtr; /* back to old bc */
@@ -7846,43 +7787,10 @@ TclExecuteByteCode(
NR_DATA_DIG();
if (TOP_CB(interp) == bottomPtr->rootPtr) {
/*
- * The bytecode is returning, all callbacks were run. Run atExit
- * handlers, 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.
*/
- 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();
Tcl_DecrRefCount(objPtr);
@@ -7903,7 +7811,6 @@ TclExecuteByteCode(
*/
goto nonRecursiveCallStart;
- case TCL_NR_ATEXIT_TYPE:
case TCL_NR_TAILCALL_TYPE:
TOP_CB(iPtr) = callbackPtr->nextPtr;
TCLNR_FREE(interp, callbackPtr);
@@ -7919,32 +7826,6 @@ TclExecuteByteCode(
}
}
-
- if (atExitPtr) {
- if (!isTailcall) {
- /*
- * Save the interp state, arrange for restoring it after running
- * the callbacks. Put the callback at the bottom of the atExit
- * stack.
- */
-
- Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
- TEOV_callback *lastPtr = atExitPtr;
-
- while (lastPtr->nextPtr) {
- lastPtr = lastPtr->nextPtr;
- }
- NRE_ASSERT(lastPtr->nextPtr == NULL);
-
- TclNRAddCallback(interp, NRRestoreInterpState, state, NULL,
- NULL, NULL);
- lastPtr->nextPtr = TOP_CB(iPtr);
- TOP_CB(iPtr) = TOP_CB(iPtr)->nextPtr;
- lastPtr->nextPtr->nextPtr = NULL;
- }
- iPtr->atExitPtr = atExitPtr;
- }
-
iPtr->execEnvPtr->bottomPtr = NULL;
return result;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3f7a2dc..48473bd 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.418 2009/03/09 09:12:39 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.419 2009/03/19 23:31:37 msofer Exp $
*/
#ifndef _TCLINT
@@ -1056,6 +1056,13 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
+ struct TEOV_callback *tailcallPtr;
+ /* The callback implementing the call to be
+ * executed by the command that pushed this
+ * frame. It can be TAILCALL_NONE to signal
+ * that we are tailcalling a frame further up
+ * the stack.
+ */
} CallFrame;
#define FRAME_IS_PROC 0x1
@@ -2006,10 +2013,13 @@ typedef struct Interp {
* tclOOInt.h and tclOO.c for real definition
* and setup. */
- struct TEOV_callback *atExitPtr;
- /* Callbacks to be run after a command exited;
- * this is only set for atProcExirt or
- * tailcalls that fall back out of tebc. */
+ struct TEOV_callback *deferredCallbacks;
+ /* Callbacks that are set previous to a call
+ * to some Eval function but that actually
+ * belong to the command that is about to be
+ * called - ie, they should be run *before*
+ * any tailcall is invoked.
+ */
#ifdef TCL_COMPILE_STATS
/*
@@ -2589,7 +2599,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRAtProcExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
@@ -4208,6 +4218,33 @@ typedef struct TEOV_callback {
TOP_CB(interp) = callbackPtr; \
}
+#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) { \
+ TEOV_callback *callbackPtr; \
+ TCLNR_ALLOC((interp), (callbackPtr)); \
+ callbackPtr->procPtr = (postProcPtr); \
+ callbackPtr->data[0] = (ClientData)(data0); \
+ callbackPtr->data[1] = (ClientData)(data1); \
+ callbackPtr->data[2] = (ClientData)(data2); \
+ callbackPtr->data[3] = (ClientData)(data3); \
+ callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks; \
+ ((Interp *)interp)->deferredCallbacks = callbackPtr; \
+ }
+
+#define TclNRSpliceCallbacks(interp,topPtr) { \
+ TEOV_callback *bottomPtr = topPtr; \
+ while (bottomPtr->nextPtr) { \
+ bottomPtr = bottomPtr->nextPtr; \
+ } \
+ bottomPtr->nextPtr = TOP_CB(interp); \
+ TOP_CB(interp) = topPtr; \
+ }
+
+#define TclNRSpliceDeferred(interp) \
+ if (((Interp *)interp)->deferredCallbacks) { \
+ TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
+ ((Interp *)interp)->deferredCallbacks = NULL; \
+ }
+
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(TEOV_callback), (ptr))
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 20b28eb..8caf7db 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,10 +23,11 @@
* 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.189 2009/02/10 22:50:07 nijtmans Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.190 2009/03/19 23:31:37 msofer Exp $
*/
#include "tclInt.h"
+#include "tclCompile.h" /* just for NRCommand */
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -428,7 +429,8 @@ Tcl_PushCallFrame(
framePtr->compiledLocals = NULL;
framePtr->clientData = NULL;
framePtr->localCachePtr = NULL;
-
+ framePtr->tailcallPtr = NULL;
+
/*
* Push the new call frame onto the interpreter's stack of procedure call
* frames making it the current frame.
@@ -454,6 +456,7 @@ Tcl_PushCallFrame(
* Modifies the call stack of the interpreter. Resets various fields of
* the popped call frame. If a namespace has been deleted and has no more
* activations on the call stack, the namespace is destroyed.
+ * Schedules a tailcall if one is present.
*
*----------------------------------------------------------------------
*/
@@ -505,6 +508,30 @@ Tcl_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ /*
+ * Find the splicing spot: right before the NRCommand of the thing being
+ * tailcalled. Note that we skip NRCommands marked in data[1] (used by
+ * command redirectors)
+ */
+
+ TEOV_callback *tailcallPtr, *runPtr;
+
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
+ break;
+ }
+ }
+ if (!runPtr) {
+ Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
+ }
+
+ tailcallPtr = framePtr->tailcallPtr;
+
+ tailcallPtr->nextPtr = runPtr->nextPtr;
+ runPtr->nextPtr = tailcallPtr;
+ }
}
/*
diff --git a/tests/unsupported.test b/tests/coroutine.test
index 0c706b8..fd3a3a1 100644
--- a/tests/unsupported.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered: tailcall, atProcExit, coroutine, yield
+# Commands covered: coroutine, yield, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -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.15 2008/10/14 18:49:47 dgp Exp $
+# RCS: @(#) $Id: coroutine.test,v 1.1 2009/03/19 23:31:37 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -17,17 +17,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
-testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
-
-if {[namespace exists tcl::unsupported]} {
- namespace eval tcl::unsupported namespace export *
- namespace import tcl::unsupported::*
-}
-
-#
-# The tests that risked blowing the C stack on failure have been removed: we
-# can now actually measure using testnrelevels.
-#
if {[testConstraint testnrelevels]} {
namespace eval testnre {
@@ -67,361 +56,6 @@ if {[testConstraint testnrelevels]} {
namespace import testnre::*
}
-#
-# Test atProcExit
-#
-
-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}
-
-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 unsupported-A.7 {atProcExit non-proc} -constraints {atProcExit} -body {
- atProcExit set x 2
- set x 1
-} -cleanup {
- unset -nocomplain x
-} -match glob -result *atProcExit* -returnCodes error
-
-test unsupported-A.8 {atProcExit and eval} -constraints {knownBug atProcExit} -setup {
- proc a {} {
- eval atProcExit lappend ::x 2
- set ::x 1
- }
-} -body {
- list [a] $::x
-} -cleanup {
- unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-A9 {atProcExit and uplevel} -constraints {knownBug atProcExit} -setup {
- proc a {} {
- uplevel 1 [list atProcExit set ::x 2]
- set ::x 1
- }
-} -body {
- list [a] $::x
-} -cleanup {
- unset -nocomplain ::x
-} -result {1 2}
-
-
-#
-# Test tailcalls
-#
-
-test unsupported-T.0 {tailcall is constant space} -constraints testnrelevels -setup {
- proc a i {
- if {[incr i] > 10} {
- return [depthDiff]
- }
- depthDiff
- tailcall a $i
- }
-} -body {
- a 0
-} -cleanup {
- rename a {}
-} -result {0 0 0 0 0 0}
-
-test unsupported-T.1 {tailcall} -body {
- namespace eval a {
- variable x *::a
- proc xset {} {
- set tmp {}
- set ns {[namespace current]}
- set level [info level]
- for {set i 0} {$i <= [info level]} {incr i} {
- uplevel #$i "set x $i$ns"
- lappend tmp "$i [info level $i]"
- }
- lrange $tmp 1 end
- }
- proc foo {} {tailcall xset; set x noreach}
- }
- namespace eval b {
- variable x *::b
- proc xset args {error b::xset}
- proc moo {} {set x 0; variable y [::a::foo]; set x}
- }
- variable x *::
- proc xset args {error ::xset}
- list [::b::moo] | $x $a::x $b::x | $::b::y
-} -cleanup {
- unset x
- rename xset {}
- namespace delete a b
-} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
-
-
-test unsupported-T.2 {tailcall in non-proc} -body {
- namespace eval a [list tailcall set x 1]
-} -match glob -result *tailcall* -returnCodes error
-
-test unsupported-T.3 {tailcall falls off tebc} -body {
- unset -nocomplain x
- proc foo {} {tailcall set x 1}
- list [catch foo msg] $msg [set x]
-} -cleanup {
- rename foo {}
- unset x
-} -result {0 1 1}
-
-test unsupported-T.4 {tailcall falls off tebc} -body {
- set x 2
- proc foo {} {tailcall set x 1}
- foo
- set x
-} -cleanup {
- rename foo {}
- unset x
-} -result 1
-
-test unsupported-T.5 {tailcall falls off tebc} -body {
- set x 2
- namespace eval bar {
- variable x 3
- proc foo {} {tailcall set x 1}
- }
- bar::foo
- list $x $bar::x
-} -cleanup {
- unset x
- namespace delete bar
-} -result {1 3}
-
-test unsupported-T.6 {tailcall does remove callframes} -body {
- proc foo {} {info level}
- proc moo {} {tailcall foo}
- proc boo {} {expr {[moo] - [info level]}}
- boo
-} -cleanup {
- rename foo {}
- rename moo {}
- rename boo {}
-} -result 1
-
-test unsupported-T.7 {tailcall does return} -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
- }
- }
-} -body {
- namespace eval ::foo c
-} -cleanup {
- namespace delete ::foo
-} -result cbabc
-
-test unsupported-T.8 {tailcall tailcall} -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
- }
- }
-} -body {
- namespace eval ::foo c
-} -cleanup {
- namespace delete ::foo
-} -match glob -result *tailcall* -returnCodes error
-
-test unsupported-T.9 {tailcall factorial} -setup {
- proc fact {n {b 1}} {
- if {$n == 1} {
- return $b
- }
- tailcall fact [expr {$n-1}] [expr {$n*$b}]
- }
-} -body {
- list [fact 1] [fact 5] [fact 10] [fact 15]
-} -cleanup {
- rename fact {}
-} -result {1 120 3628800 1307674368000}
-
-test unsupported-T.10 {tailcall and eval} -constraints {knownBug atProcExit} -setup {
- proc a {} {
- eval [list tailcall lappend ::x 2]
- set ::x 1
- }
-} -body {
- list [a] $::x
-} -cleanup {
- unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-T.11 {tailcall and uplevel} -constraints {knownBug atProcExit} -setup {
- proc a {} {
- uplevel 1 [list tailcall set ::x 2]
- set ::x 1
- }
-} -body {
- list [a] $::x
-} -cleanup {
- unset -nocomplain ::x
-} -result {1 2}
-
-#
-# Test both together
-#
-
-test unsupported-AT.1 {atProcExit and tailcall} -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
- 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}
-
-#
-# Test coroutines
-#
-
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
@@ -435,7 +69,7 @@ set lambda [list {{start 0} {stop 10}} {
}]
-test unsupported-C.1.1 {coroutine basic} -setup {
+test coroutine-1.1 {coroutine basic} -setup {
coroutine foo ::apply $lambda
set res {}
} -body {
@@ -448,7 +82,7 @@ test unsupported-C.1.1 {coroutine basic} -setup {
unset res
} -result {0 10 20}
-test unsupported-C.1.2 {coroutine basic} -setup {
+test coroutine-1.2 {coroutine basic} -setup {
coroutine foo ::apply $lambda 2 8
set res {}
} -body {
@@ -461,7 +95,7 @@ test unsupported-C.1.2 {coroutine basic} -setup {
unset res
} -result {16 24 32}
-test unsupported-C.1.3 {yield returns new arg} -setup {
+test coroutine-1.3 {yield returns new arg} -setup {
set body {
# init
set i $start
@@ -485,7 +119,7 @@ test unsupported-C.1.3 {yield returns new arg} -setup {
unset res
} -result {20 6 12}
-test unsupported-C.1.4 {yield in nested proc} -setup {
+test coroutine-1.4 {yield in nested proc} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
@@ -514,21 +148,21 @@ test unsupported-C.1.4 {yield in nested proc} -setup {
unset body res
} -result {0 10 20}
-test unsupported-C.1.5 {just yield} -body {
+test coroutine-1.5 {just yield} -body {
coroutine foo yield
list [foo] [catch foo msg] $msg
} -cleanup {
unset msg
} -result {{} 1 {invalid command name "foo"}}
-test unsupported-C.1.6 {just yield} -body {
+test coroutine-1.6 {just yield} -body {
coroutine foo [list yield]
list [foo] [catch foo msg] $msg
} -cleanup {
unset msg
} -result {{} 1 {invalid command name "foo"}}
-test unsupported-C.1.7 {yield in nested uplevel} -setup {
+test coroutine-1.7 {yield in nested uplevel} -setup {
set body {
# init
set i $start
@@ -552,7 +186,7 @@ test unsupported-C.1.7 {yield in nested uplevel} -setup {
unset body res
} -result {0 10 20}
-test unsupported-C.1.8 {yield in nested uplevel} -setup {
+test coroutine-1.8 {yield in nested uplevel} -setup {
set body {
# init
set i $start
@@ -576,7 +210,7 @@ test unsupported-C.1.8 {yield in nested uplevel} -setup {
unset body res
} -result {0 10 20}
-test unsupported-C.1.9 {yield in nested eval} -setup {
+test coroutine-1.9 {yield in nested eval} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
@@ -604,7 +238,7 @@ test unsupported-C.1.9 {yield in nested eval} -setup {
unset body res
} -result {0 10 20}
-test unsupported-C.1.10 {yield in nested eval} -setup {
+test coroutine-1.10 {yield in nested eval} -setup {
set body {
# init
set i $start
@@ -627,7 +261,7 @@ test unsupported-C.1.10 {yield in nested eval} -setup {
unset body res
} -result {0 10 20}
-test unsupported-C.1.11 {yield outside coroutine} -setup {
+test coroutine-1.11 {yield outside coroutine} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
@@ -640,7 +274,7 @@ test unsupported-C.1.11 {yield outside coroutine} -setup {
unset i stop
} -returnCodes error -result {yield can only be called in a coroutine}
-test unsupported-C.1.12 {proc as coroutine} -setup {
+test coroutine-1.12 {proc as coroutine} -setup {
set body {
# init
set i $start
@@ -662,37 +296,37 @@ test unsupported-C.1.12 {proc as coroutine} -setup {
rename foo {}
} -result {16 24}
-test unsupported-C.2.1 {self deletion on return} -body {
+test coroutine-2.1 {self deletion on return} -body {
coroutine foo set x 3
foo
} -returnCodes error -result {invalid command name "foo"}
-test unsupported-C.2.2 {self deletion on return} -body {
+test coroutine-2.2 {self deletion on return} -body {
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
list [foo] [foo] [catch foo msg] $msg
} -result {1 2 1 {invalid command name "foo"}}
-test unsupported-C.2.3 {self deletion on error return} -body {
+test coroutine-2.3 {self deletion on error return} -body {
coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
list [foo] [catch foo msg] $msg [catch foo msg] $msg
} -result {1 1 ouch! 1 {invalid command name "foo"}}
-test unsupported-C.2.4 {self deletion on other return} -body {
+test coroutine-2.4 {self deletion on other return} -body {
coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
list [foo] [catch foo msg] $msg [catch foo msg] $msg
} -result {1 100 ouch! 1 {invalid command name "foo"}}
-test unsupported-C.2.5 {deletion of suspended coroutine} -body {
+test coroutine-2.5 {deletion of suspended coroutine} -body {
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
list [foo] [rename foo {}] [catch foo msg] $msg
} -result {1 {} 1 {invalid command name "foo"}}
-test unsupported-C.2.6 {deletion of running coroutine} -body {
+test coroutine-2.6 {deletion of running coroutine} -body {
coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
list [foo] [catch foo msg] $msg
} -result {1 1 {invalid command name "foo"}}
-test unsupported-C.3.1 {info level computation} -setup {
+test coroutine-3.1 {info level computation} -setup {
proc a {} {while 1 {yield [info level]}}
proc b {} foo
} -body {
@@ -706,7 +340,7 @@ test unsupported-C.3.1 {info level computation} -setup {
rename b {}
} -result {1 1 1}
-test unsupported-C.3.2 {info frame computation} -setup {
+test coroutine-3.2 {info frame computation} -setup {
proc a {} {while 1 {yield [info frame]}}
proc b {} foo
} -body {
@@ -719,7 +353,7 @@ test unsupported-C.3.2 {info frame computation} -setup {
rename b {}
} -result 1
-test unsupported-C.3.3 {info coroutine} -setup {
+test coroutine-3.3 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} a
} -body {
@@ -729,7 +363,7 @@ test unsupported-C.3.3 {info coroutine} -setup {
rename b {}
} -result {}
-test unsupported-C.3.4 {info coroutine} -setup {
+test coroutine-3.4 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} a
} -body {
@@ -739,7 +373,7 @@ test unsupported-C.3.4 {info coroutine} -setup {
rename b {}
} -result ::foo
-test unsupported-C.3.5 {info coroutine} -setup {
+test coroutine-3.5 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} {rename [info coroutine] {}; a}
} -body {
@@ -750,7 +384,7 @@ test unsupported-C.3.5 {info coroutine} -setup {
} -result {}
-test unsupported-C.4.1 {bug #2093188} -setup {
+test coroutine-4.1 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
@@ -769,7 +403,7 @@ test unsupported-C.4.1 {bug #2093188} -setup {
unset ::res
} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
-test unsupported-C.4.2 {bug #2093188} -setup {
+test coroutine-4.2 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {read unset} bar
@@ -789,7 +423,7 @@ test unsupported-C.4.2 {bug #2093188} -setup {
unset ::res
} -result {{} 3 {{v {} read} {v {} unset}}}
-test unsupported-C.4.3 {bug #2093947} -setup {
+test coroutine-4.3 {bug #2093947} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
@@ -813,7 +447,7 @@ test unsupported-C.4.3 {bug #2093947} -setup {
unset ::res
} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
-test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelevels} \
+test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
-setup {
proc nestedYield {{val {}}} {
yield $val
@@ -856,7 +490,7 @@ test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelev
unset res
} -result {0 0 0 0 0 0}
-test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \
+test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
-setup {
proc nestedYield {{val {}}} {
yield $val
@@ -902,10 +536,6 @@ test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels
unset -nocomplain lambda
-if {[testConstraint atProcExit]} {
- namespace forget tcl::unsupported::atProcExit
-}
-
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
diff --git a/tests/tailcall.test b/tests/tailcall.test
new file mode 100644
index 0000000..a3cf88e
--- /dev/null
+++ b/tests/tailcall.test
@@ -0,0 +1,428 @@
+# Commands covered: tailcall
+#
+# This file contains a collection of tests for experimental commands that are
+# found in ::tcl::unsupported. The tests will migrate to normal test files
+# if/when the commands find their way into the core.
+#
+# Copyright (c) 2008 by Miguel Sofer.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tailcall.test,v 1.1 2009/03/19 23:31:37 msofer Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+testConstraint testnrelevels [llength [info commands testnrelevels]]
+
+#
+# The tests that risked blowing the C stack on failure have been removed: we
+# can now actually measure using testnrelevels.
+#
+
+if {[testConstraint testnrelevels]} {
+ namespace eval testnre {
+ #
+ # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
+ # cmdFrame level, callFrame level, tosPtr and callback depth
+ #
+ variable last [testnrelevels]
+ proc depthDiff {} {
+ variable last
+ set depth [testnrelevels]
+ set res {}
+ foreach t $depth l $last {
+ lappend res [expr {$t-$l}]
+ }
+ set last $depth
+ return $res
+ }
+ proc setabs {} {
+ uplevel 1 variable abs -[lindex [testnrelevels] 0]
+ }
+
+ variable body0 {
+ set x [depthDiff]
+ if {[incr i] > 10} {
+ variable abs
+ incr abs [lindex [testnrelevels] 0]
+ return [list [lrange $x 0 3] $abs]
+ }
+ }
+ proc makebody txt {
+ variable body0
+ return "$body0; $txt"
+ }
+ namespace export *
+ }
+ namespace import testnre::*
+}
+
+test tailcall-0 {tailcall is constant space} -constraints testnrelevels -setup {
+ proc a i {
+ if {[incr i] > 10} {
+ return [depthDiff]
+ }
+ depthDiff
+ tailcall a $i
+ }
+} -body {
+ a 0
+} -cleanup {
+ rename a {}
+} -result {0 0 0 0 0 0}
+
+test tailcall-1 {tailcall} -body {
+ namespace eval a {
+ variable x *::a
+ proc xset {} {
+ set tmp {}
+ set ns {[namespace current]}
+ set level [info level]
+ for {set i 0} {$i <= [info level]} {incr i} {
+ uplevel #$i "set x $i$ns"
+ lappend tmp "$i [info level $i]"
+ }
+ lrange $tmp 1 end
+ }
+ proc foo {} {tailcall xset; set x noreach}
+ }
+ namespace eval b {
+ variable x *::b
+ proc xset args {error b::xset}
+ proc moo {} {set x 0; variable y [::a::foo]; set x}
+ }
+ variable x *::
+ proc xset args {error ::xset}
+ list [::b::moo] | $x $a::x $b::x | $::b::y
+} -cleanup {
+ unset x
+ rename xset {}
+ namespace delete a b
+} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
+
+
+test tailcall-2 {tailcall in non-proc} -body {
+ namespace eval a [list tailcall set x 1]
+} -match glob -result *tailcall* -returnCodes error
+
+test tailcall-3 {tailcall falls off tebc} -body {
+ unset -nocomplain x
+ proc foo {} {tailcall set x 1}
+ list [catch foo msg] $msg [set x]
+} -cleanup {
+ rename foo {}
+ unset x
+} -result {0 1 1}
+
+test tailcall-4 {tailcall falls off tebc} -body {
+ set x 2
+ proc foo {} {tailcall set x 1}
+ foo
+ set x
+} -cleanup {
+ rename foo {}
+ unset x
+} -result 1
+
+test tailcall-5 {tailcall falls off tebc} -body {
+ set x 2
+ namespace eval bar {
+ variable x 3
+ proc foo {} {tailcall set x 1}
+ }
+ bar::foo
+ list $x $bar::x
+} -cleanup {
+ unset x
+ namespace delete bar
+} -result {1 3}
+
+test tailcall-6 {tailcall does remove callframes} -body {
+ proc foo {} {info level}
+ proc moo {} {tailcall foo}
+ proc boo {} {expr {[moo] - [info level]}}
+ boo
+} -cleanup {
+ rename foo {}
+ rename moo {}
+ rename boo {}
+} -result 1
+
+test tailcall-7 {tailcall does return} -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
+ }
+ }
+} -body {
+ namespace eval ::foo c
+} -cleanup {
+ namespace delete ::foo
+} -result cbabc
+
+test tailcall-8 {tailcall tailcall} -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
+ }
+ }
+} -body {
+ namespace eval ::foo c
+} -cleanup {
+ namespace delete ::foo
+} -match glob -result *tailcall* -returnCodes error
+
+test tailcall-9 {tailcall factorial} -setup {
+ proc fact {n {b 1}} {
+ if {$n == 1} {
+ return $b
+ }
+ tailcall fact [expr {$n-1}] [expr {$n*$b}]
+ }
+} -body {
+ list [fact 1] [fact 5] [fact 10] [fact 15]
+} -cleanup {
+ rename fact {}
+} -result {1 120 3628800 1307674368000}
+
+test tailcall-10 {tailcall and eval} -constraints {knownBug} -setup {
+ proc a {} {
+ eval [list tailcall lappend ::x 2]
+ set ::x 1
+ }
+} -body {
+ list [a] $::x
+} -cleanup {
+ unset -nocomplain ::x
+} -result {1 2}
+
+test tailcall-11 {tailcall and uplevel} -constraints {knownBug} -setup {
+ proc a {} {
+ uplevel 1 [list tailcall set ::x 2]
+ set ::x 1
+ }
+} -body {
+ list [a] $::x
+} -cleanup {
+ unset -nocomplain ::x
+} -result {1 2}
+
+# cleanup
+::tcltest::cleanupTests
+
+
+test tailcall-12.1 {[Bug 2649975]} -setup {
+ proc dump {{text {}}} {
+ set text [uplevel 1 [list subst $text]]
+ set l [expr {[info level] -1}]
+ if {$text eq {}} {
+ set text [info level $l]
+ }
+ puts "$l: $text"
+ }
+ # proc dump args {}
+ proc bravo {} {
+ upvar 1 v w
+ dump {inside bravo, v -> $w}
+ set v "procedure bravo"
+ #uplevel 1 [list delta ::betty]
+ uplevel 1 {delta ::betty}
+ return $::resolution
+ }
+ proc delta name {
+ upvar 1 v w
+ dump {inside delta, v -> $w}
+ set v "procedure delta"
+ tailcall foxtrot
+ }
+ proc foxtrot {} {
+ upvar 1 v w
+ dump {inside foxtrot, v -> $w}
+ global resolution
+ set ::resolution $w
+ }
+ set v "global level"
+} -body {
+ set result [bravo]
+ if {$result ne $v} {
+ puts "v should have been found at $v but was found in $result"
+ }
+} -cleanup {
+ unset v
+ rename dump {}
+ rename bravo {}
+ rename delta {}
+ rename foxtrot {}
+} -output {1: inside bravo, v -> global level
+1: inside delta, v -> global level
+1: inside foxtrot, v -> global level
+}
+
+test tailcall-12.2 {[Bug 2649975]} -setup {
+ proc dump {{text {}}} {
+ set text [uplevel 1 [list subst $text]]
+ set l [expr {[info level] -1}]
+ if {$text eq {}} {
+ set text [info level $l]
+ }
+ puts "$l: $text"
+ }
+ # proc dump args {}
+ set v "global level"
+ oo::class create foo { # like connection
+ method alpha {} { # like connections 'tables' method
+ dump
+ upvar 1 v w
+ dump {inside foo's alpha, v resolves to $w}
+ set v "foo's method alpha"
+ dump {foo's alpha is calling [self] bravo - v should resolve at global level}
+ set result [uplevel 1 [list [self] bravo]]
+ dump {exiting from foo's alpha}
+ return $result
+ }
+ method bravo {} { # like connections 'foreach' method
+ dump
+ upvar 1 v w
+ dump {inside foo's bravo, v resolves to $w}
+ set v "foo's method bravo"
+ dump {foo's bravo is calling charlie to create barney}
+ set barney [my charlie ::barney]
+ dump {foo's bravo is calling bravo on $barney}
+ dump {v should resolve at global scope there}
+ set result [uplevel 1 [list $barney bravo]]
+ dump {exiting from foo's bravo}
+ return $result
+ }
+ method charlie {name} { # like tdbc prepare
+ dump
+ set v "foo's method charlie"
+ dump {tailcalling bar's constructor}
+ tailcall ::bar create $name
+ }
+ }
+ oo::class create bar { # like statement
+ method bravo {} { # like statement foreach method
+ dump
+ upvar 1 v w
+ dump {inside bar's bravo, v is resolving to $w}
+ set v "bar's method bravo"
+ dump {calling delta to construct betty - v should resolve global there}
+ uplevel 1 [list [self] delta ::betty]
+ dump {exiting from bar's bravo}
+ return [::betty whathappened]
+ }
+ method delta {name} { # like statement execute method
+ dump
+ upvar 1 v w
+ dump {inside bar's delta, v is resolving to $w}
+ set v "bar's method delta"
+ dump {tailcalling to construct $name as instance of grill}
+ dump {v should resolve at global level in grill's constructor}
+ dump {grill's constructor should run at level [info level]}
+ tailcall grill create $name
+ }
+ }
+ oo::class create grill {
+ variable resolution
+ constructor {} {
+ dump
+ upvar 1 v w
+ dump "in grill's constructor, v resolves to $w"
+ set resolution $w
+ }
+ method whathappened {} {
+ return $resolution
+ }
+ }
+ foo create fred
+} -body {
+ set result [fred alpha]
+ if {$result ne "global level"} {
+ puts "v should have been found at global level but was found in $result"
+ }
+} -cleanup {
+ unset result
+ rename fred {}
+ rename dump {}
+ rename foo {}
+ rename bar {}
+ rename grill {}
+} -output {1: fred alpha
+1: inside foo's alpha, v resolves to global level
+1: foo's alpha is calling ::fred bravo - v should resolve at global level
+1: ::fred bravo
+1: inside foo's bravo, v resolves to global level
+1: foo's bravo is calling charlie to create barney
+2: my charlie ::barney
+2: tailcalling bar's constructor
+1: foo's bravo is calling bravo on ::barney
+1: v should resolve at global scope there
+1: ::barney bravo
+1: inside bar's bravo, v is resolving to global level
+1: calling delta to construct betty - v should resolve global there
+1: ::barney delta ::betty
+1: inside bar's delta, v is resolving to global level
+1: tailcalling to construct ::betty as instance of grill
+1: v should resolve at global level in grill's constructor
+1: grill's constructor should run at level 1
+1: grill create ::betty
+1: in grill's constructor, v resolves to global level
+1: exiting from bar's bravo
+1: exiting from foo's bravo
+1: exiting from foo's alpha
+}
+
+test tailcall-12.3 {[Bug 2695587]} -setup {
+ proc a {} {
+ list [catch {tailcall foo} msg] $msg
+ }
+} -body {
+ a
+} -cleanup {
+ rename a {}
+} -result {1 {Tailcall called from within a catch environment}}
+
+
+if {[testConstraint testnrelevels]} {
+ namespace forget testnre::*
+ namespace delete testnre
+}
+
+# cleanup
+::tcltest::cleanupTests
generated by cgit v0.12 at 2024-06-29 00:55:44 (GMT)