From 03601b802956fa8a856e342f3035467c41af3f4c Mon Sep 17 00:00:00 2001
From: dgp <dgp@noemail.net>
Date: Wed, 11 Dec 2002 21:29:52 +0000
Subject:         * generic/tclProc.c (ProcessProcResultCode): Fix failure to  
         propagate negative return codes up the call stack. [Bug 647307]      
   * tests/proc.test (proc-6.1): Test for Bug 647307

FossilOrigin-Name: b05c44bcd8dde75542e336a80a312d744070a0a8
---
 ChangeLog         |  4 ++++
 generic/tclProc.c |  4 ++--
 tests/proc.test   | 11 ++++++++++-
 3 files changed, 16 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ee98999..9d115ec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2002-12-11  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclProc.c (ProcessProcResultCode): Fix failure to
+	  propagate negative return codes up the call stack. [Bug 647307]
+	* tests/proc.test (proc-6.1): Test for Bug 647307
+
 	* generic/tclParseExpr.c (TclParseInteger):  Return 1 for the
 	string "0x" (recognize leading "0" as an integer).  [Bug 648441].
 	* tests/parseExpr.test (parseExpr-19.1): Test for Bug 648441.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 5b4108c..4e3d4b8 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.43 2002/10/02 01:36:29 hobbs Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.44 2002/12/11 21:29:52 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1297,7 +1297,7 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
     if (returnCode == TCL_OK) {
 	return TCL_OK;
     }
-    if (returnCode > TCL_CONTINUE) {
+    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
 	return returnCode;
     }
     if (returnCode == TCL_RETURN) {
diff --git a/tests/proc.test b/tests/proc.test
index a982d78..ce07e88 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: proc.test,v 1.10 2001/09/10 17:04:10 msofer Exp $
+# RCS: @(#) $Id: proc.test,v 1.11 2002/12/11 21:29:52 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -316,6 +316,15 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
     set result
 } {aba}    
 
+test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
+    proc a {} {return -code -5}
+    proc b {} a
+    set result [catch b]
+    rename a {}
+    rename b {}
+    set result
+} -5
+
 # cleanup
 catch {rename p ""}
 catch {rename t ""}
-- 
cgit v0.12