* generic/tclBasic.c: For compatibility with earlier Tcl releases,

        * generic/tclResult.c:  when a command procedure simply does a
        * generic/tclTest.c:    "return TCL_RETURN;" we must interpret that
        * tests/result.test:    the same as
        "return Tcl_SetReturnOptions(interp, Tcl_NewObj());"  [Bug 1209759].

5 files changed, 58 insertions, 4 deletions

diff --git a/ChangeLog b/ChangeLog
index 6dbbf82..28572fa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2005-06-01  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:	For compatibility with earlier Tcl releases,
+	* generic/tclResult.c:	when a command procedure simply does a
+	* generic/tclTest.c:	"return TCL_RETURN;" we must interpret that
+	* tests/result.test:	the same as
+	"return Tcl_SetReturnOptions(interp, Tcl_NewObj());"  [Bug 1209759].
+
 2005-06-01  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 144b2f7..bc1ff3d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,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.158 2005/05/30 00:04:45 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.159 2005/06/01 21:38:40 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -358,7 +358,7 @@ Tcl_CreateInterp()
     iPtr->errorCode = NULL;
     iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
     Tcl_IncrRefCount(iPtr->ecVar);
-    iPtr->returnLevel = 0;
+    iPtr->returnLevel = 1;
     iPtr->returnCode = TCL_OK;
 
     iPtr->appendResult = NULL;
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 770d7cb..1c4438d 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.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: tclResult.c,v 1.25 2005/05/10 18:34:48 kennykb Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.26 2005/06/01 21:38:41 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -927,6 +927,8 @@ Tcl_ResetResult(interp)
 	Tcl_DecrRefCount(iPtr->errorInfo);
 	iPtr->errorInfo = NULL;
     }
+    iPtr->returnLevel = 1;
+    iPtr->returnCode = TCL_OK;
     if (iPtr->returnOpts) {
 	Tcl_DecrRefCount(iPtr->returnOpts);
 	iPtr->returnOpts = NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 22859a7..974112c 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.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: tclTest.c,v 1.90 2005/05/14 20:46:46 das Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.91 2005/06/01 21:38:42 dgp Exp $
  */
 
 #define TCL_TEST
@@ -309,6 +309,9 @@ static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
 static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]));
+static int		TestreturnObjCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[]));
 static void		TestregexpXflags _ANSI_ARGS_((char *string,
 			    int length, int *cflagsPtr, int *eflagsPtr));
 static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
@@ -664,6 +667,8 @@ Tcltest_Init(interp)
 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
@@ -3615,6 +3620,37 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * TestreturnObjCmd --
+ *
+ *	This procedure implements the "testreturn" command. It is
+ *	used to verify that a
+ *		return TCL_RETURN;
+ *	has same behavior as
+ *		return Tcl_SetReturnOptions(interp, Tcl_NewObj());
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static int
+TestreturnObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int objc;				/* Number of arguments. */
+    Tcl_Obj *CONST objv[];		/* Argument objects. */
+{
+    return TCL_RETURN;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestsetassocdataCmd --
  *
  *	This procedure implements the "testsetassocdata" command. It is used
diff --git a/tests/result.test b/tests/result.test
index 92f8d41..a1ee0b7 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -109,6 +109,14 @@ test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode {
     set errorCode
 } {{a b} c}
 
+::tcltest::testConstraint testreturn \
+	[expr {[info commands testreturn] != {}}]
+test result-6.0 {Bug 1209759} testreturn {
+    # Might panic if bug is not fixed.
+    proc foo {} {testreturn}
+    foo
+}
+
 # cleanup
 ::tcltest::cleanupTests
 return