* [PATCH 01/11] [gdb/testsuite] Normalize indentation in with_test_prefix
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 02/11] [gdb/testsuite] Fix return -level 2 bug " Tom de Vries
` (9 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Normalize indentation in proc with_test_prefix to 4 spaces.
---
gdb/testsuite/lib/gdb.exp | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 1a6438f36a5..09c89624f2e 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3290,19 +3290,19 @@ gdb_caching_proc allow_tui_tests {} {
# Returns the result of BODY.
#
proc with_test_prefix { prefix body } {
- global pf_prefix
+ global pf_prefix
- set saved $pf_prefix
- append pf_prefix " " $prefix ":"
- set code [catch {uplevel 1 $body} result]
- set pf_prefix $saved
+ set saved $pf_prefix
+ append pf_prefix " " $prefix ":"
+ set code [catch {uplevel 1 $body} result]
+ set pf_prefix $saved
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
- }
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
}
# Wrapper for foreach that calls with_test_prefix on each iteration,
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 02/11] [gdb/testsuite] Fix return -level 2 bug in with_test_prefix
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
2026-08-24 13:58 ` [PATCH 01/11] [gdb/testsuite] Normalize indentation in with_test_prefix Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 03/11] [gdb/testsuite] Simplify foreach_with_prefix Tom de Vries
` (8 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Consider proc with_test_prefix:
...
proc with_test_prefix { prefix body } {
global pf_prefix
set saved $pf_prefix
append pf_prefix " " $prefix ":"
set code [catch {uplevel 1 $body} result]
set pf_prefix $saved
if {$code == 1} {
global errorInfo errorCode
return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
} else {
return -code $code $result
}
}
...
I asked Claude Code:
...
The function test_with_prefix is trying to implement that
"test_with_prefix prefix body" has the same semantics as "body" (ignoring the
prefix part). Can you verify this, and possibly come up with a
counter-example?
...
and it came up with using return -level 2.
I wrote a standalone reproducer:
...
proc with_test_prefix { body } {
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
}
}
proc bar {} {
with_test_prefix {
puts "Returning in bar (ok)"
return -level 2 1
}
}
proc foo {} {
set res [bar]
puts "returning in foo (not ok)"
return 2
}
puts [foo]
...
which gives us:
...
$ tclsh ./test.tcl
Returning in bar (ok)
returning in foo (not ok)
2
...
Fix this by:
- using "catch {...} result opts" to capture the return options dictionary
- increasing -level in $opts, and
- using return -options $opts,
reducing exception handling to just two lines:
...
catch {uplevel 1 $body} result opts
...
return -options [dict incr opts -level 1] $result
...
The problem exists everywhere were we use the same catch/return pattern, but
that gets fixed in following patches.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553
---
.../gdb.testsuite/with-test-prefix.exp | 45 +++++++++++++++++++
gdb/testsuite/lib/gdb.exp | 9 +---
2 files changed, 47 insertions(+), 7 deletions(-)
create mode 100644 gdb/testsuite/gdb.testsuite/with-test-prefix.exp
diff --git a/gdb/testsuite/gdb.testsuite/with-test-prefix.exp b/gdb/testsuite/gdb.testsuite/with-test-prefix.exp
new file mode 100644
index 00000000000..366be7ee3e6
--- /dev/null
+++ b/gdb/testsuite/gdb.testsuite/with-test-prefix.exp
@@ -0,0 +1,45 @@
+# Copyright 2026 Free Software Foundation, Inc.
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# Testsuite self-tests for with_test_prefix.
+
+proc bar {variant} {
+ if {$variant == 0} {
+ verbose -log "Returning in bar (ok)"
+ return -level 2 1
+ } else {
+ with_test_prefix dummy {
+ verbose -log "Returning in bar (ok)"
+ return -level 2 1
+ }
+ }
+}
+
+proc foo {variant} {
+ set res [bar $variant]
+ verbose -log "returning in foo (not ok)"
+ return 2
+}
+
+# Note: don't use with_test_prefix (directly or indirectly) to make sure that
+# this test is run even if with_test_prefix is broken.
+foreach variant {0 1} {
+ set msg "$variant: return -level 2"
+ try {
+ set res 0
+ set res [foo $variant]
+ } finally {
+ gdb_assert {$res == 1} $msg
+ }
+}
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 09c89624f2e..71e38e4801a 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3294,15 +3294,10 @@ proc with_test_prefix { prefix body } {
set saved $pf_prefix
append pf_prefix " " $prefix ":"
- set code [catch {uplevel 1 $body} result]
+ catch {uplevel 1 $body} result opts
set pf_prefix $saved
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
- }
+ return -options [dict incr opts -level 1] $result
}
# Wrapper for foreach that calls with_test_prefix on each iteration,
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 03/11] [gdb/testsuite] Simplify foreach_with_prefix
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
2026-08-24 13:58 ` [PATCH 01/11] [gdb/testsuite] Normalize indentation in with_test_prefix Tom de Vries
2026-08-24 13:58 ` [PATCH 02/11] [gdb/testsuite] Fix return -level 2 bug " Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 04/11] [gdb/testsuite] Refactor exception handling in foreach_with_prefix Tom de Vries
` (7 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
In the testsuite there's a pattern for handling a catch result:
...
proc foo {body} {
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
}
}
...
with the intended effect that executing "foo body" has the same effect as
"body".
The pattern's different though in proc foreach_with_prefix:
...
proc foreach_with_prefix {var list body} {
upvar 1 $var myvar
foreach myvar $list {
with_test_prefix "$var=$myvar" {
set code [catch {uplevel 1 $body} result]
}
if {$code == 1} {
global errorInfo errorCode
return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
} elseif {$code == 3} {
break
} elseif {$code == 2} {
return -code $code $result
}
}
}
...
where it handles:
- break ($code == 3) by breaking, and
- ok and continue ($code == 0/4) by ignoring it.
Move the foreach into the catch:
...
set code [catch {
foreach myvar $list {
with_test_prefix "$var=$myvar" {
uplevel 1 $body
}
}
} result]
...
to let foreach handle break and continue, allowing us to handle the catch
result in the usual way.
Likewise in foreach_mi_ui_mode.
---
gdb/testsuite/lib/gdb.exp | 22 +++++++++++-----------
gdb/testsuite/lib/mi-support.exp | 26 +++++++++++++-------------
2 files changed, 24 insertions(+), 24 deletions(-)
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 71e38e4801a..c8254ac9dd3 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3305,19 +3305,19 @@ proc with_test_prefix { prefix body } {
proc foreach_with_prefix {var list body} {
upvar 1 $var myvar
- foreach myvar $list {
- with_test_prefix "$var=$myvar" {
- set code [catch {uplevel 1 $body} result]
+ set code [catch {
+ foreach myvar $list {
+ with_test_prefix "$var=$myvar" {
+ uplevel 1 $body
+ }
}
+ } result]
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif {$code == 3} {
- break
- } elseif {$code == 2} {
- return -code $code $result
- }
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
}
}
diff --git a/gdb/testsuite/lib/mi-support.exp b/gdb/testsuite/lib/mi-support.exp
index 4fd3eeb0dde..2e87769b538 100644
--- a/gdb/testsuite/lib/mi-support.exp
+++ b/gdb/testsuite/lib/mi-support.exp
@@ -2931,19 +2931,19 @@ proc foreach_mi_ui_mode { var_name body } {
set modes {"main" "separate"}
}
- foreach var $modes {
- with_test_prefix "$var_name=$var" {
- set code [catch {uplevel 1 $body} result]
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif {$code == 3} {
- break
- } elseif {$code == 2} {
- return -code $code $result
- }
+ set code [catch {
+ foreach var $modes {
+ with_test_prefix "$var_name=$var" {
+ uplevel 1 $body
+ }
+ }
+ } result]
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
}
}
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 04/11] [gdb/testsuite] Refactor exception handling in foreach_with_prefix
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (2 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 03/11] [gdb/testsuite] Simplify foreach_with_prefix Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 05/11] [gdb/testsuite] Add transparent_uplevel Tom de Vries
` (6 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Refactor foreach_with_prefix using return -options.
Likewise in foreach_mi_ui_mode.
Both procs also have the return -level 2 problem (PR34553), so fix this using
"[dict incr opts -level]".
Also add a PR34553 regression test for foreach_with_prefix.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553
---
.../gdb.testsuite/foreach_with_prefix.exp | 27 +++++++++++++++++++
gdb/testsuite/lib/gdb.exp | 12 +++------
gdb/testsuite/lib/mi-support.exp | 12 +++------
3 files changed, 33 insertions(+), 18 deletions(-)
diff --git a/gdb/testsuite/gdb.testsuite/foreach_with_prefix.exp b/gdb/testsuite/gdb.testsuite/foreach_with_prefix.exp
index 04762d9baef..20a0f1022be 100644
--- a/gdb/testsuite/gdb.testsuite/foreach_with_prefix.exp
+++ b/gdb/testsuite/gdb.testsuite/foreach_with_prefix.exp
@@ -71,6 +71,33 @@ with_test_prefix "return" {
check_sequence $seq "0 0"
}
+# Test TCL_RETURN (2), level 2.
+foreach foreach_variant {foreach foreach_with_prefix} {
+ with_test_prefix "$foreach_variant: return level 2" {
+ proc test_return_level_2_inner {} {
+ set seq ""
+ $::foreach_variant var1 {0 1} {
+ $::foreach_variant var2 {0 1} {
+ lappend seq $var1 $var2
+ return -level 2 $seq
+ }
+ }
+ return $seq
+ }
+ proc test_return_level_2_outer {} {
+ test_return_level_2_inner
+ return "outer"
+ }
+
+ try {
+ set seq "initial"
+ set seq [test_return_level_2_outer]
+ } finally {
+ check_sequence $seq "0 0"
+ }
+ }
+}
+
# Test TCL_BREAK (3).
with_test_prefix "break" {
set seq ""
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index c8254ac9dd3..88a42aff4ac 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3305,20 +3305,14 @@ proc with_test_prefix { prefix body } {
proc foreach_with_prefix {var list body} {
upvar 1 $var myvar
- set code [catch {
+ catch {
foreach myvar $list {
with_test_prefix "$var=$myvar" {
uplevel 1 $body
}
}
- } result]
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
- }
+ } result opts
+ return -options [dict incr opts -level] $result
}
# Like TCL's native proc, but defines a procedure that wraps its body
diff --git a/gdb/testsuite/lib/mi-support.exp b/gdb/testsuite/lib/mi-support.exp
index 2e87769b538..240bc844350 100644
--- a/gdb/testsuite/lib/mi-support.exp
+++ b/gdb/testsuite/lib/mi-support.exp
@@ -2931,20 +2931,14 @@ proc foreach_mi_ui_mode { var_name body } {
set modes {"main" "separate"}
}
- set code [catch {
+ catch {
foreach var $modes {
with_test_prefix "$var_name=$var" {
uplevel 1 $body
}
}
- } result]
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
- } else {
- return -code $code $result
- }
+ } result opts
+ return -options [dict incr opts -level] $result
}
# Check if GDB has information about the stderr symbol.
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 05/11] [gdb/testsuite] Add transparent_uplevel
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (3 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 04/11] [gdb/testsuite] Refactor exception handling in foreach_with_prefix Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 06/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (5 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Having learned the trick of increasing -level, factor out a new proc
transparent_uplevel:
...
proc transparent_uplevel { body } {
catch {uplevel 2 $body} result opts
return -options [dict incr opts -level 2] $result
...
to be used in conjunction with try/finally to apply this pattern:
...
proc foo { body } {
<do something>
try {
transparent_uplevel $body
} finally {
<do something else>
}
}
...
such that "foo body" has the same effect as "body", apart from the
<do something>/<do something else> parts.
This proc has the fix for PR34553 designed into it, so (correctly) applying it
in a proc will fix the PR there.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553
---
gdb/testsuite/lib/gdb.exp | 47 +++++++++++++++++++++++++++++++++++++++
1 file changed, 47 insertions(+)
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 88a42aff4ac..853b45f4a53 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3218,6 +3218,53 @@ gdb_caching_proc allow_tui_tests {} {
return [expr {[string first "--enable-tui" $output] != -1}]
}
+# Run BODY in the context of the callers caller.
+#
+# To be used in a proc foo:
+# proc foo {body} {
+# transparent_uplevel body
+# }
+# to make "foo body" have the same effect as "body".
+#
+# It ensures this by doing two things:
+# - evaluating the body in the context of the caller of foo
+# - propagating any return, exceptional or not to the caller of foo.
+#
+# Typically used in conjunction with try/finally, to ensure something
+# happens before and after body. For instance, this:
+# proc foo {body} {
+# try {
+# puts "foo: enter"
+# transparent_uplevel $body
+# } finally {
+# puts "foo: exit"
+# }
+# }
+#
+# for {set i 0} {$i < 5} {incr i} {
+# puts $i
+# foo {
+# if {$i == 2} {
+# break
+# }
+# }
+# }
+# produces:
+# 0
+# foo: enter
+# foo: exit
+# 1
+# foo: enter
+# foo: exit
+# 2
+# foo: enter
+# foo: exit
+
+proc transparent_uplevel { body } {
+ catch {uplevel 2 $body} result opts
+ return -options [dict incr opts -level 2] $result
+}
+
# Test files shall make sure all the test result lines in gdb.sum are
# unique in a test run, so that comparing the gdb.sum files of two
# test runs gives correct results. Test files that exercise
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 06/11] [gdb/testsuite] Refactor exception handling
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (4 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 05/11] [gdb/testsuite] Add transparent_uplevel Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 07/11] [gdb/testsuite] Refactor exception handling in gdb_expect Tom de Vries
` (4 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
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
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 07/11] [gdb/testsuite] Refactor exception handling in gdb_expect
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (5 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 06/11] [gdb/testsuite] Refactor exception handling Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 08/11] [gdb/testsuite] Refactor exception handling in gdb_test_multiple Tom de Vries
` (3 subsequent siblings)
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Simplify gdb_expect using transparent_uplevel.
---
gdb/testsuite/lib/gdb.exp | 13 +++----------
1 file changed, 3 insertions(+), 10 deletions(-)
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 2cd2603e39f..479d1229142 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -7531,16 +7531,9 @@ proc gdb_expect { args } {
set tmt [get_largest_timeout]
}
- set code [catch \
- {uplevel remote_expect host $tmt $expcode} string]
-
- if {$code == 1} {
- global errorInfo errorCode
-
- return -code error -errorinfo $errorInfo -errorcode $errorCode $string
- } else {
- return -code $code $string
- }
+ transparent_uplevel [subst_vars {
+ remote_expect host $tmt $expcode
+ }]
}
# gdb_expect_list TEST SENTINEL LIST -- expect a sequence of outputs
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 08/11] [gdb/testsuite] Refactor exception handling in gdb_test_multiple
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (6 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 07/11] [gdb/testsuite] Refactor exception handling in gdb_expect Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-25 7:29 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 09/11] [gdb/testsuite] Refactor exception handling in lock_file_acquire/release Tom de Vries
` (2 subsequent siblings)
10 siblings, 1 reply; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Simplify gdb_test_multiple using return -options and try/finally.
In the process, we also try to fix PR34553.
I've added a test to verify this, but it'll be only useful after remote_expect
gets fixed [1].
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553
[1] https://debbugs.gnu.org/cgi/bugreport.cgi?bug=81691
---
gdb/testsuite/gdb.testsuite/gdb-test.exp | 51 ++++++++++++++++++++++++
gdb/testsuite/lib/gdb.exp | 37 +++++++++--------
2 files changed, 69 insertions(+), 19 deletions(-)
diff --git a/gdb/testsuite/gdb.testsuite/gdb-test.exp b/gdb/testsuite/gdb.testsuite/gdb-test.exp
index dab65f21bdb..231f0755f58 100644
--- a/gdb/testsuite/gdb.testsuite/gdb-test.exp
+++ b/gdb/testsuite/gdb.testsuite/gdb-test.exp
@@ -49,6 +49,57 @@ with_test_prefix "cmd with trailing control code" {
}
}
+foreach_with_prefix variant {0 1 2} {
+ proc level_2_inner {} {
+ if {$::variant == 0} {
+ return -level 2 "return_level_2"
+ } elseif {$::variant == 1} {
+ send_gdb "print 1\n"
+ set prompt_re [string_to_regexp "(gdb) "]
+ remote_expect host 10 {
+ -re " = 1\r\n$prompt_re$" {
+ return -level 2 "return_level_2"
+ }
+ }
+ } else {
+ gdb_test_multiple "print 1" "" {
+ -re -wrap " = 1" {
+ return -level 2 "return_level_2"
+ }
+ }
+ }
+ return "inner"
+ }
+
+ proc level_2_outer {} {
+ level_2_inner
+ return "outer"
+ }
+
+ try {
+ set res "initial"
+ set res [level_2_outer]
+ } finally {
+ if {$variant == 0} {
+ # trivial case.
+ gdb_assert {$res == "return_level_2"}
+ } elseif {$variant == 1} {
+ # Remove_expect case.
+ if {$res == "outer"} {
+ # Dejagnu bug.
+ # https://debbugs.gnu.org/cgi/bugreport.cgi?bug=81691
+ setup_xfail *-*-*
+ }
+ gdb_assert {$res == "return_level_2"}
+ set variant1_res $res
+ } else {
+ # Gdb_test_multiple case. This should work if the remote_expect
+ # case works.
+ gdb_assert {$res == $variant1_res}
+ }
+ }
+}
+
# Change the prompt.
set prompt "(GDB) "
set prompt_re "\\(GDB\\) $"
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 479d1229142..99468ac3ef3 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1369,7 +1369,6 @@ proc gdb_test_multiple { command message args } {
send_user "Message is \"$message\"\n"
}
- set result -1
set string "${command}\n"
if { $command != "" } {
set multi_line_re "\[\r\n\] *>"
@@ -1574,25 +1573,25 @@ proc gdb_test_multiple { command message args } {
}
set gdb_test_name "$message"
- set result 0
- set code [catch {gdb_expect $code} string]
-
- # Clean up the gdb_test_name variable. If we had a
- # previous value then restore it, otherwise, delete the variable
- # from the parent scope.
- if { [info exists gdb_test_name_old] } {
- set gdb_test_name "$gdb_test_name_old"
- } else {
- unset gdb_test_name
- }
-
- if {$code == 1} {
- global errorInfo errorCode
- return -code error -errorinfo $errorInfo -errorcode $errorCode $string
- } elseif {$code > 1} {
- return -code $code $string
+ try {
+ if {[info exists result]} {
+ error "result set but not used"
+ }
+ set result 0
+ if {[catch {gdb_expect $code} string opts] == 0} {
+ return $result
+ }
+ return -options [dict incr opts -level] $string
+ } finally {
+ # Clean up the gdb_test_name variable. If we had a
+ # previous value then restore it, otherwise, delete the variable
+ # from the parent scope.
+ if { [info exists gdb_test_name_old] } {
+ set gdb_test_name "$gdb_test_name_old"
+ } else {
+ unset gdb_test_name
+ }
}
- return $result
}
# Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ...
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 09/11] [gdb/testsuite] Refactor exception handling in lock_file_acquire/release
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (7 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 08/11] [gdb/testsuite] Refactor exception handling in gdb_test_multiple Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 10/11] [gdb/testsuite] Refactor exception handling in tentative_rename Tom de Vries
2026-08-24 13:58 ` [PATCH 11/11] [gdb/testsuite] Refactor exception handling in with_stub_devices Tom de Vries
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Use try/on-error to simplify lock_file_acquire/release.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
---
gdb/testsuite/lib/gdb-utils.exp | 28 +++++++++++++++++-----------
1 file changed, 17 insertions(+), 11 deletions(-)
diff --git a/gdb/testsuite/lib/gdb-utils.exp b/gdb/testsuite/lib/gdb-utils.exp
index 1f04a626cbc..35329f3c46e 100644
--- a/gdb/testsuite/lib/gdb-utils.exp
+++ b/gdb/testsuite/lib/gdb-utils.exp
@@ -184,7 +184,9 @@ proc version_compare { l1 op l2 } {
proc lock_file_acquire {lockfile} {
verbose -log "acquiring lock file: $::subdir/${::gdb_test_file_name}.exp"
while {true} {
- if {![catch {open $lockfile {WRONLY CREAT EXCL}} rc]} {
+ try {
+ open $lockfile {WRONLY CREAT EXCL}
+ } on ok {rc} {
set msg "locked by $::subdir/${::gdb_test_file_name}.exp"
verbose -log "lock file: $msg"
# For debugging, put info in the lockfile about who owns
@@ -192,6 +194,8 @@ proc lock_file_acquire {lockfile} {
puts $rc $msg
flush $rc
return [list $rc $lockfile]
+ } on error {} {
+ # Ignore and try again.
}
after 10
}
@@ -202,18 +206,20 @@ proc lock_file_acquire {lockfile} {
proc lock_file_release {info} {
verbose -log "releasing lock file: $::subdir/${::gdb_test_file_name}.exp"
- if {![catch {fconfigure [lindex $info 0]}]} {
- if {![catch {
- close [lindex $info 0]
- file delete -force [lindex $info 1]
- } rc]} {
- return ""
- } else {
- return -code error "Error releasing lockfile: '$rc'"
- }
- } else {
+ try {
+ fconfigure [lindex $info 0]
+ } on error {} {
error "invalid lock"
}
+
+ try {
+ close [lindex $info 0]
+ file delete -force [lindex $info 1]
+ } on error {rc} {
+ error "Error releasing lockfile: '$rc'"
+ }
+
+ return ""
}
# Return directory where we keep lock files.
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 10/11] [gdb/testsuite] Refactor exception handling in tentative_rename
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (8 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 09/11] [gdb/testsuite] Refactor exception handling in lock_file_acquire/release Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
2026-08-24 13:58 ` [PATCH 11/11] [gdb/testsuite] Refactor exception handling in with_stub_devices Tom de Vries
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Use try/on-error to simplify tentative_rename.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
---
gdb/testsuite/lib/gdb.exp | 23 ++++++++++++-----------
1 file changed, 12 insertions(+), 11 deletions(-)
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 99468ac3ef3..e69a598bb10 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -8639,17 +8639,18 @@ proc standard_temp_file {basename} {
# as is and delete A. Return 1 if rename happened.
proc tentative_rename { a b } {
- global errorInfo errorCode
- set code [catch {file rename -- $a $b} result]
- if { $code == 1 && [lindex $errorCode 0] == "POSIX" \
- && [lindex $errorCode 1] == "EEXIST" } {
- file delete $a
- return 0
- }
- if {$code == 1} {
- return -code error -errorinfo $errorInfo -errorcode $errorCode $result
- } elseif {$code > 1} {
- return -code $code $result
+ try {
+ file rename -- $a $b
+ } on error {result opts} {
+ set errorcode [dict get $opts -errorcode]
+ if { [lindex $errorcode 0] == "POSIX" \
+ && [lindex $errorcode 1] == "EEXIST" } {
+ file delete $a
+ return 0
+ }
+
+ # Rethrow.
+ return -options $opts $result
}
return 1
}
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread* [PATCH 11/11] [gdb/testsuite] Refactor exception handling in with_stub_devices
2026-08-24 13:58 [PATCH 00/11] [gdb/testsuite] Refactor exception handling Tom de Vries
` (9 preceding siblings ...)
2026-08-24 13:58 ` [PATCH 10/11] [gdb/testsuite] Refactor exception handling in tentative_rename Tom de Vries
@ 2026-08-24 13:58 ` Tom de Vries
10 siblings, 0 replies; 13+ messages in thread
From: Tom de Vries @ 2026-08-24 13:58 UTC (permalink / raw)
To: gdb-patches
Use with_override and try/finally to simplify with_stub_devices.
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
---
gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp b/gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp
index 8f04cca7981..7f90a112138 100644
--- a/gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp
+++ b/gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp
@@ -24,13 +24,16 @@ load_lib rocm.exp
# Run BODY with find_amdgpu_devices stubbed to return DEVICES, then
# restore the original proc.
proc with_stub_devices {devices body} {
- rename find_amdgpu_devices __saved_find_amdgpu_devices
# tclint-disable-next-line command-args
- proc find_amdgpu_devices {} [list return $devices]
- set code [catch {uplevel 1 $body} result]
- rename find_amdgpu_devices {}
- rename __saved_find_amdgpu_devices find_amdgpu_devices
- return -code $code $result
+ proc with_stub_devices_find_amdgpu_devices {} [list return $devices]
+ try {
+ # tclint-disable-next-line command-args
+ with_override \
+ find_amdgpu_devices with_stub_devices_find_amdgpu_devices \
+ $body
+ } finally {
+ rename with_stub_devices_find_amdgpu_devices {}
+ }
}
# Tests using find_amdgpu_devices (no HCC_AMDGPU_TARGET env var).
--
2.51.0
^ permalink raw reply [flat|nested] 13+ messages in thread