[PATCH 00/11] [gdb/testsuite] Refactor exception handling

[PATCH 00/11] [gdb/testsuite] Refactor exception handling

[Tom de Vries]

This patch series does two things:
- use modern exception handling constructs like try/finally and
  "return -options" (PR34552).
- fix bug in "return -level 2" handling (PR34553).

Tested on x86_64-linux.

Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34552
Bug: https://sourceware.org/bugzilla/show_bug.cgi?id=34553

Tom de Vries (11):
  [gdb/testsuite] Normalize indentation in with_test_prefix
  [gdb/testsuite] Fix return -level 2 bug in with_test_prefix
  [gdb/testsuite] Simplify foreach_with_prefix
  [gdb/testsuite] Refactor exception handling in foreach_with_prefix
  [gdb/testsuite] Add transparent_uplevel
  [gdb/testsuite] Refactor exception handling
  [gdb/testsuite] Refactor exception handling in gdb_expect
  [gdb/testsuite] Refactor exception handling in gdb_test_multiple
  [gdb/testsuite] Refactor exception handling in
    lock_file_acquire/release
  [gdb/testsuite] Refactor exception handling in tentative_rename
  [gdb/testsuite] Refactor exception handling in with_stub_devices

 gdb/testsuite/gdb.rocm/hcc-amdgpu-targets.exp |  15 +-
 .../gdb.testsuite/foreach_with_prefix.exp     |  27 ++
 gdb/testsuite/gdb.testsuite/gdb-test.exp      |  51 ++
 .../gdb.testsuite/with-test-prefix.exp        |  45 ++
 gdb/testsuite/lib/ada.exp                     |  14 +-
 gdb/testsuite/lib/dwarf.exp                   |  15 +-
 gdb/testsuite/lib/gdb-utils.exp               |  45 +-
 gdb/testsuite/lib/gdb.exp                     | 449 ++++++++----------
 gdb/testsuite/lib/mi-support.exp              |  22 +-
 gdb/testsuite/lib/tuiterm.exp                 |  15 +-
 10 files changed, 383 insertions(+), 315 deletions(-)
 create mode 100644 gdb/testsuite/gdb.testsuite/with-test-prefix.exp


base-commit: 7063b767cc9c2774e7ead41144e5613bacad6a0d
-- 
2.51.0

[PATCH 01/11] [gdb/testsuite] Normalize indentation in with_test_prefix

[Tom de Vries]

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

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

[Tom de Vries]

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

[PATCH 03/11] [gdb/testsuite] Simplify foreach_with_prefix

[Tom de Vries]

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

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

[Tom de Vries]

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

[PATCH 05/11] [gdb/testsuite] Add transparent_uplevel

[Tom de Vries]

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

[PATCH 06/11] [gdb/testsuite] Refactor exception handling

[Tom de Vries]

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

[PATCH 07/11] [gdb/testsuite] Refactor exception handling in gdb_expect

[Tom de Vries]

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

[PATCH 08/11] [gdb/testsuite] Refactor exception handling in gdb_test_multiple

[Tom de Vries]

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

[PATCH 09/11] [gdb/testsuite] Refactor exception handling in lock_file_acquire/release

[Tom de Vries]

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

[PATCH 10/11] [gdb/testsuite] Refactor exception handling in tentative_rename

[Tom de Vries]

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

[PATCH 11/11] [gdb/testsuite] Refactor exception handling in with_stub_devices

[Tom de Vries]

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

Re: [PATCH 08/11] [gdb/testsuite] Refactor exception handling in gdb_test_multiple

[Tom de Vries]

On 8/24/26 3:58 PM, Tom de Vries wrote:
> implify 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].
> 

I heard back from the dejagnu maintainers, who acknowledged the bug.

The current stable release is 1.6.3.  Since the currently envisioned fix 
breaks 8.4 support, it's scheduled for 1.6.5 rather than 1.6.4.

I proposed a fix that keeps backward compatibility, allowing it to be 
fixed in 1.6.4.

We could copy a version into lib/future.exp to have it fixed faster, but 
I don't see the need for this.  AFAIK we're currently not relying on this.

Thanks,
- Tom

> 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