summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2002-04-15 17:45:06 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2002-04-15 17:45:06 (GMT)
commitce77e262200ad395011337df26e7e52292d83c17 (patch)
treea2089c7e0c492fc71493d5dc30e2c0ebca6af8c6
parentc57b1b3f7c6afcd33faa0e7f8451d07435660464 (diff)
downloadtcl-ce77e262200ad395011337df26e7e52292d83c17.zip
tcl-ce77e262200ad395011337df26e7e52292d83c17.tar.gz
tcl-ce77e262200ad395011337df26e7e52292d83c17.tar.bz2
Improved stack trace for TCL_BREAK and TCL_CONTINUE returns from procs. [Bug 536955].
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclProc.c47
-rw-r--r--tests/proc-old.test8
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 {