diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclResult.c | 4 | ||||
| -rw-r--r-- | generic/tclTest.c | 38 | ||||
| -rw-r--r-- | tests/result.test | 8 |
5 files changed, 58 insertions, 4 deletions
@@ -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 |