[PATCH 06/11] [gdb/testsuite] Refactor exception handling

[Tom de Vries <tdevries@suse.de>]

Use try/finally and transparent_uplevel to refactor exception handling.

Most procs use both try/finally and transparent_uplevel.

The two exceptions are:
- target_compile_ada_from_dir (only uses try/finally)
- with_ansi_styling_terminal (only uses transparent_uplevel)

Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553
---
 gdb/testsuite/lib/ada.exp       |  14 +-
 gdb/testsuite/lib/dwarf.exp     |  15 +-
 gdb/testsuite/lib/gdb-utils.exp |  17 +-
 gdb/testsuite/lib/gdb.exp       | 298 ++++++++++++--------------------
 gdb/testsuite/lib/tuiterm.exp   |  15 +-
 5 files changed, 136 insertions(+), 223 deletions(-)

diff --git a/gdb/testsuite/lib/ada.exp b/gdb/testsuite/lib/ada.exp
index 086866aca99..2dcd8a06f3f 100644
--- a/gdb/testsuite/lib/ada.exp
+++ b/gdb/testsuite/lib/ada.exp
@@ -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.
diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 839c5174265..1323c2dfd83 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -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.
diff --git a/gdb/testsuite/lib/gdb-utils.exp b/gdb/testsuite/lib/gdb-utils.exp
index cabeb7aa1ed..1f04a626cbc 100644
--- a/gdb/testsuite/lib/gdb-utils.exp
+++ b/gdb/testsuite/lib/gdb-utils.exp
@@ -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
+	}
     }
 }
 
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 853b45f4a53..2cd2603e39f 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -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
     }
 }
 
diff --git a/gdb/testsuite/lib/tuiterm.exp b/gdb/testsuite/lib/tuiterm.exp
index d23e29d1a6d..e0ba8510d6e 100644
--- a/gdb/testsuite/lib/tuiterm.exp
+++ b/gdb/testsuite/lib/tuiterm.exp
@@ -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"
     }
 }
 
-- 
2.51.0