diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclProc.c | 47 | ||||
| -rw-r--r-- | tests/proc-old.test | 8 |
3 files changed, 35 insertions, 27 deletions
@@ -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 { |