@@ -67,18 +67,16 @@ proc target_compile_ada_from_dir {builddir source dest type options} {
set_board_info multilib_flags "$multilib_flag"
}
- catch {
+ try {
with_cwd $builddir {
return [target_compile $source $dest $type $options]
}
- } result options
-
- if { $save_multilib_flag != "" } {
- unset_board_info "multilib_flags"
- set_board_info multilib_flags $save_multilib_flag
+ } finally {
+ if { $save_multilib_flag != "" } {
+ unset_board_info "multilib_flags"
+ set_board_info multilib_flags $save_multilib_flag
+ }
}
-
- return -options $options $result
}
# Compile some Ada code. Return "" if the compile was successful.
@@ -324,18 +324,11 @@ proc shared_gdb_end_use {} {
proc with_shared_gdb { body } {
shared_gdb_enable
- set code [catch { uplevel 1 $body } result]
- shared_gdb_disable
-
- # Return as appropriate.
- if { $code == 1 } {
- global errorInfo errorCode
- return -code error -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif { $code > 1 } {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ shared_gdb_disable
}
-
- return $result
}
# Return a list of expressions about function FUNC's address and length.
@@ -235,17 +235,12 @@ proc with_lock { lock_file body } {
set lock_rc [lock_file_acquire $lock_file]
}
- set code [catch {uplevel 1 $body} result]
-
- if {[info exists ::GDB_PARALLEL]} {
- lock_file_release $lock_rc
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ if {[info exists ::GDB_PARALLEL]} {
+ lock_file_release $lock_rc
+ }
}
}
@@ -148,22 +148,15 @@ proc load_lib { file } {
set known_globals($varname) 1
}
- set code [catch {saved_load_lib $file} result]
-
- foreach varname [info globals] {
- if { ![info exists known_globals($varname)] } {
- gdb_persistent_global_no_decl $varname
- }
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code error -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif {$code > 1} {
- return -code $code $result
+ try {
+ saved_load_lib $file
+ } finally {
+ foreach varname [info globals] {
+ if { ![info exists known_globals($varname)] } {
+ gdb_persistent_global_no_decl $varname
+ }
+ }
}
-
- return $result
}
# Tcl 9.0 changed the default channel encoding profile to "strict".
@@ -3341,10 +3334,11 @@ proc with_test_prefix { prefix body } {
set saved $pf_prefix
append pf_prefix " " $prefix ":"
- catch {uplevel 1 $body} result opts
- set pf_prefix $saved
-
- return -options [dict incr opts -level 1] $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ set pf_prefix $saved
+ }
}
# Wrapper for foreach that calls with_test_prefix on each iteration,
@@ -3440,26 +3434,21 @@ proc save_vars { vars body } {
}
}
- set code [catch {uplevel 1 $body} result]
-
- foreach {var value} [array get saved_scalars] {
- uplevel 1 [list set $var $value]
- }
-
- foreach {var value} [array get saved_arrays] {
- uplevel 1 [list unset $var]
- uplevel 1 [list array set $var $value]
- }
+ try {
+ transparent_uplevel $body
+ } finally {
+ foreach {var value} [array get saved_scalars] {
+ uplevel 1 [list set $var $value]
+ }
- foreach var $unset_vars {
- uplevel 1 [list unset -nocomplain $var]
- }
+ foreach {var value} [array get saved_arrays] {
+ uplevel 1 [list unset $var]
+ uplevel 1 [list array set $var $value]
+ }
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ foreach var $unset_vars {
+ uplevel 1 [list unset -nocomplain $var]
+ }
}
}
@@ -3491,22 +3480,17 @@ proc save_target_board_info { vars body } {
}
}
- set code [catch {uplevel 1 $body} result]
-
- foreach {var value} [array get saved_target_board_info] {
- unset_board_info $var
- set_board_info $var $value
- }
-
- foreach var $unset_target_board_info {
- unset_board_info $var
- }
+ try {
+ transparent_uplevel $body
+ } finally {
+ foreach {var value} [array get saved_target_board_info] {
+ unset_board_info $var
+ set_board_info $var $value
+ }
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ foreach var $unset_target_board_info {
+ unset_board_info $var
+ }
}
}
@@ -3522,16 +3506,11 @@ proc with_cwd { dir body } {
verbose -log "Switching to directory $dir (saved CWD: $saved_dir)."
cd $dir
- set code [catch {uplevel 1 $body} result]
-
- verbose -log "Switching back to $saved_dir."
- cd $saved_dir
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ verbose -log "Switching back to $saved_dir."
+ cd $saved_dir
}
}
@@ -3606,42 +3585,37 @@ proc with_gdb_cwd { dir body } {
return
}
- set code [catch {uplevel 1 $body} result]
-
- verbose -log "Switching back to $saved_dir."
- if {![gdb_cd $saved_dir]} {
- return
- }
-
- # Check that GDB is still alive. If GDB crashed in the above code
- # then any corefile will have been left in DIR, not the root
- # testsuite directory. As a result the corefile will not be
- # brought to the users attention. Instead, if GDB crashed, then
- # this check should cause a FAIL, which should be enough to alert
- # the user.
- set saw_result false
- gdb_test_multiple "p 123" "" {
- -re "p 123\r\n" {
- exp_continue
+ try {
+ transparent_uplevel $body
+ } finally {
+ verbose -log "Switching back to $saved_dir."
+ if {![gdb_cd $saved_dir]} {
+ return
}
- -re "^${::valnum_re} = 123\r\n" {
- set saw_result true
- exp_continue
- }
+ # Check that GDB is still alive. If GDB crashed in the above code
+ # then any corefile will have been left in DIR, not the root
+ # testsuite directory. As a result the corefile will not be
+ # brought to the users attention. Instead, if GDB crashed, then
+ # this check should cause a FAIL, which should be enough to alert
+ # the user.
+ set saw_result false
+ gdb_test_multiple "p 123" "" {
+ -re "p 123\r\n" {
+ exp_continue
+ }
- -re "^$::gdb_prompt $" {
- if { !$saw_result } {
- fail "check gdb is alive in with_gdb_cwd"
+ -re "^${::valnum_re} = 123\r\n" {
+ set saw_result true
+ exp_continue
}
- }
- }
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ -re "^$::gdb_prompt $" {
+ if { !$saw_result } {
+ fail "check gdb is alive in with_gdb_cwd"
+ }
+ }
+ }
}
}
@@ -3682,17 +3656,12 @@ proc with_gdb_prompt { prompt body } {
set gdb_prompt $prompt
gdb_test_no_output "set prompt $prompt " ""
- set code [catch {uplevel 1 $body} result]
-
- verbose -log "Restoring gdb prompt to \"$saved \"."
- set gdb_prompt $saved
- gdb_test_no_output "set prompt $saved " ""
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ verbose -log "Restoring gdb prompt to \"$saved \"."
+ set gdb_prompt $saved
+ gdb_test_no_output "set prompt $saved " ""
}
}
@@ -3717,15 +3686,10 @@ proc with_target_charset { target_charset body } {
gdb_test_no_output -nopass "set target-charset $target_charset"
- set code [catch {uplevel 1 $body} result]
-
- gdb_test_no_output -nopass "set target-charset $saved"
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ gdb_test_no_output -nopass "set target-charset $saved"
}
}
@@ -3747,15 +3711,10 @@ proc with_max_value_size { size body } {
gdb_test_no_output -nopass "set max-value-size $size"
- set code [catch {uplevel 1 $body} result]
-
- gdb_test_no_output -nopass "set max-value-size $saved"
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ gdb_test_no_output -nopass "set max-value-size $saved"
}
}
@@ -3793,19 +3752,14 @@ proc with_spawn_id { spawn_id body } {
switch_gdb_spawn_id $spawn_id
- set code [catch {uplevel 1 $body} result]
-
- if {[info exists saved_spawn_id]} {
- switch_gdb_spawn_id $saved_spawn_id
- } else {
- clear_gdb_spawn_id
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ if {[info exists saved_spawn_id]} {
+ switch_gdb_spawn_id $saved_spawn_id
+ } else {
+ clear_gdb_spawn_id
+ }
}
}
@@ -3860,14 +3814,10 @@ proc with_timeout_factor { factor body } {
set savedtimeout $timeout
set timeout [expr {[get_largest_timeout] * $factor}]
- set code [catch {uplevel 1 $body} result]
-
- set timeout $savedtimeout
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ set timeout $savedtimeout
}
}
@@ -8281,24 +8231,19 @@ proc with_set { var val body } {
}
}
- set code [catch {uplevel 1 $body} result]
-
- # Restore saved setting.
- if { $save != "" } {
- gdb_test_multiple "set $var $save" "" {
- -re -wrap "^" {
- }
- -re -wrap "is set to \"?$save\"?( \\(\[^)\]*\\))?\\." {
+ try {
+ transparent_uplevel $body
+ } finally {
+ # Restore saved setting.
+ if { $save != "" } {
+ gdb_test_multiple "set $var $save" "" {
+ -re -wrap "^" {
+ }
+ -re -wrap "is set to \"?$save\"?( \\(\[^)\]*\\))?\\." {
+ }
}
}
}
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
- }
}
#
@@ -11334,25 +11279,17 @@ proc with_override { name override body } {
proc $name $new_args $new_body
# Execute body.
- set code [catch {uplevel 1 $body} result]
-
- # Restore old proc if it existed on entry, else delete it.
- if { $existed } {
- # tclint-disable-next-line command-args
- proc $name $old_args $old_body
- } else {
- rename $name ""
- }
-
- # Return as appropriate.
- if { $code == 1 } {
- global errorInfo errorCode
- return -code error -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif { $code > 1 } {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ # Restore old proc if it existed on entry, else delete it.
+ if { $existed } {
+ # tclint-disable-next-line command-args
+ proc $name $old_args $old_body
+ } else {
+ rename $name ""
+ }
}
-
- return $result
}
# Run BODY after setting the TERM environment variable to 'ansi', and
@@ -11368,14 +11305,7 @@ proc with_ansi_styling_terminal { body } {
unset -nocomplain ::env(NO_COLOR)
unset -nocomplain ::env(COLORTERM)
- set code [catch {uplevel 1 $body} result]
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ transparent_uplevel $body
}
}
@@ -56,15 +56,12 @@ proc Term::_log_cur { what body } {
set orig_cur_row $_cur_row
set orig_cur_col $_cur_col
- set code [catch {uplevel $body} result]
-
- _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"
-
- if { $code == 1 } {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
+ try {
+ transparent_uplevel $body
+ } finally {
+ set before "($orig_cur_row, $orig_cur_col)"
+ set after "($_cur_row, $_cur_col)"
+ _log "$what, cursor: $before -> $after"
}
}