From 334db97a72461fd68bc9574ff8f6fc628cd40650 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 18 Mar 2010 14:35:03 +0000
Subject: Fix silly error in bytecode generation for [try].

---
 ChangeLog               |  3 ++-
 generic/tclCompCmdsSZ.c |  4 +++-
 tests/error.test        | 61 ++++++++++++++++++++++++++++++++++++++++++++-----
 3 files changed, 60 insertions(+), 8 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index fc4cc6f..979c569 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,7 +3,8 @@
 	* generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions):
 	[Bug 2971921]: Corrected jump so that it doesn't skip into the middle
 	of an instruction! Tightened the instruction issuing. Moved endCatch
-	calls closer to their point that they guard.
+	calls closer to their point that they guard, ensuring correct ordering
+	of result values.
 
 2010-03-17  Andreas Kupries  <andreask@activestate.com>
 
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b55367c..25ff92a 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.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: tclCompCmdsSZ.c,v 1.3 2010/03/18 10:59:48 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.4 2010/03/18 14:35:04 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -2077,6 +2077,7 @@ IssueTryInstructions(
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
     PUSH(				"0");
+    OP4(				REVERSE, 2);
     OP1(				JUMP1, 4);
     ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RETURN_CODE);
@@ -2224,6 +2225,7 @@ IssueTryFinallyInstructions(
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
     PUSH(				"0");
+    OP4(				REVERSE, 2);
     OP1(				JUMP1, 4);
     ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RETURN_CODE);
diff --git a/tests/error.test b/tests/error.test
index 86e52c2..95cd4c2 100644
--- a/tests/error.test
+++ b/tests/error.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: error.test,v 1.26 2010/03/18 10:59:48 dkf Exp $
+# RCS: @(#) $Id: error.test,v 1.27 2010/03/18 14:35:04 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -803,11 +803,11 @@ test error-19.5 {multiple unrelated fallthroughs #2} {
     } 
     set RES
 } {err}
+proc addmsg msg {
+    variable RES
+    lappend RES $msg
+}
 test error-19.6 {compiled try executes all clauses} -setup {
-    proc addmsg msg {
-	variable RES
-	lappend RES $msg
-    }
     set RES {}
 } -body {
     apply {{} {
@@ -822,9 +822,58 @@ test error-19.6 {compiled try executes all clauses} -setup {
 	addmsg d
     } ::tcl::test::error}
 } -cleanup {
-    rename addmsg {}
     unset RES
 } -result {a b c d}
+test error-19.7 {compiled try executes all clauses} -setup {
+    set RES {}
+} -body {
+    apply {{} {
+	try {
+	    addmsg a
+	} on error {res opt} {
+	    addmsg b
+	} on ok {} {
+	    addmsg c
+	} finally {
+	    addmsg d
+	}
+	addmsg e
+    } ::tcl::test::error}
+} -cleanup {
+    unset RES
+} -result {a c d e}
+test error-19.8 {compiled try executes all clauses} -setup {
+    set RES {}
+} -body {
+    apply {{} {
+	try {
+	    addmsg a
+	    throw bar hello
+	} trap bar {res opt} {
+	    addmsg b
+	}
+	addmsg c
+    } ::tcl::test::error}
+} -cleanup {
+    unset RES
+} -result {a b c}
+test error-19.9 {compiled try executes all clauses} -setup {
+    set RES {}
+} -body {
+    apply {{} {
+	try {
+	    addmsg a
+	} on error {res opt} {
+	    addmsg b
+	} on ok {} {
+	    addmsg c
+	}
+	addmsg d
+    } ::tcl::test::error}
+} -cleanup {
+    unset RES
+} -result {a c d}
+rename addmsg {}
 
 # FIXME test what vars get set on fallthough ... what is the correct behavior?
 # It would seem appropriate to set at least those for the matching handler and
-- 
cgit v0.12