From 8e841a82ee24a19f46b5242cc2a989361da94dd9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 8 May 2009 08:48:19 +0000
Subject: Fix [Bug 2414858].

---
 generic/tclBasic.c | 10 +++++++++-
 generic/tclInt.h   |  3 ++-
 generic/tclOO.c    |  3 ++-
 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 {
-- 
cgit v0.12