summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2005-06-01 21:38:34 (GMT)
committerdgp <dgp@users.sourceforge.net>2005-06-01 21:38:34 (GMT)
commit9fb09ab047419f92eea30d3b4dc0a3a6b83f58b0 (patch)
treef64716a58409f5582716350a70767ed3630c9cc7
parent854f85bb1700aa6f106cc6a443cb0eb2e917f2de (diff)
downloadtcl-9fb09ab047419f92eea30d3b4dc0a3a6b83f58b0.zip
tcl-9fb09ab047419f92eea30d3b4dc0a3a6b83f58b0.tar.gz
tcl-9fb09ab047419f92eea30d3b4dc0a3a6b83f58b0.tar.bz2
* 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].
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclResult.c4
-rw-r--r--generic/tclTest.c38
-rw-r--r--tests/result.test8
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