diff options
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | generic/tclOO.c | 3 | ||||
| -rw-r--r-- | tests/oo.test | 17 |
4 files changed, 27 insertions, 6 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 41e3824..264fdc8 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.393 2009/05/08 01:02:26 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.394 2009/05/08 08:48:19 dkf Exp $ */ #include "tclInt.h" @@ -4200,6 +4200,14 @@ TclNREvalObjv( return TCL_OK; } +void +TclPushTailcallPoint( + Tcl_Interp *interp) +{ + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + ((Interp *) interp)->numLevels++; +} + int TclNRRunCallbacks( Tcl_Interp *interp, diff --git a/generic/tclInt.h b/generic/tclInt.h index 3028ff1..9562d6b 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.422 2009/03/21 12:24:49 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.423 2009/05/08 08:48:19 dkf Exp $ */ #ifndef _TCLINT @@ -2614,6 +2614,7 @@ MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp, MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); +MODULE_SCOPE void TclPushTailcallPoint(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/tclOO.c b/generic/tclOO.c index 6e476e9..1ba0ba8 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOO.c,v 1.21 2009/05/05 15:47:45 dkf Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.22 2009/05/08 08:48:19 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -1443,6 +1443,7 @@ TclNRNewObjectInstance( TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); + TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } diff --git a/tests/oo.test b/tests/oo.test index 6b81f37..c8957b3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.25 2009/04/11 11:18:51 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.26 2009/05/08 08:48:19 dkf Exp $ package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -278,10 +278,21 @@ test oo-2.5 {OO constructor - Bug 2531577} -setup { } -cleanup { foo destroy } -result {1 1} +test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup { + oo::class create foo +} -body { + oo::define foo { + constructor {} { tailcall my bar } + method bar {} { return bad } + } + namespace tail [foo create good] +} -cleanup { + foo destroy +} -result good test oo-3.1 {basic test of OO functionality: destructor} -setup { - # This is a bit complex because it needs to run in a sub-interp as - # we're modifying the root object class's constructor + # This is a bit complex because it needs to run in a sub-interp as we're + # modifying the root object class's constructor interp create subinterp initInterpreter subinterp subinterp eval { |