[PATCH 02/11] [gdb/testsuite] Fix return -level 2 bug in with_test_prefix

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

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