From ae5d02d6bc12e614899a7770ab82ef0dd72b0255 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 8 Jan 2003 00:34:58 +0000
Subject:         * 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.

---
 ChangeLog             |  8 ++++++++
 generic/tclCompCmds.c | 16 +++++++++++++++-
 tests/compile.test    | 34 ++++++++++++++++++++++++++++++++--
 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
-- 
cgit v0.12