summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2017-06-26 19:17:12 (GMT)
committerdgp <dgp@users.sourceforge.net>2017-06-26 19:17:12 (GMT)
commit45b7c8a7643c1ccb4268653e962709300c237d85 (patch)
treea917ef89016b085236f854e85787ff9e08be5b6a /library/init.tcl
parentc4c7df6e176c32ac510fc6e454147a478ffc4cf1 (diff)
downloadtcl-45b7c8a7643c1ccb4268653e962709300c237d85.zip
tcl-45b7c8a7643c1ccb4268653e962709300c237d85.tar.gz
tcl-45b7c8a7643c1ccb4268653e962709300c237d85.tar.bz2
Try to make good stack trace. Fallback to making not-so-good stack trace.bug_46f801ea5a
Stop failing altogether. Test in test suite, not program fragility.
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl50
1 files changed, 28 insertions, 22 deletions
diff --git a/library/init.tcl b/library/init.tcl
index a202054..6173b86 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -284,14 +284,9 @@ proc unknown args {
}
append cinfo ...
}
- append cinfo "\"\n (\"uplevel\" body line 1)"
- append cinfo "\n invoked from within"
- append cinfo "\n\"uplevel 1 \$args\""
- #
- # Try each possible form of the stack trace
- # and trim the extra contribution from the matching case
- #
- set expect "$msg\n while executing\n\"$cinfo"
+ set tail "\n (\"uplevel\" body line 1)\n invoked\
+ from within\n\"uplevel 1 \$args\""
+ set expect "$msg\n while executing\n\"$cinfo\"$tail"
if {$errInfo eq $expect} {
#
# The stack has only the eval from the expanded command
@@ -305,21 +300,32 @@ proc unknown args {
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
- set expect "\n invoked from within\n\"$cinfo"
- set exlen [string length $expect]
- set eilen [string length $errInfo]
- set i [expr {$eilen - $exlen - 1}]
- set einfo [string range $errInfo 0 $i]
- #
- # For now verify that $errInfo consists of what we are about
- # to return plus what we expected to trim off.
- #
- if {$errInfo ne "$einfo$expect"} {
- error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo]
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] != [string length $errInfo]} {
+ # Very likely cannot happen
+ return -options $opts $msg
}
- return -code error -errorcode $errCode \
- -errorinfo $einfo $msg
+ set errInfo [string range $errInfo 0 $last-1]
+ set tail "\"$cinfo\""
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] != [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo $errInfo $msg
+ }
+ set errInfo [string range $errInfo 0 $last-1]
+ set tail "\n invoked from within\n"
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] == [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo [string range $errInfo 0 $last-1] $msg
+ }
+ set tail "\n while executing\n"
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] == [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo [string range $errInfo 0 $last-1] $msg
+ }
+ return -options $opts $msg
} else {
dict incr opts -level
return -options $opts $msg