[02/11,gdb/testsuite] Fix return -level 2 bug in with_test_prefix
Checks
| Context |
Check |
Description |
| linaro-tcwg-bot/tcwg_gdb_build--master-arm |
success
|
Build passed
|
| linaro-tcwg-bot/tcwg_gdb_build--master-aarch64 |
success
|
Build passed
|
| linaro-tcwg-bot/tcwg_gdb_check--master-arm |
success
|
Test passed
|
Commit Message
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
Comments
>>>>> "Tom" == Tom de Vries <tdevries@suse.de> writes:
Tom> Fix this by:
Tom> - using "catch {...} result opts" to capture the return options dictionary
Tom> - increasing -level in $opts, and
Tom> - using return -options $opts,
Tom> reducing exception handling to just two lines:
Tom> ...
Tom> catch {uplevel 1 $body} result opts
Tom> ...
Tom> return -options [dict incr opts -level 1] $result
Tom> ...
It wasn't clear to me, but does this formulation also work correctly for
things other than 'return' and 'error'? Like, are 'break' and
'continue' properly handled as well?
Tom
new file mode 100644
@@ -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
+ }
+}
@@ -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,