From ce77e262200ad395011337df26e7e52292d83c17 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Mon, 15 Apr 2002 17:45:06 +0000
Subject: Improved stack trace for TCL_BREAK and TCL_CONTINUE returns from
 procs. [Bug 536955].

---
 ChangeLog           |  7 +++++++
 generic/tclProc.c   | 47 +++++++++++++++++++++++------------------------
 tests/proc-old.test |  8 +++++---
 3 files changed, 35 insertions(+), 27 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ccb3db4..c3efeb3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,12 @@
 2002-04-15  Miguel Sofer  <msofer@users.sourceforge.net>
 
+	* generic/tclProc.c:
+	* tests/proc-old.test: Improved stack trace for TCL_BREAK and
+	TCL_CONTINUE returns from procs. Patch by Don Porter
+	[Bug 536955]. 
+	
+2002-04-15  Miguel Sofer  <msofer@users.sourceforge.net>
+
 	* generic/tclExecute.c:
 	* tests/compile.test: made bytecodes check for a catch before
 	returning; the compiled [return] is otherwise non-catchable. 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index f1e7510..446bf09 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.36 2002/01/25 20:40:55 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.37 2002/04/15 17:45:06 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1283,33 +1283,32 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
     int returnCode;		/* The unexpected result code. */
 {
     Interp *iPtr = (Interp *) interp;
+    char msg[100 + TCL_INTEGER_SPACE];
+    char *ellipsis = "";
 
+    if (returnCode == TCL_OK) {
+	return TCL_OK;
+    }
+    if (returnCode > TCL_CONTINUE) {
+	return returnCode;
+    }
     if (returnCode == TCL_RETURN) {
-	returnCode = TclUpdateReturnInfo(iPtr);
-    } else if (returnCode == TCL_ERROR) {
-	char msg[100 + TCL_INTEGER_SPACE];
-	char *ellipsis = "";
-	int numChars = nameLen;
-
-	if (numChars > 60) {
-	    numChars = 60;
-	    ellipsis = "...";
-	}
-	sprintf(msg, "\n    (procedure \"%.*s%s\" line %d)",
-		numChars, procName, ellipsis, iPtr->errorLine);
-	Tcl_AddObjErrorInfo(interp, msg, -1);
-    } else if (returnCode == TCL_BREAK) {
+	return TclUpdateReturnInfo(iPtr);
+    } 
+    if (returnCode != TCL_ERROR) {
 	Tcl_ResetResult(interp);
-	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		"invoked \"break\" outside of a loop", -1);
-	returnCode = TCL_ERROR;
-    } else if (returnCode == TCL_CONTINUE) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-	        "invoked \"continue\" outside of a loop", -1);
-	returnCode = TCL_ERROR;
+	Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) 
+		? "invoked \"break\" outside of a loop"
+		: "invoked \"continue\" outside of a loop"), -1);
+    }
+    if (nameLen > 60) {
+	nameLen = 60;
+	ellipsis = "...";
     }
-    return returnCode;
+    sprintf(msg, "\n    (procedure \"%.*s%s\" line %d)", nameLen, procName,
+	    ellipsis, iPtr->errorLine);
+    Tcl_AddObjErrorInfo(interp, msg, -1);
+    return TCL_ERROR;
 }
 
 /*
diff --git a/tests/proc-old.test b/tests/proc-old.test
index e4dae6a..44b55a4 100644
--- a/tests/proc-old.test
+++ b/tests/proc-old.test
@@ -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: proc-old.test,v 1.8 2001/07/31 19:12:07 vincentdarley Exp $
+# RCS: @(#) $Id: proc-old.test,v 1.9 2002/04/15 17:45:06 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -332,7 +332,8 @@ test proc-old-5.14 {error conditions} {
     catch tproc msg
     set errorInfo
 } {invoked "break" outside of a loop
-    while executing
+    (procedure "tproc" line 1)
+    invoked from within
 "tproc"}
 test proc-old-5.15 {error conditions} {
     proc tproc {} {
@@ -343,7 +344,8 @@ test proc-old-5.15 {error conditions} {
     catch tproc msg
     set errorInfo
 } {invoked "continue" outside of a loop
-    while executing
+    (procedure "tproc" line 1)
+    invoked from within
 "tproc"}
 test proc-old-5.16 {error conditions} {
     proc foo args {
-- 
cgit v0.12