diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclBasic.c | 56 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 16 | ||||
| -rw-r--r-- | generic/tclExecute.c | 31 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | tests/tailcall.test | 16 |
6 files changed, 99 insertions, 34 deletions
@@ -1,5 +1,13 @@ 2009-03-21 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: Fix for (among others) [Bug 2699087] + * generic/tclCmdAH.c: Tailcalls now perform properly even from + * generic/tclExecute.c: within [eval]ed scripts. + * generic/tclInt.h: More tests missing, as well as proper + exploration and testing of the interaction with "redirectors" like + interp-alias (suspect that it does not happen in constant space) + and pure-eval commands. + * generic/tclExecute.c: proper fix for [Bug 2415422]. Reenabled * tests/nre.test: the failing assertion that was disabled on 2008-12-18: the assertion is correct, the fault was in the diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 739732f..c40cd49 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.388 2009/03/19 23:31:37 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.389 2009/03/21 09:42:06 msofer Exp $ */ #include "tclInt.h" @@ -7988,8 +7988,9 @@ TclNRTailcallObjCmd( { Interp *iPtr = (Interp *) interp; TEOV_callback *tailcallPtr; - Tcl_Obj *listPtr; - Namespace *nsPtr = iPtr->varFramePtr->nsPtr; + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); @@ -8004,10 +8005,16 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - nsPtr->activationCount++; listPtr = Tcl_NewListObj(objc-1, objv+1); Tcl_IncrRefCount(listPtr); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("Tailcall failed to find the proper namespace"); + } + Tcl_IncrRefCount(nsObjPtr); + /* * Add two callbacks: first the one to actually evaluate the tailcalled * command, then the one that signals TEBC to stash the first at its @@ -8017,7 +8024,7 @@ TclNRTailcallObjCmd( * TclNRAddCallBack macro to build the callback) */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); + TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); tailcallPtr = TOP_CB(interp); TOP_CB(interp) = tailcallPtr->nextPtr; @@ -8033,27 +8040,19 @@ NRTailcallEval( { Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; - Namespace *nsPtr = data[1]; - int omit = PTR2INT(data[2]); + Tcl_Obj *nsObjPtr = data[1]; + Tcl_Namespace *nsPtr; int objc; Tcl_Obj **objv; - 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); - } - - nsPtr->activationCount--; - if ((nsPtr->flags & NS_DYING) - && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { - /* - * FIXME NRE tailcall: is this the proper way to manage this? This is - * like what CallFrames do. - */ - - Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL, NULL); + if (result == TCL_OK) { + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result == TCL_OK) { + iPtr->lookupNsPtr = (Namespace *) nsPtr; + ListObjGetElements(listPtr, objc, objv); + result = TclNREvalObjv(interp, objc, objv, 0, NULL); + } } return result; } @@ -8065,8 +8064,19 @@ TailcallCleanup( int result) { Tcl_DecrRefCount((Tcl_Obj *) data[0]); + Tcl_DecrRefCount((Tcl_Obj *) data[1]); return result; } + +void +TclClearTailcall( + Tcl_Interp *interp, + TEOV_callback *tailcallPtr) +{ + TailcallCleanup(tailcallPtr->data, interp, TCL_OK); + TCLNR_FREE(interp, tailcallPtr); +} + void Tcl_NRAddCallback( diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c8829f8..a00fff8 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.115 2009/02/03 23:34:33 nijtmans Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.116 2009/03/21 09:42:06 msofer Exp $ */ #include "tclInt.h" @@ -302,12 +302,26 @@ CatchObjCmdCallback( Tcl_Interp *interp, int result) { + Interp *iPtr = (Interp *) interp; int objc = PTR2INT(data[0]); Tcl_Obj *varNamePtr = data[1]; Tcl_Obj *optionVarNamePtr = data[2]; int rewind = ((Interp *) interp)->execEnvPtr->rewind; /* + * catch has to disable any tailcall + */ + + if (iPtr->varFramePtr->tailcallPtr) { + TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; + result = TCL_ERROR; + Tcl_SetResult(interp,"Tailcall called from within a catch environment", + TCL_STATIC); + } + + + /* * We disable catch in interpreters where the limit has been exceeded. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 99bf84e..b00848a 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.432 2009/03/21 06:55:31 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.433 2009/03/21 09:42:07 msofer Exp $ */ #include "tclInt.h" @@ -1871,18 +1871,15 @@ TclExecuteByteCode( fprintf(stdout, " Tailcall request received\n"); } #endif - TEOV_callback *tailcallPtr = param; - - iPtr->varFramePtr->tailcallPtr = tailcallPtr; - if (catchTop != initCatchTop) { - tailcallPtr->data[2] = INT2PTR(1); + TclClearTailcall(interp, param); result = TCL_ERROR; Tcl_SetResult(interp,"Tailcall called from within a catch environment", TCL_STATIC); pc--; goto checkForCatch; } + iPtr->varFramePtr->tailcallPtr = param; goto abnormalReturn; } case TCL_NR_YIELD_TYPE: { /*[yield] */ @@ -1995,6 +1992,15 @@ TclExecuteByteCode( */ if (iPtr->varFramePtr->tailcallPtr) { + if (catchTop != initCatchTop) { + TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; + result = TCL_ERROR; + Tcl_SetResult(interp,"Tailcall called from within a catch environment", + TCL_STATIC); + pc--; + goto checkForCatch; + } goto abnormalReturn; } @@ -7759,6 +7765,19 @@ TclExecuteByteCode( abnormalReturn: TCL_DTRACE_INST_LAST(); + + /* + * Winding down: insure that all pending cleanups are done before + * dropping out of this bytecode. + */ + if (TOP_CB(interp) != bottomPtr->rootPtr) { + result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1); + + if (TOP_CB(interp) != bottomPtr->rootPtr) { + Tcl_Panic("Abnormal return with busy callback stack"); + } + } + /* * Clear all expansions and same-level NR calls. * diff --git a/generic/tclInt.h b/generic/tclInt.h index 48473bd..3c45cc1 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.419 2009/03/19 23:31:37 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.420 2009/03/21 09:42:07 msofer Exp $ */ #ifndef _TCLINT @@ -2603,6 +2603,10 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; +MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp, + struct TEOV_callback *tailcallPtr); + + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: diff --git a/tests/tailcall.test b/tests/tailcall.test index fb6d662..4cfbebf 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.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: tailcall.test,v 1.3 2009/03/21 03:43:53 msofer Exp $ +# RCS: @(#) $Id: tailcall.test,v 1.4 2009/03/21 09:42:07 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -221,7 +221,7 @@ test tailcall-9 {tailcall factorial} -setup { rename fact {} } -result {1 120 3628800 1307674368000} -test tailcall-10a {tailcall and eval} -constraints {knownBug} -setup { +test tailcall-10a {tailcall and eval} -setup { set ::x 0 proc a {} { eval [list tailcall lappend ::x 2] @@ -432,7 +432,17 @@ test tailcall-12.2 {[Bug 2649975]} -setup { 1: exiting from foo's alpha } -test tailcall-12.3 {[Bug 2695587]} -setup { +test tailcall-12.3a {[Bug 2695587]} -setup { + proc a {} { + list [catch [list tailcall foo] msg] $msg + } +} -body { + a +} -cleanup { + rename a {} +} -result {1 {Tailcall called from within a catch environment}} + +test tailcall-12.3b {[Bug 2695587]} -setup { proc a {} { list [catch {tailcall foo} msg] $msg } |