From 245ab4ae255929317069b92446f66b83c901b8f8 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sun, 3 Aug 2008 17:33:10 +0000 Subject: * 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: --- generic/tclBasic.c | 69 ++++++------------ generic/tclCompile.h | 6 +- generic/tclExecute.c | 192 +++++++++++++++++++++++++++++++++++++------------ generic/tclInt.h | 9 ++- generic/tclInterp.c | 7 +- generic/tclNamesp.c | 8 +-- tests/unsupported.test | 168 ++++++++++++++++++++++++++++++++++++++++--- 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::* -- cgit v0.12