summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-05-08 08:48:19 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-05-08 08:48:19 (GMT)
commit8e841a82ee24a19f46b5242cc2a989361da94dd9 (patch)
tree02c103233e67d5211073223af43b8ae52e97efdc
parent0aacbdde5731d13b37f89453b2c72c1ff5250a51 (diff)
downloadtcl-8e841a82ee24a19f46b5242cc2a989361da94dd9.zip
tcl-8e841a82ee24a19f46b5242cc2a989361da94dd9.tar.gz
tcl-8e841a82ee24a19f46b5242cc2a989361da94dd9.tar.bz2
Fix [Bug 2414858].
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclOO.c3
-rw-r--r--tests/oo.test17
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 {