diff options
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | library/init.tcl | 62 | ||||
| -rw-r--r-- | tests/init.test | 4 |
3 files changed, 10 insertions, 59 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 562cca6..5b2f1fe 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8400,8 +8400,11 @@ TailcallCleanup( Tcl_Interp *interp, int result) { + Interp *iPtr = (Interp *) interp; + Tcl_DecrRefCount((Tcl_Obj *) data[0]); Tcl_DecrRefCount((Tcl_Obj *) data[1]); + iPtr->flags |= ERR_ALREADY_LOGGED; return result; } diff --git a/library/init.tcl b/library/init.tcl index 3ec78af..9584bf9 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -243,6 +243,10 @@ proc unknown args { set savedErrorCode $::errorCode } + if {[catch {set retry [dict get [info frame -1] cmd]}]} { + set retry $args + } + set name [lindex $args 0] if {![info exists auto_noload]} { # @@ -275,63 +279,7 @@ proc unknown args { } else { unset -nocomplain ::errorInfo } - set code [catch {uplevel 1 $args} msg opts] - if {$code == 1} { - # - # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. - # construct the stack trace. - # - set errorInfo [dict get $opts -errorinfo] - set errorCode [dict get $opts -errorcode] - set cinfo $args - if {[string bytelength $cinfo] > 150} { - set cinfo [string range $cinfo 0 150] - while {[string bytelength $cinfo] > 150} { - set cinfo [string range $cinfo 0 end-1] - } - 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" - if {$errorInfo eq $expect} { - # - # The stack has only the eval from the expanded command - # Do not generate any stack trace here. - # - dict unset opts -errorinfo - dict incr opts -level - return -options $opts $msg - } - # - # 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 $errorInfo] - set i [expr {$eilen - $exlen - 1}] - set einfo [string range $errorInfo 0 $i] - # - # For now verify that $errorInfo consists of what we are about - # to return plus what we expected to trim off. - # - if {$errorInfo ne "$einfo$expect"} { - error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ - [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] - } - return -code error -errorcode $errorCode \ - -errorinfo $einfo $msg - } else { - dict incr opts -level - return -options $opts $msg - } + tailcall try $retry } } diff --git a/tests/init.test b/tests/init.test index 41b8624..00ab3a5 100644 --- a/tests/init.test +++ b/tests/init.test @@ -151,7 +151,7 @@ foreach arg [subst -nocommands -novariables { catch {parray a b $arg} set first $::errorInfo catch {parray a b $arg} - list $first $::errorInfo + list $first "$::errorInfo\n (\"try\" body line 1)" } -match pairwise -result equal test init-4.$count.1 {::errorInfo produced by [unknown]} -setup { auto_reset @@ -162,7 +162,7 @@ foreach arg [subst -nocommands -novariables { catch {parray ::junk::$arg} set first $::errorInfo catch {parray ::junk::$arg} - list $first $::errorInfo + list $first "$::errorInfo\n (\"try\" body line 1)" } -match pairwise -result equal incr count |