Tcl Source Code

Artifact 9956c90445894cfbe299319819a07915ceee8567:

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	17 Dec 2002 23:13:35 -0000
@@ -2453,11 +2453,11 @@
     }
 
     /*
-     * The INST_DONE opcode actually causes the branching out of the
+     * The INST_RETURN opcode triggers the branching out of the
      * subroutine, and takes the top stack item as the return result
      * (which is why we pushed the value above).
      */
-    TclEmitOpcode(INST_DONE, envPtr);
+    TclEmitOpcode(INST_RETURN, envPtr);
     return TCL_OK;
 }
 
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.41
diff -u -r1.41 tclCompile.c
--- generic/tclCompile.c	24 Sep 2002 12:53:33 -0000	1.41
+++ generic/tclCompile.c	17 Dec 2002 23:13:35 -0000
@@ -269,6 +269,8 @@
 	 * stacked objs: stktop is old value, next is new element value, next 
 	 * come (operand-2) indices; pushes the new value.
 	 */
+    {"return",		  1,   -1,          0,   {OPERAND_NONE}},
+	/* return TCL_RETURN code. */
     {0}
 };
 
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.33
diff -u -r1.33 tclCompile.h
--- generic/tclCompile.h	9 Oct 2002 11:54:05 -0000	1.33
+++ generic/tclCompile.h	17 Dec 2002 23:13:35 -0000
@@ -522,8 +522,10 @@
 #define INST_LSET_LIST			96
 #define INST_LSET_FLAT                  97
 
+#define INST_RETURN			98
+
 /* The last opcode */
-#define LAST_INST_OPCODE        	97
+#define LAST_INST_OPCODE        	98
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.90
diff -u -r1.90 tclExecute.c
--- generic/tclExecute.c	12 Nov 2002 02:25:48 -0000	1.90
+++ generic/tclExecute.c	17 Dec 2002 23:13:36 -0000
@@ -1234,6 +1234,8 @@
     iPtr->stats.instructionCount[*pc]++;
 #endif
     switch (*pc) {
+    case INST_RETURN:
+	result = TCL_RETURN;
     case INST_DONE:
 	if (stackTop <= initStackTop) {
 	    stackTop--;
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	17 Dec 2002 23:13:37 -0000
@@ -331,7 +331,31 @@
      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
 
 
 # cleanup