Tcl Source Code

Artifact 422a3712b8e6d935c1b99a5f321b068fe9ec8bd2:

Attachment "workaround.patch" to ticket [633204ffff] added by dgp 2002-12-19 06:56:14.

---

Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.35
diff -u -r1.35 tclCompCmds.c
--- generic/tclCompCmds.c	14 Nov 2002 00:56:43 -0000	1.35
+++ generic/tclCompCmds.c	18 Dec 2002 23:54:19 -0000
@@ -2393,6 +2393,7 @@
 {
     Tcl_Token *varTokenPtr;
     int code;
+    int index = envPtr->exceptArrayNext;
 
     /*
      * If we're not in a procedure, don't compile.
@@ -2400,6 +2401,19 @@
 
     if (envPtr->procPtr == NULL) {
 	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) {
Index: tests/compile.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/compile.test,v
retrieving revision 1.23
diff -u -r1.23 compile.test
--- tests/compile.test	26 Aug 2002 17:38:54 -0000	1.23
+++ tests/compile.test	18 Dec 2002 23:54:20 -0000
@@ -331,7 +331,37 @@
      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