summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclCompCmds.c16
-rw-r--r--tests/compile.test34
3 files changed, 55 insertions, 3 deletions
diff --git a/ChangeLog b/ChangeLog
index fe642f7..e645349 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2003-01-07 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCompCmds.c (TclCompileReturnCmd):
+ * tests/compile.test: Corrects failure of bytecompiled
+ [catch {return}] to have result TCL_RETURN (not TCL_OK) [Bug 633204].
+ This patch is a workaround for 8.4.X. A new opcode INST_RETURN is a
+ better long term solution for 8.5 and later.
+
2003-01-04 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc:
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c261ba9..a188a0b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.35 2002/11/14 00:56:43 hobbs Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.36 2003/01/08 00:34:58 dgp Exp $
*/
#include "tclInt.h"
@@ -2393,6 +2393,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
{
Tcl_Token *varTokenPtr;
int code;
+ int index = envPtr->exceptArrayNext;
/*
* If we're not in a procedure, don't compile.
@@ -2402,6 +2403,19 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
return TCL_OUT_LINE_COMPILE;
}
+ /*
+ * If there's an enclosing [catch], don't compile.
+ */
+
+ while (index >= 0) {
+ ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[index]);
+ if ((rangePtr->type == CATCH_EXCEPTION_RANGE)
+ && (rangePtr->catchOffset == -1)) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ index--;
+ }
+
switch (parsePtr->numWords) {
case 1: {
/*
diff --git a/tests/compile.test b/tests/compile.test
index f3c1a08..e31da81 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: compile.test,v 1.23 2002/08/26 17:38:54 msofer Exp $
+# RCS: @(#) $Id: compile.test,v 1.24 2003/01/08 00:34:59 dgp Exp $
package require tcltest 2
namespace import -force ::tcltest::*
@@ -331,7 +331,37 @@ test compile-14.1 {testing errors in element name; segfault?} {} {
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
-
+# Next 4 tests cover Tcl Bug 633204
+test compile-15.1 {proper TCL_RETURN code from [return]} {
+ proc p {} {catch return}
+ set result [p]
+ rename p {}
+ set result
+} 2
+test compile-15.2 {proper TCL_RETURN code from [return]} {
+ proc p {} {catch {return foo}}
+ set result [p]
+ rename p {}
+ set result
+} 2
+test compile-15.3 {proper TCL_RETURN code from [return]} {
+ proc p {} {catch {return $::tcl_library}}
+ set result [p]
+ rename p {}
+ set result
+} 2
+test compile-15.4 {proper TCL_RETURN code from [return]} {
+ proc p {} {catch {return [info library]}}
+ set result [p]
+ rename p {}
+ set result
+} 2
+test compile-15.5 {proper TCL_RETURN code from [return]} {
+ proc p {} {catch {set a 1}; return}
+ set result [p]
+ rename p {}
+ set result
+} ""
# cleanup