diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 13 | ||||
| -rw-r--r-- | generic/tclCompile.h | 3 | ||||
| -rw-r--r-- | generic/tclExecute.c | 99 |
3 files changed, 64 insertions, 51 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1133c4c..b1ceab7 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.351 2008/08/07 04:13:50 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.352 2008/08/09 22:20:56 msofer Exp $ */ #include "tclInt.h" @@ -777,9 +777,11 @@ Tcl_CreateInterp(void) */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::atProcExit", - /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(0), NULL); + /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_ATEXIT_TYPE), + NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::tailcall", - /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(1), NULL); + /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_TAILCALL_TYPE), + NULL); #ifdef USE_DTRACE /* @@ -4274,6 +4276,7 @@ NRCallTEBC( case TCL_NR_BC_TYPE: return TclExecuteByteCode(interp, data[1]); case TCL_NR_ATEXIT_TYPE: + case TCL_NR_TAILCALL_TYPE: /* For atProcExit and tailcalls */ Tcl_SetResult(interp, "atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC); @@ -7880,9 +7883,7 @@ TclNRAtProcExitObjCmd( */ TclNRAddCallback(interp, NRAtProcExitEval, listPtr, nsPtr, NULL, NULL); - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_ATEXIT_TYPE), clientData, - NULL, NULL); - + TclNRAddCallback(interp, NRCallTEBC, clientData, NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1653ea5..53a2c95 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.101 2008/08/04 14:09:31 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.102 2008/08/09 22:20:56 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -841,6 +841,7 @@ MODULE_SCOPE Tcl_NRPostProc NRCallTEBC; #define TCL_NR_BC_TYPE 0 #define TCL_NR_ATEXIT_TYPE 1 +#define TCL_NR_TAILCALL_TYPE 2 /* *---------------------------------------------------------------- diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f9d8bae..d2c656e 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.402 2008/08/09 00:13:36 das Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.403 2008/08/09 22:20:57 msofer Exp $ */ #include "tclInt.h" @@ -1844,27 +1844,26 @@ TclExecuteByteCode( NR_DATA_BURY(); - if (type == TCL_NR_BC_TYPE) { - /* - * A request to run a bytecode: record this level's state - * variables, swap codePtr and start running the new one. - */ - - NR_DATA_BURY(); - codePtr = param; - } else if (type == TCL_NR_ATEXIT_TYPE) { - /* - * 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 *newPtr = TOP_CB(interp); - - TOP_CB(interp) = newPtr->nextPtr; + switch (type) { + case TCL_NR_BC_TYPE: + /* + * A request to run a bytecode: record this level's state + * variables, swap codePtr and start running the new one. + */ + + NR_DATA_BURY(); + codePtr = param; + break; + case TCL_NR_ATEXIT_TYPE: { + /* + * A request to perform a command at exit: put it in the stack + * and continue eexec'ing the current bytecode + */ + + TEOV_callback *newPtr = TOP_CB(interp); - isTailcall = PTR2INT(param); - if (!isTailcall) { + TOP_CB(interp) = newPtr->nextPtr; + #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " atProcExit request received\n"); @@ -1877,8 +1876,17 @@ TclExecuteByteCode( Tcl_DecrRefCount(objPtr); } goto nonRecursiveCallReturn; - } else { - + } + 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. + */ + + 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"); @@ -1891,7 +1899,7 @@ TclExecuteByteCode( TCL_STATIC); goto checkForCatch; } - + newPtr->nextPtr = NULL; if (!bottomPtr->atExitPtr) { newPtr->nextPtr = NULL; @@ -1900,9 +1908,9 @@ TclExecuteByteCode( /* * There are already atExit callbacks: run last. */ - + TEOV_callback *tmpPtr = bottomPtr->atExitPtr; - + while (tmpPtr->nextPtr) { tmpPtr = tmpPtr->nextPtr; } @@ -1910,8 +1918,8 @@ TclExecuteByteCode( } goto abnormalReturn; } - } else { - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); + default: + Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); } } nested = 1; @@ -7800,24 +7808,27 @@ TclExecuteByteCode( NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC); NRE_ASSERT(result == TCL_OK); - if (type == TCL_NR_BC_TYPE) { - /* - * One of the callbacks requested a new execution: a tailcall! - * Start the new bytecode. - */ - - goto nonRecursiveCallStart; - } else if (type == TCL_NR_ATEXIT_TYPE) { - TOP_CB(iPtr) = callbackPtr->nextPtr; - TCLNR_FREE(interp, callbackPtr); - - Tcl_SetResult(interp, - "atProcExit/tailcall cannot be invoked recursively", TCL_STATIC); - result = TCL_ERROR; - goto rerunCallbacks; + switch (type) { + case TCL_NR_BC_TYPE: + /* + * One of the callbacks requested a new execution: a tailcall! + * Start the new bytecode. + */ + + goto nonRecursiveCallStart; + case TCL_NR_ATEXIT_TYPE: + case TCL_NR_TAILCALL_TYPE: + TOP_CB(iPtr) = callbackPtr->nextPtr; + TCLNR_FREE(interp, callbackPtr); + + Tcl_SetResult(interp, + "atProcExit/tailcall cannot be invoked recursively", TCL_STATIC); + result = TCL_ERROR; + goto rerunCallbacks; + default: + Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); } } - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); } |