[PATCH 04/11] [gdb/testsuite] Refactor exception handling in foreach_with_prefix

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

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