[pushed 1/3] [gdb/testsuite] Use transparent_uplevel in foreach_with_prefix

[pushed 1/3] [gdb/testsuite] Use transparent_uplevel in foreach_with_prefix

[Tom de Vries]

After the 2 previous commits:
- foreach_with_prefix is simplified (foreach handles break and continue), and
- PR34553 is fixed in foreach_with_prefix (added -level increment).

It now looks like this:
...
proc foreach_with_prefix {var list body} {
    upvar 1 $var myvar
    catch {
        foreach myvar $list {
            with_test_prefix "$var=$myvar" {
                uplevel 1 $body
            }
        }
    } result opts
    return -options [dict incr opts -level] $result
...

However, IWBN to use transparent_uplevel, which ideally should replace the
catch, the uplevel and the -level increment.

I finally came up with this solution:
...
    transparent_uplevel [subst_vars {
	foreach $var {$list} {
	    with_test_prefix "$var=[set $var]" {
		$body
 	    }
 	}
    }]
...
which also gets rid of the myvar.

The only gotcha is that the implementation is wrapped in [subst_vars {}],
which provides a way to get values of variables defined in:
- the foreach_with_prefix using $var, and
- the caller using [set var].
---
 gdb/testsuite/lib/gdb.exp | 12 +++++-------
 1 file changed, 5 insertions(+), 7 deletions(-)

diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index cad1ac65913..589e25a12e1 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -3356,15 +3356,13 @@ proc with_test_prefix { prefix body } {
 # including the iterator's name and current value in the prefix.
 
 proc foreach_with_prefix {var list body} {
-    upvar 1 $var myvar
-    catch {
-	foreach myvar $list {
-	    with_test_prefix "$var=$myvar" {
-		uplevel 1 $body
+    transparent_uplevel [subst_vars {
+	foreach $var {$list} {
+	    with_test_prefix "$var=[set $var]" {
+		$body
 	    }
 	}
-    } result opts
-    return -options [dict incr opts -level] $result
+    }]
 }
 
 # Like TCL's native proc, but defines a procedure that wraps its body

base-commit: 0b17fe8b941e1b95535caa61664e96b19c607777
-- 
2.51.0

[pushed 2/3] [gdb/testsuite] Add gdb.testsuite/foreach_with_prefix-2.exp

[Tom de Vries]

Add test-case gdb.testsuite/foreach_with_prefix-2.exp.

It tests the foreach_with_prefix construct, similar to how test-case
gdb.testsuite/transparent-uplevel.exp does.
---
 .../gdb.testsuite/foreach_with_prefix-2.exp   | 102 ++++++++++++++++++
 1 file changed, 102 insertions(+)
 create mode 100644 gdb/testsuite/gdb.testsuite/foreach_with_prefix-2.exp

diff --git a/gdb/testsuite/gdb.testsuite/foreach_with_prefix-2.exp b/gdb/testsuite/gdb.testsuite/foreach_with_prefix-2.exp
new file mode 100644
index 00000000000..861aa2e50f7
--- /dev/null
+++ b/gdb/testsuite/gdb.testsuite/foreach_with_prefix-2.exp
@@ -0,0 +1,102 @@
+# 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/>.
+
+set stmts \
+    [list \
+	 {} \
+	 "error foo" \
+	 return \
+	 break \
+	 continue \
+	 "return -code ok" \
+	 "return -code error" \
+	 "return -code return" \
+	 "return -code break" \
+	 "return -code continue" \
+	 "return -code ok -level 0" \
+	 "return -code ok -level 1" \
+	 "return -code ok -level 2" \
+	 "return -code error -level 0" \
+	 "return -code error -level 1" \
+	 "return -code error -level 2" \
+	 "return -code return -level 0" \
+	 "return -code return -level 1" \
+	 "return -code return -level 2" \
+	 "return -code break -level 0" \
+	 "return -code break -level 1" \
+	 "return -code break -level 2" \
+	 "return -code continue -level 0" \
+	 "return -code continue -level 1" \
+	 "return -code continue -level 2"]
+
+foreach stmt $stmts {
+    verbose -log "STMT: $stmt"
+
+    set counter 0
+    set res1 [catch {
+	incr counter 1
+	foreach i {1 2 3} {
+	    incr counter 10
+	    if {$i == 2} {
+		{*}$stmt
+	    }
+	    incr counter 100
+	}
+	incr counter 1000
+    } script_res1 opts1]
+    set counter1 $counter
+
+    set counter 0
+    set res2 [catch {
+	incr counter 1
+	foreach_with_prefix i {1 2 3} {
+	    incr counter 10
+	    if {$i == 2} {
+		{*}$stmt
+	    }
+	    incr counter 100
+	}
+	incr counter 1000
+    } script_res2 opts2]
+    set counter2 $counter
+
+    verbose -log "COUNTER1: $counter1"
+    verbose -log "COUNTER2: $counter2"
+    gdb_assert {$counter1 == $counter2} "$stmt: counter"
+
+    verbose -log "RES1: $res1"
+    verbose -log "RES2: $res2"
+    gdb_assert {$res1 == $res2} "$stmt: res"
+
+    verbose -log "SCRIPT_RES1: '$script_res1'"
+    verbose -log "SCRIPT_RES2: '$script_res2'"
+    gdb_assert {$script_res1 == $script_res2} "$stmt: script_res"
+
+    # Note: we skip -errorinfo and -errorstack here.  These differ for
+    # something like "error foo", and they should.  When it comes to errors,
+    # we're not trying to hide the indirection.
+    foreach key {-code -level -errorcode} {
+	set v1 {}
+	set v2 {}
+	if {[dict exists $opts1 $key]} {
+	    set v1 [dict get $opts1 $key]
+	}
+	if {[dict exists $opts2 $key]} {
+	    set v2 [dict get $opts2 $key]
+	}
+	verbose -log "KEY: $key, V1: $v1"
+	verbose -log "KEY: $key, V2: $v2"
+	gdb_assert {$v1 == $v2} "$stmt: opts: $key"
+    }
+}
-- 
2.51.0

[pushed 3/3] [gdb/testsuite] Simplify foreach_mi_ui_mode

[Tom de Vries]

Simplify foreach_mi_ui_mode using transparent_uplevel and foreach_with_prefix.
---
 gdb/testsuite/lib/mi-support.exp | 13 ++++---------
 1 file changed, 4 insertions(+), 9 deletions(-)

diff --git a/gdb/testsuite/lib/mi-support.exp b/gdb/testsuite/lib/mi-support.exp
index 240bc844350..cd7e0a61189 100644
--- a/gdb/testsuite/lib/mi-support.exp
+++ b/gdb/testsuite/lib/mi-support.exp
@@ -2922,8 +2922,6 @@ proc mi_get_valueof { fmt exp default {test ""} } {
 # BODY will be run just once with MODE set to 'main'.
 
 proc foreach_mi_ui_mode { var_name body } {
-    upvar 1 $var_name var
-
     if {[gdb_debug_enabled]} {
        # gdb debug doesn't work for separate-mi-tty.
        set modes {"main"}
@@ -2931,14 +2929,11 @@ proc foreach_mi_ui_mode { var_name body } {
        set modes {"main" "separate"}
     }
 
-    catch {
-	foreach var $modes {
-	    with_test_prefix "$var_name=$var" {
-		uplevel 1 $body
-	    }
+    transparent_uplevel [subst_vars {
+	foreach_with_prefix $var_name {$modes} {
+	    $body
 	}
-    } result opts
-    return -options [dict incr opts -level] $result
+    }]
 }
 
 # Check if GDB has information about the stderr symbol.
-- 
2.51.0