-# Copyright 1992-2020 Free Software Foundation, Inc.
+# Copyright 1992-2021 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
exit 2
}
+# List of procs to run in gdb_finish.
+set gdb_finish_hooks [list]
+
+# Variable in which we keep track of globals that are allowed to be live
+# across test-cases.
+array set gdb_persistent_globals {}
+
+# Mark variable names in ARG as a persistent global, and declare them as
+# global in the calling context. Can be used to rewrite "global var_a var_b"
+# into "gdb_persistent_global var_a var_b".
+proc gdb_persistent_global { args } {
+ global gdb_persistent_globals
+ foreach varname $args {
+ uplevel 1 global $varname
+ set gdb_persistent_globals($varname) 1
+ }
+}
+
+# Mark variable names in ARG as a persistent global.
+proc gdb_persistent_global_no_decl { args } {
+ global gdb_persistent_globals
+ foreach varname $args {
+ set gdb_persistent_globals($varname) 1
+ }
+}
+
+# Override proc load_lib.
+rename load_lib saved_load_lib
+# Run the runtest version of load_lib, and mark all variables that were
+# created by this call as persistent.
+proc load_lib { file } {
+ array set known_global {}
+ foreach varname [info globals] {
+ 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
+ }
+
+ return $result
+}
+
load_lib libgloss.exp
load_lib cache.exp
load_lib gdb-utils.exp
load_lib memory.exp
+load_lib check-test-names.exp
global GDB
# INTERNAL_GDBFLAGS contains flags that the testsuite requires.
global INTERNAL_GDBFLAGS
if ![info exists INTERNAL_GDBFLAGS] {
- set INTERNAL_GDBFLAGS "-nw -nx -data-directory $BUILD_DATA_DIRECTORY"
+ set INTERNAL_GDBFLAGS \
+ [join [list \
+ "-nw" \
+ "-nx" \
+ "-data-directory $BUILD_DATA_DIRECTORY" \
+ {-iex "set height 0"} \
+ {-iex "set width 0"}]]
}
# The variable gdb_prompt is a regexp which matches the gdb prompt.
# Generic run command.
#
+# Return 0 if we could start the program, -1 if we could not.
+#
# The second pattern below matches up to the first newline *only*.
# Using ``.*$'' could swallow up output that we attempt to match
# elsewhere.
#
+# INFERIOR_ARGS is passed as arguments to the start command, so may contain
+# inferior arguments.
+#
# N.B. This function does not wait for gdb to return to the prompt,
# that is the caller's responsibility.
-proc gdb_run_cmd {args} {
+proc gdb_run_cmd { {inferior_args {}} } {
global gdb_prompt use_gdb_stub
foreach command [gdb_init_commands] {
if $use_gdb_stub {
if [target_info exists gdb,do_reload_on_run] {
- if { [gdb_reload] != 0 } {
- return
+ if { [gdb_reload $inferior_args] != 0 } {
+ return -1
}
send_gdb "continue\n"
gdb_expect 60 {
-re "Continu\[^\r\n\]*\[\r\n\]" {}
default {}
}
- return
+ return 0
}
if [target_info exists gdb,start_symbol] {
# clever and not send a command when it has failed.
if [expr $start_attempt > 3] {
perror "Jump to start() failed (retry count exceeded)"
- return
+ return -1
}
set start_attempt [expr $start_attempt + 1]
gdb_expect 30 {
}
-re "No symbol \"_start\" in current.*$gdb_prompt $" {
perror "Can't find start symbol to run in gdb_run"
- return
+ return -1
}
-re "No symbol \"start\" in current.*$gdb_prompt $" {
send_gdb "jump *_start\n"
send_gdb "y\n" answer
}
-re "The program is not being run.*$gdb_prompt $" {
- if { [gdb_reload] != 0 } {
- return
+ if { [gdb_reload $inferior_args] != 0 } {
+ return -1
}
send_gdb "jump *$start\n"
}
timeout {
perror "Jump to start() failed (timeout)"
- return
+ return -1
}
}
}
- return
+
+ return 0
}
if [target_info exists gdb,do_reload_on_run] {
- if { [gdb_reload] != 0 } {
- return
+ if { [gdb_reload $inferior_args] != 0 } {
+ return -1
}
}
- send_gdb "run $args\n"
+ send_gdb "run $inferior_args\n"
# This doesn't work quite right yet.
# Use -notransfer here so that test cases (like chng-sym.exp)
# may test for additional start-up messages.
# There is no more input expected.
}
}
+
+ return 0
}
# Generic start command. Return 0 if we could start the program, -1
# if we could not.
#
+# INFERIOR_ARGS is passed as arguments to the start command, so may contain
+# inferior arguments.
+#
# N.B. This function does not wait for gdb to return to the prompt,
# that is the caller's responsibility.
-proc gdb_start_cmd {args} {
+proc gdb_start_cmd { {inferior_args {}} } {
global gdb_prompt use_gdb_stub
foreach command [gdb_init_commands] {
return -1
}
- send_gdb "start $args\n"
+ send_gdb "start $inferior_args\n"
# Use -notransfer here so that test cases (like chng-sym.exp)
# may test for additional start-up messages.
gdb_expect 60 {
# Generic starti command. Return 0 if we could start the program, -1
# if we could not.
#
+# INFERIOR_ARGS is passed as arguments to the starti command, so may contain
+# inferior arguments.
+#
# N.B. This function does not wait for gdb to return to the prompt,
# that is the caller's responsibility.
-proc gdb_starti_cmd {args} {
+proc gdb_starti_cmd { {inferior_args {}} } {
global gdb_prompt use_gdb_stub
foreach command [gdb_init_commands] {
return -1
}
- send_gdb "starti $args\n"
+ send_gdb "starti $inferior_args\n"
gdb_expect 60 {
-re "The program .* has been started already.*y or n. $" {
send_gdb "y\n" answer
# Set a breakpoint at FUNCTION. If there is an additional argument it is
# a list of options; the supported options are allow-pending, temporary,
-# message, no-message, passfail and qualified.
+# message, no-message and qualified.
# The result is 1 for success, 0 for failure.
#
# Note: The handling of message vs no-message is messed up, but it's based
return 0
}
eof {
+ perror "GDB process no longer exists"
+ global gdb_spawn_id
+ set wait_status [wait -i $gdb_spawn_id]
+ verbose -log "GDB process exited with wait status $wait_status"
if { $print_fail } {
fail "$test_name (eof)"
}
return 0
}
-re ".*A problem internal to GDB has been detected" {
- if { $print_fail } {
- fail "$test_name (GDB internal error)"
- }
+ # Always emit a FAIL if we encounter an internal error: internal
+ # errors are never expected.
+ fail "$test_name (GDB internal error)"
gdb_internal_error_resync
return 0
}
# If you don't want that, use gdb_start_cmd.
proc runto_main { } {
- return [runto main no-message]
+ return [runto main no-message qualified]
}
### Continue, and expect to hit a breakpoint.
}
-# gdb_test_multiple COMMAND MESSAGE [ -promp PROMPT_REGEXP] [ -lbl ]
+# gdb_test_multiple COMMAND MESSAGE [ -prompt PROMPT_REGEXP] [ -lbl ]
# EXPECT_ARGUMENTS
# Send a command to gdb; test the result.
#
if { $foo < [expr $len - 1] } {
set str [string range "$string" 0 $foo]
if { [send_gdb "$str"] != "" } {
- global suppress_flag
-
- if { ! $suppress_flag } {
- perror "Couldn't send $command to GDB."
- }
- fail "$message"
- return $result
+ perror "Couldn't send $command to GDB."
}
# since we're checking if each line of the multi-line
# command are 'accepted' by GDB here,
}
if { "$string" != "" } {
if { [send_gdb "$string"] != "" } {
- global suppress_flag
-
- if { ! $suppress_flag } {
- perror "Couldn't send $command to GDB."
- }
- fail "$message"
- return $result
+ perror "Couldn't send $command to GDB."
}
}
}
+ drain_gdbserver_output
+
set code $early_processed_code
append code {
-re ".*A problem internal to GDB has been detected" {
if { $message != "" } {
fail "$message"
}
- gdb_suppress_entire_file "GDB died"
set result -1
}
}
return $result
}
+# Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ...
+# Run a test named NAME, consisting of multiple lines of input.
+# After each input line INPUT, search for result line RESULT.
+# Succeed if all results are seen; fail otherwise.
+
+proc gdb_test_multiline { name args } {
+ global gdb_prompt
+ set inputnr 0
+ foreach {input result} $args {
+ incr inputnr
+ if {[gdb_test_multiple $input "$name: input $inputnr: $input" {
+ -re "\[\r\n\]*($result)\[\r\n\]+($gdb_prompt | *>)$" {
+ pass $gdb_test_name
+ }
+ }]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+
# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
# Send a command to gdb; test the result.
#
# EXPECTED_OUTPUT_LIST is a list of regexps of expected output, which are
# processed in order, and all must be present in the output.
#
+# The -prompt switch can be used to override the prompt expected at the end of
+# the output sequence.
+#
# It is unnecessary to specify ".*" at the beginning or end of any regexp,
# there is an implicit ".*" between each element of EXPECTED_OUTPUT_LIST.
# There is also an implicit ".*" between the last regexp and the gdb prompt.
# 0 if the test passes,
# -1 if there was an internal error.
-proc gdb_test_sequence { command test_name expected_output_list } {
+proc gdb_test_sequence { args } {
global gdb_prompt
+
+ parse_args {{prompt ""}}
+
+ if { $prompt == "" } {
+ set prompt "$gdb_prompt $"
+ }
+
+ if { [llength $args] != 3 } {
+ error "Unexpected # of arguments, expecting: COMMAND TEST_NAME EXPECTED_OUTPUT_LIST"
+ }
+
+ lassign $args command test_name expected_output_list
+
if { $test_name == "" } {
set test_name $command
}
+
lappend expected_output_list ""; # implicit ".*" before gdb prompt
+
if { $command != "" } {
send_gdb "$command\n"
}
- return [gdb_expect_list $test_name "$gdb_prompt $" $expected_output_list]
+
+ return [gdb_expect_list $test_name $prompt $expected_output_list]
}
\f
+# Match output of COMMAND using RE. Read output line-by-line.
+# Report pass/fail with MESSAGE.
+# For a command foo with output:
+# (gdb) foo^M
+# <line1>^M
+# <line2>^M
+# (gdb)
+# the portion matched using RE is:
+# '<line1>^M
+# <line2>^M
+# '
+
+proc gdb_test_lines { command message re } {
+ set found 0
+ set idx 0
+ if { $message == ""} {
+ set message $command
+ }
+ set lines ""
+ gdb_test_multiple $command $message {
+ -re "\r\n(\[^\r\n\]*)(?=\r\n)" {
+ set line $expect_out(1,string)
+ if { $lines eq "" } {
+ append lines "$line"
+ } else {
+ append lines "\r\n$line"
+ }
+ exp_continue
+ }
+ -re -wrap "" {
+ append lines "\r\n"
+ }
+ }
+
+ gdb_assert { [regexp $re $lines] } $message
+}
+
# Test that a command gives an error. For pass or fail, return
# a 1 to indicate that more tests can proceed. However a timeout
# is a serious error, generates a special fail message, and causes
return $res
}
+# Wrapper around gdb_test_multiple to be used when testing expression
+# evaluation while 'set debug expression 1' is in effect.
+# Looks for some patterns that indicates the expression was rejected.
+#
+# CMD is the command to execute, which should include an expression
+# that GDB will need to parse.
+#
+# OUTPUT is the expected output pattern.
+#
+# TESTNAME is the name to be used for the test, defaults to CMD if not
+# given.
+proc gdb_test_debug_expr { cmd output {testname "" }} {
+ global gdb_prompt
+
+ if { ${testname} == "" } {
+ set testname $cmd
+ }
+
+ gdb_test_multiple $cmd $testname {
+ -re ".*Invalid expression.*\r\n$gdb_prompt $" {
+ fail $gdb_test_name
+ }
+ -re ".*\[\r\n\]$output\r\n$gdb_prompt $" {
+ pass $gdb_test_name
+ }
+ }
+}
+
# get_print_expr_at_depths EXP OUTPUTS
#
# Used for testing 'set print max-depth'. Prints the expression EXP
set message $condition
}
- set res [uplevel 1 expr $condition]
- if {!$res} {
+ set code [catch {uplevel 1 expr $condition} res]
+ if {$code == 1} {
+ # If code is 1 (TCL_ERROR), it means evaluation failed and res contains
+ # an error message. Print the error message, and set res to 0 since we
+ # want to return a boolean.
+ warning "While evaluating expression in gdb_assert: $res"
+ unresolved $message
+ set res 0
+ } elseif { !$res } {
fail $message
} else {
pass $message
global gdb_spawn_id inferior_spawn_id
global inotify_log_file
- gdb_stop_suppressing_tests
-
if ![info exists gdb_spawn_id] {
return
}
remote_close host
}
unset gdb_spawn_id
+ unset ::gdb_tty_name
unset inferior_spawn_id
}
# compiled in
# fail file was not loaded
#
+# This procedure also set the global variable GDB_FILE_CMD_MSG to the
+# output of the file command in case of success.
+#
# I tried returning this information as part of the return value,
# but ran into a mess because of the many re-implementations of
# gdb_load in config/*.exp.
global GDB
global last_loaded_file
+ # GCC for Windows target may create foo.exe given "-o foo".
+ if { ![file exists $arg] && [file exists "$arg.exe"] } {
+ set arg "$arg.exe"
+ }
+
# Save this for the benefit of gdbserver-support.exp.
set last_loaded_file $arg
# Set whether debug info was found.
# Default to "fail".
- global gdb_file_cmd_debug_info
+ global gdb_file_cmd_debug_info gdb_file_cmd_msg
set gdb_file_cmd_debug_info "fail"
if [is_remote host] {
}
send_gdb "file $arg\n"
+ set new_symbol_table 0
+ set basename [file tail $arg]
gdb_expect 120 {
- -re "Reading symbols from.*LZMA support was disabled.*$gdb_prompt $" {
+ -re "(Reading symbols from.*LZMA support was disabled.*$gdb_prompt $)" {
verbose "\t\tLoaded $arg into $GDB; .gnu_debugdata found but no LZMA available"
+ set gdb_file_cmd_msg $expect_out(1,string)
set gdb_file_cmd_debug_info "lzma"
return 0
}
- -re "Reading symbols from.*no debugging symbols found.*$gdb_prompt $" {
+ -re "(Reading symbols from.*no debugging symbols found.*$gdb_prompt $)" {
verbose "\t\tLoaded $arg into $GDB with no debugging symbols"
+ set gdb_file_cmd_msg $expect_out(1,string)
set gdb_file_cmd_debug_info "nodebug"
return 0
}
- -re "Reading symbols from.*$gdb_prompt $" {
+ -re "(Reading symbols from.*$gdb_prompt $)" {
verbose "\t\tLoaded $arg into $GDB"
+ set gdb_file_cmd_msg $expect_out(1,string)
set gdb_file_cmd_debug_info "debug"
return 0
}
-re "Load new symbol table from \".*\".*y or n. $" {
+ if { $new_symbol_table > 0 } {
+ perror [join [list "Couldn't load $basename,"
+ "interactive prompt loop detected."]]
+ return -1
+ }
send_gdb "y\n" answer
- gdb_expect 120 {
- -re "Reading symbols from.*$gdb_prompt $" {
- verbose "\t\tLoaded $arg with new symbol table into $GDB"
- set gdb_file_cmd_debug_info "debug"
- return 0
- }
- timeout {
- perror "Couldn't load $arg, other program already loaded (timeout)."
- return -1
- }
- eof {
- perror "Couldn't load $arg, other program already loaded (eof)."
- return -1
- }
- }
+ incr new_symbol_table
+ set suffix "-- with new symbol table"
+ set arg "$arg $suffix"
+ set basename "$basename $suffix"
+ exp_continue
}
-re "No such file or directory.*$gdb_prompt $" {
- perror "($arg) No such file or directory"
+ perror "($basename) No such file or directory"
return -1
}
-re "A problem internal to GDB has been detected" {
- fail "($arg) (GDB internal error)"
+ perror "Couldn't load $basename into GDB (GDB internal error)."
gdb_internal_error_resync
return -1
}
-re "$gdb_prompt $" {
- perror "Couldn't load $arg into $GDB."
+ perror "Couldn't load $basename into GDB."
return -1
}
timeout {
- perror "Couldn't load $arg into $GDB (timeout)."
+ perror "Couldn't load $basename into GDB (timeout)."
return -1
}
eof {
# This is an attempt to detect a core dump, but seems not to
# work. Perhaps we need to match .* followed by eof, in which
# gdb_expect does not seem to have a way to do that.
- perror "Couldn't load $arg into $GDB (eof)."
+ perror "Couldn't load $basename into GDB (eof)."
return -1
}
}
}
+# The expect "spawn" function puts the tty name into the spawn_out
+# array; but dejagnu doesn't export this globally. So, we have to
+# wrap spawn with our own function and poke in the built-in spawn
+# so that we can capture this value.
+#
+# If available, the TTY name is saved to the LAST_SPAWN_TTY_NAME global.
+# Otherwise, LAST_SPAWN_TTY_NAME is unset.
+
+proc spawn_capture_tty_name { args } {
+ set result [uplevel builtin_spawn $args]
+ upvar spawn_out spawn_out
+ if { [info exists spawn_out] } {
+ set ::last_spawn_tty_name $spawn_out(slave,name)
+ } else {
+ unset ::last_spawn_tty_name
+ }
+ return $result
+}
+
+rename spawn builtin_spawn
+rename spawn_capture_tty_name spawn
+
# Default gdb_spawn procedure.
proc default_gdb_spawn { } {
global INTERNAL_GDBFLAGS GDBFLAGS
global gdb_spawn_id
- gdb_stop_suppressing_tests
-
# Set the default value, it may be overriden later by specific testfile.
#
# Use `set_board_info use_gdb_stub' for the board file to flag the inferior
}
set gdb_spawn_id $res
+ set ::gdb_tty_name $::last_spawn_tty_name
return 0
}
unset gdb_spawn_id
return -1
}
+ eof {
+ perror "(eof) GDB never initialized."
+ unset gdb_spawn_id
+ return -1
+ }
}
# force the height to "unlimited", so no pagers get used
# Examine the output of compilation to determine whether compilation
# failed or not. If it failed determine whether it is due to missing
# compiler or due to compiler error. Report pass, fail or unsupported
-# as appropriate
+# as appropriate.
proc gdb_compile_test {src output} {
+ set msg "compilation [file tail $src]"
+
if { $output == "" } {
- pass "compilation [file tail $src]"
- } elseif { [regexp {^[a-zA-Z_0-9]+: Can't find [^ ]+\.$} $output] } {
- unsupported "compilation [file tail $src]"
- } elseif { [regexp {.*: command not found[\r|\n]*$} $output] } {
- unsupported "compilation [file tail $src]"
- } elseif { [regexp {.*: [^\r\n]*compiler not installed[^\r\n]*[\r|\n]*$} $output] } {
- unsupported "compilation [file tail $src]"
- } else {
- verbose -log "compilation failed: $output" 2
- fail "compilation [file tail $src]"
+ pass $msg
+ return
+ }
+
+ if { [regexp {^[a-zA-Z_0-9]+: Can't find [^ ]+\.$} $output]
+ || [regexp {.*: command not found[\r|\n]*$} $output]
+ || [regexp {.*: [^\r\n]*compiler not installed[^\r\n]*[\r|\n]*$} $output] } {
+ unsupported "$msg (missing compiler)"
+ return
+ }
+
+ set gcc_re ".*: error: unrecognized command line option "
+ set clang_re ".*: error: unsupported option "
+ if { [regexp "(?:$gcc_re|$clang_re)(\[^ \t;\r\n\]*)" $output dummy option]
+ && $option != "" } {
+ unsupported "$msg (unsupported option $option)"
+ return
}
+
+ # Unclassified compilation failure, be more verbose.
+ verbose -log "compilation failed: $output" 2
+ fail "$msg"
}
# Return a 1 for configurations for which we don't even want to try to
# Return a 1 for configurations for which don't have both C++ and the STL.
proc skip_stl_tests {} {
- # Symbian supports the C++ language, but the STL is missing
- # (both headers and libraries).
- if { [istarget "arm*-*-symbianelf*"] } {
- return 1
- }
-
return [skip_cplus_tests]
}
# Return 1 to skip Rust tests, 0 to try them.
proc skip_rust_tests {} {
- return [expr {![isnative]}]
+ if { ![isnative] } {
+ return 1
+ }
+
+ # The rust compiler does not support "-m32", skip.
+ global board board_info
+ set board [target_info name]
+ if {[board_info $board exists multilib_flags]} {
+ foreach flag [board_info $board multilib_flags] {
+ if { $flag == "-m32" } {
+ return 1
+ }
+ }
+ }
+
+ return 0
}
# Return a 1 for configurations that do not support Python scripting.
if {([istarget *-*-linux*]
|| [istarget *-*-*bsd*]
|| [istarget *-*-solaris2*]
- || [istarget arm*-*-symbianelf*]
|| [istarget *-*-mingw*]
|| [istarget *-*-cygwin*]
|| [istarget *-*-pe*])} {
}
}
+# As save_vars, but for variables stored in the board_info for the
+# target board.
+#
+# Usage example:
+#
+# save_target_board_info { multilib_flags } {
+# global board
+# set board [target_info name]
+# unset_board_info multilib_flags
+# set_board_info multilib_flags "$multilib_flags"
+# ...
+# }
+
+proc save_target_board_info { vars body } {
+ global board board_info
+ set board [target_info name]
+
+ array set saved_target_board_info { }
+ set unset_target_board_info { }
+
+ foreach var $vars {
+ if { [info exists board_info($board,$var)] } {
+ set saved_target_board_info($var) [board_info $board $var]
+ } else {
+ lappend unset_target_board_info $var
+ }
+ }
+
+ 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
+ }
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+
# Run tests in BODY with the current working directory (CWD) set to
# DIR. When BODY is finished, restore the original CWD. Return the
# result of BODY.
}
}
+# Return 1 if memory tagging is supported at runtime, otherwise return 0.
+
+gdb_caching_proc supports_memtag {
+ global gdb_prompt
+
+ gdb_test_multiple "memory-tag check" "" {
+ -re "Memory tagging not supported or disabled by the current architecture\..*$gdb_prompt $" {
+ return 0
+ }
+ -re "Argument required \\(address or pointer\\).*$gdb_prompt $" {
+ return 1
+ }
+ }
+ return 0
+}
+
# Return 1 if the target supports hardware single stepping.
proc can_hardware_single_step {} {
return $skip_vmx_tests
}
+# Run a test on the power target to see if it supports ISA 3.1 instructions
+gdb_caching_proc skip_power_isa_3_1_tests {
+ global srcdir subdir gdb_prompt inferior_exited_re
+
+ set me "skip_power_isa_3_1_tests"
+
+ # Compile a test program containing ISA 3.1 instructions.
+ set src {
+ int main() {
+ asm volatile ("pnop"); // marker
+ asm volatile ("nop");
+ return 0;
+ }
+ }
+
+ if {![gdb_simple_compile $me $src executable ]} {
+ return 1
+ }
+
+ # No error message, compilation succeeded so now run it via gdb.
+
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load "$obj"
+ gdb_run_cmd
+ gdb_expect {
+ -re ".*Illegal instruction.*${gdb_prompt} $" {
+ verbose -log "\n$me Power ISA 3.1 hardware not detected"
+ set skip_power_isa_3_1_tests 1
+ }
+ -re ".*$inferior_exited_re normally.*${gdb_prompt} $" {
+ verbose -log "\n$me: Power ISA 3.1 hardware detected"
+ set skip_power_isa_3_1_tests 0
+ }
+ default {
+ warning "\n$me: default case taken"
+ set skip_power_isa_3_1_tests 1
+ }
+ }
+ gdb_exit
+ remote_file build delete $obj
+
+ verbose "$me: returning $skip_power_isa_3_1_tests" 2
+ return $skip_power_isa_3_1_tests
+}
+
# Run a test on the target to see if it supports vmx hardware. Return 0 if so,
# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite.
return $skip_tsx_tests
}
+# Run a test on the target to see if it supports avx512bf16. Return 0 if so,
+# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite.
+
+gdb_caching_proc skip_avx512bf16_tests {
+ global srcdir subdir gdb_prompt inferior_exited_re
+
+ set me "skip_avx512bf16_tests"
+ if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } {
+ verbose "$me: target does not support avx512bf16, returning 1" 2
+ return 1
+ }
+
+ # Compile a test program.
+ set src {
+ int main() {
+ asm volatile ("vcvtne2ps2bf16 %xmm0, %xmm1, %xmm0");
+ return 0;
+ }
+ }
+ if {![gdb_simple_compile $me $src executable]} {
+ return 1
+ }
+
+ # No error message, compilation succeeded so now run it via gdb.
+
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load "$obj"
+ gdb_run_cmd
+ gdb_expect {
+ -re ".*Illegal instruction.*${gdb_prompt} $" {
+ verbose -log "$me: avx512bf16 hardware not detected."
+ set skip_avx512bf16_tests 1
+ }
+ -re ".*$inferior_exited_re normally.*${gdb_prompt} $" {
+ verbose -log "$me: avx512bf16 hardware detected."
+ set skip_avx512bf16_tests 0
+ }
+ default {
+ warning "\n$me: default case taken."
+ set skip_avx512bf16_tests 1
+ }
+ }
+ gdb_exit
+ remote_file build delete $obj
+
+ verbose "$me: returning $skip_avx512bf16_tests" 2
+ return $skip_avx512bf16_tests
+}
+
# Run a test on the target to see if it supports btrace hardware. Return 0 if so,
# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite.
# This is the preferred way of checking use_gdb_stub, since it allows to check
# the value before the gdb has been spawned and it will return the correct value
# even when it was overriden by the test.
+#
+# Note that stub targets are not able to spawn new inferiors. Use this
+# check for skipping respective tests.
proc use_gdb_stub {} {
global use_gdb_stub
return [string match $compiler $compiler_info]
}
-proc current_target_name { } {
+# Return the gcc major version, or -1.
+# For gcc 4.8.5, the major version is 4.8.
+# For gcc 7.5.0, the major version 7.
+
+proc gcc_major_version { } {
+ global compiler_info
+ global decimal
+ if { ![test_compiler_info "gcc-*"] } {
+ return -1
+ }
+ set res [regexp gcc-($decimal)-($decimal)- $compiler_info \
+ dummy_var major minor]
+ if { $res != 1 } {
+ return -1
+ }
+ if { $major >= 5} {
+ return $major
+ }
+ return $major.$minor
+}
+
+proc current_target_name { } {
global target_info
if [info exists target_info(target,name)] {
set answer $target_info(target,name)
set gdb_wrapper_initialized 0
set gdb_wrapper_target ""
+set gdb_wrapper_file ""
+set gdb_wrapper_flags ""
proc gdb_wrapper_init { args } {
global gdb_wrapper_initialized
global gdb_wrapper_flags
global gdb_wrapper_target
- # If the wrapper is initialized but the wrapper file cannot be
- # found anymore, the wrapper file must be built again.
- if { $gdb_wrapper_initialized == 1 && \
- [info exists gdb_wrapper_file] && \
- ![file exists $gdb_wrapper_file] } {
- verbose "reinitializing the wrapper"
- set gdb_wrapper_initialized 0
- }
-
if { $gdb_wrapper_initialized == 1 } { return; }
if {[target_info exists needs_status_wrapper] && \
[target_info needs_status_wrapper] != "0"} {
- set result [build_wrapper [standard_output_file "testglue.o"]]
+ set result [build_wrapper "testglue.o"]
if { $result != "" } {
set gdb_wrapper_file [lindex $result 0]
+ if ![is_remote host] {
+ set gdb_wrapper_file [file join [pwd] $gdb_wrapper_file]
+ }
set gdb_wrapper_flags [lindex $result 1]
} else {
warning "Status wrapper failed to build."
}
+ } else {
+ set gdb_wrapper_file ""
+ set gdb_wrapper_flags ""
}
+ verbose "set gdb_wrapper_file = $gdb_wrapper_file"
set gdb_wrapper_initialized 1
set gdb_wrapper_target [current_target_name]
}
# - ldflags=flag: Add FLAG to the linker flags.
# - incdir=path: Add PATH to the searched include directories.
# - libdir=path: Add PATH to the linker searched directories.
-# - ada, c++, f77: Compile the file as Ada, C++ or Fortran.
+# - ada, c++, f77, f90, go, rust: Compile the file as Ada, C++,
+# Fortran 77, Fortran 90, Go or Rust.
# - debug: Build with debug information.
# - optimize: Build with optimization.
global GDB_TESTCASE_OPTIONS
global gdb_wrapper_file
global gdb_wrapper_flags
- global gdb_wrapper_initialized
global srcdir
global objdir
global gdb_saved_set_unbuffered_mode_obj
set new_options [universal_compile_options]
}
+ # Some C/C++ testcases unconditionally pass -Wno-foo as additional
+ # options to disable some warning. That is OK with GCC, because
+ # by design, GCC accepts any -Wno-foo option, even if it doesn't
+ # support -Wfoo. Clang however warns about unknown -Wno-foo by
+ # default, unless you pass -Wno-unknown-warning-option as well.
+ # We do that here, so that individual testcases don't have to
+ # worry about it.
+ if {[lsearch -exact $options getting_compiler_info] == -1
+ && [lsearch -exact $options rust] == -1
+ && [lsearch -exact $options ada] == -1
+ && [lsearch -exact $options f77] == -1
+ && [lsearch -exact $options f90] == -1
+ && [lsearch -exact $options go] == -1
+ && [test_compiler_info "clang-*"]} {
+ lappend new_options "additional_flags=-Wno-unknown-warning-option"
+ }
+
+ # Treating .c input files as C++ is deprecated in Clang, so
+ # explicitly force C++ language.
+ if { [lsearch -exact $options getting_compiler_info] == -1
+ && [lsearch -exact $options c++] != -1
+ && [string match *.c $source] != 0 } {
+
+ # gdb_compile cannot handle this combination of options, the
+ # result is a command like "clang -x c++ foo.c bar.so -o baz"
+ # which tells Clang to treat bar.so as C++. The solution is
+ # to call gdb_compile twice--once to compile, once to link--
+ # either directly, or via build_executable_from_specs.
+ if { [lsearch $options shlib=*] != -1 } {
+ error "incompatible gdb_compile options"
+ }
+
+ if {[test_compiler_info "clang-*"]} {
+ lappend new_options early_flags=-x\ c++
+ }
+ }
+
# Place (and look for) Fortran `.mod` files in the output
# directory for this specific test.
if {[lsearch -exact $options f77] != -1 \
|| [lsearch -exact $options f90] != -1 } {
# Fortran compile.
set mod_path [standard_output_file ""]
- lappend new_options "additional_flags=-J${mod_path}"
+ if [test_compiler_info "gcc-*"] {
+ lappend new_options "additional_flags=-J${mod_path}"
+ }
}
set shlib_found 0
# Do not need anything.
} elseif { [istarget *-*-freebsd*] || [istarget *-*-openbsd*] } {
lappend new_options "ldflags=-Wl,-rpath,${outdir}"
- } elseif { [istarget arm*-*-symbianelf*] } {
- if { $shlib_load } {
- lappend new_options "libs=-ldl"
- }
} else {
if { $shlib_load } {
lappend new_options "libs=-ldl"
if {[target_info exists needs_status_wrapper] && \
[target_info needs_status_wrapper] != "0" && \
- [info exists gdb_wrapper_file]} {
+ $gdb_wrapper_file != "" } {
lappend options "libs=${gdb_wrapper_file}"
lappend options "ldflags=${gdb_wrapper_flags}"
}
lappend options "$flag"
}
- # Replace the "nopie" option with the appropriate linker flag to disable
- # PIE executables. There are no compiler flags for this option.
+ # Replace the "nopie" option with the appropriate compiler and linker
+ # flags to disable PIE executables.
set nopie [lsearch -exact $options nopie]
if {$nopie != -1} {
if [target_info exists gdb,nopie_flag] {
- set flag "ldflags=[target_info gdb,nopie_flag]"
+ set flag "additional_flags=[target_info gdb,nopie_flag]"
} else {
- set flag "ldflags=-no-pie"
+ set flag "additional_flags=-fno-pie"
}
set options [lreplace $options $nopie $nopie $flag]
+
+ if [target_info exists gdb,nopie_ldflag] {
+ set flag "ldflags=[target_info gdb,nopie_ldflag]"
+ } else {
+ set flag "ldflags=-no-pie"
+ }
+ lappend options "$flag"
}
if { $type == "executable" } {
# Build a shared library from SOURCES.
-proc gdb_compile_shlib {sources dest options} {
+proc gdb_compile_shlib_1 {sources dest options} {
set obj_options $options
+ set ada 0
+ if { [lsearch -exact $options "ada"] >= 0 } {
+ set ada 1
+ }
+
set info_options ""
if { [lsearch -exact $options "c++"] >= 0 } {
set info_options "c++"
lappend obj_options "additional_flags=-qpic"
}
"clang-*" {
- if { !([istarget "*-*-cygwin*"]
- || [istarget "*-*-mingw*"]) } {
+ if { [istarget "*-*-cygwin*"]
+ || [istarget "*-*-mingw*"] } {
+ lappend obj_options "additional_flags=-fPIC"
+ } else {
lappend obj_options "additional_flags=-fpic"
}
}
"gcc-*" {
- if { !([istarget "powerpc*-*-aix*"]
+ if { [istarget "powerpc*-*-aix*"]
|| [istarget "rs6000*-*-aix*"]
|| [istarget "*-*-cygwin*"]
|| [istarget "*-*-mingw*"]
- || [istarget "*-*-pe*"]) } {
+ || [istarget "*-*-pe*"] } {
+ lappend obj_options "additional_flags=-fPIC"
+ } else {
lappend obj_options "additional_flags=-fpic"
}
}
}
default {
# don't know what the compiler is...
+ lappend obj_options "additional_flags=-fPIC"
}
}
set outdir [file dirname $dest]
set objects ""
foreach source $sources {
- set sourcebase [file tail $source]
if {[file extension $source] == ".o"} {
# Already a .o file.
lappend objects $source
- } elseif {[gdb_compile $source "${outdir}/${sourcebase}.o" object \
- $obj_options] != ""} {
- return -1
+ continue
+ }
+
+ set sourcebase [file tail $source]
+
+ if { $ada } {
+ # Gnatmake doesn't like object name foo.adb.o, use foo.o.
+ set sourcebase [file rootname $sourcebase]
+ }
+ set object ${outdir}/${sourcebase}.o
+
+ if { $ada } {
+ # Use gdb_compile_ada_1 instead of gdb_compile_ada to avoid the
+ # PASS message.
+ if {[gdb_compile_ada_1 $source $object object \
+ $obj_options] != ""} {
+ return -1
+ }
} else {
- lappend objects ${outdir}/${sourcebase}.o
+ if {[gdb_compile $source $object object \
+ $obj_options] != ""} {
+ return -1
+ }
}
+
+ lappend objects $object
}
set link_options $options
+ if { $ada } {
+ # If we try to use gnatmake for the link, it will interpret the
+ # object file as an .adb file. Remove ada from the options to
+ # avoid it.
+ set idx [lsearch $link_options "ada"]
+ set link_options [lreplace $link_options $idx $idx]
+ }
if [test_compiler_info "xlc-*"] {
lappend link_options "additional_flags=-qmkshrobj"
} else {
return ""
}
+# Build a shared library from SOURCES. Ignore target boards PIE-related
+# multilib_flags.
+
+proc gdb_compile_shlib {sources dest options} {
+ global board
+
+ # Ignore PIE-related setting in multilib_flags.
+ set board [target_info name]
+ set multilib_flags_orig [board_info $board multilib_flags]
+ set multilib_flags ""
+ foreach op $multilib_flags_orig {
+ if { $op == "-pie" || $op == "-no-pie" \
+ || $op == "-fPIE" || $op == "-fno-PIE"} {
+ } else {
+ append multilib_flags " $op"
+ }
+ }
+
+ save_target_board_info { multilib_flags } {
+ unset_board_info multilib_flags
+ set_board_info multilib_flags "$multilib_flags"
+ set result [gdb_compile_shlib_1 $sources $dest $options]
+ }
+
+ return $result
+}
+
# This is just like gdb_compile_shlib, above, except that it tries compiling
# against several different thread libraries, to see which one this
# system has.
set why_msg "missing runtime threads library"
}
{^$} {
- pass "successfully compiled posix threads test case"
+ pass "successfully compiled posix threads shlib test case"
set built_binfile 1
break
}
# For options for TYPE see gdb_stdin_log_write
proc send_gdb { string {type standard}} {
- global suppress_flag
- if { $suppress_flag } {
- return "suppressed"
- }
gdb_stdin_log_write $string $type
return [remote_send host "$string"]
}
set tmt [get_largest_timeout]
}
- global suppress_flag
- global remote_suppress_flag
- if [info exists remote_suppress_flag] {
- set old_val $remote_suppress_flag
- }
- if [info exists suppress_flag] {
- if { $suppress_flag } {
- set remote_suppress_flag 1
- }
- }
set code [catch \
{uplevel remote_expect host $tmt $expcode} string]
- if [info exists old_val] {
- set remote_suppress_flag $old_val
- } else {
- if [info exists remote_suppress_flag] {
- unset remote_suppress_flag
- }
- }
if {$code == 1} {
global errorInfo errorCode
proc gdb_expect_list {test sentinel list} {
global gdb_prompt
- global suppress_flag
set index 0
set ok 1
- if { $suppress_flag } {
- set ok 0
- unresolved "${test}"
- }
+
while { ${index} < [llength ${list}] } {
set pattern [lindex ${list} ${index}]
set index [expr ${index} + 1]
}
}
-#
-#
-proc gdb_suppress_entire_file { reason } {
- global suppress_flag
-
- warning "$reason\n"
- set suppress_flag -1
-}
-
-#
-# Set suppress_flag, which will cause all subsequent calls to send_gdb and
-# gdb_expect to fail immediately (until the next call to
-# gdb_stop_suppressing_tests).
-#
-proc gdb_suppress_tests { args } {
- global suppress_flag
-
- return; # fnf - disable pending review of results where
- # testsuite ran better without this
- incr suppress_flag
-
- if { $suppress_flag == 1 } {
- if { [llength $args] > 0 } {
- warning "[lindex $args 0]\n"
- } else {
- warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n"
- }
- }
-}
-
-#
-# Clear suppress_flag.
-#
-proc gdb_stop_suppressing_tests { } {
- global suppress_flag
-
- if [info exists suppress_flag] {
- if { $suppress_flag > 0 } {
- set suppress_flag 0
- clone_output "Tests restarted.\n"
- }
- } else {
- set suppress_flag 0
- }
-}
-
-proc gdb_clear_suppressed { } {
- global suppress_flag
-
- set suppress_flag 0
-}
-
# Spawn the gdb process.
#
# This doesn't expect any output or do any other initialization,
fail "$test (bad file format)"
return -1
}
- -re ": No such file or directory.*\r\n$gdb_prompt $" {
+ -re -wrap "[string_to_regexp $core]: No such file or directory.*" {
fail "$test (file not found)"
return -1
}
return 0
}
+#
+# with_complaints -- Execute BODY and set complaints temporary to N for the
+# duration.
+#
+proc with_complaints { n body } {
+ global decimal
+
+ # Save current setting of complaints.
+ set save ""
+ set show_complaints_re \
+ "Max number of complaints about incorrect symbols is ($decimal)\\."
+ gdb_test_multiple "show complaints" "" {
+ -re -wrap $show_complaints_re {
+ set save $expect_out(1,string)
+ }
+ }
+
+ if { $save == "" } {
+ perror "Did not manage to set complaints"
+ } else {
+ # Set complaints.
+ gdb_test_no_output "set complaints $n" ""
+ }
+
+ set code [catch {uplevel 1 $body} result]
+
+ # Restore saved setting of complaints.
+ if { $save != "" } {
+ gdb_test_no_output "set complaints $save" ""
+ }
+
+ if {$code == 1} {
+ global errorInfo errorCode
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
+ } else {
+ return -code $code $result
+ }
+}
+
+#
+# gdb_load_no_complaints -- As gdb_load, but in addition verifies that
+# loading caused no symbol reading complaints.
+#
+proc gdb_load_no_complaints { arg } {
+ global gdb_prompt gdb_file_cmd_msg decimal
+
+ # Temporarily set complaint to a small non-zero number.
+ with_complaints 5 {
+ gdb_load $arg
+ }
+
+ # Verify that there were no complaints.
+ set re "^Reading symbols from \[^\r\n\]*\r\n$gdb_prompt $"
+ gdb_assert {[regexp $re $gdb_file_cmd_msg]} "No complaints"
+}
+
# gdb_reload -- load a file into the target. Called before "running",
# either the first time or after already starting the program once,
# for remote targets. Most files that override gdb_load should now
# override this instead.
+#
+# INFERIOR_ARGS contains the arguments to pass to the inferiors, as a
+# single string to get interpreted by a shell. If the target board
+# overriding gdb_reload is a "stub", then it should arrange things such
+# these arguments make their way to the inferior process.
-proc gdb_reload { } {
+proc gdb_reload { {inferior_args {}} } {
# For the benefit of existing configurations, default to gdb_load.
# Specifying no file defaults to the executable currently being
# debugged.
return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"]
}
+# Default implementation of gdb_init.
proc default_gdb_init { test_file_name } {
global gdb_wrapper_initialized
global gdb_wrapper_target
global cleanfiles
global pf_prefix
- set cleanfiles {}
+ # Reset the timeout value to the default. This way, any testcase
+ # that changes the timeout value without resetting it cannot affect
+ # the timeout used in subsequent testcases.
+ global gdb_test_timeout
+ global timeout
+ set timeout $gdb_test_timeout
+
+ if { [regexp ".*gdb\.reverse\/.*" $test_file_name]
+ && [target_info exists gdb_reverse_timeout] } {
+ set timeout [target_info gdb_reverse_timeout]
+ }
+
+ # If GDB_INOTIFY is given, check for writes to '.'. This is a
+ # debugging tool to help confirm that the test suite is
+ # parallel-safe. You need "inotifywait" from the
+ # inotify-tools package to use this.
+ global GDB_INOTIFY inotify_pid
+ if {[info exists GDB_INOTIFY] && ![info exists inotify_pid]} {
+ global outdir tool inotify_log_file
+
+ set exclusions {outputs temp gdb[.](log|sum) cache}
+ set exclusion_re ([join $exclusions |])
+
+ set inotify_log_file [standard_temp_file inotify.out]
+ set inotify_pid [exec inotifywait -r -m -e move,create,delete . \
+ --exclude $exclusion_re \
+ |& tee -a $outdir/$tool.log $inotify_log_file &]
+
+ # Wait for the watches; hopefully this is long enough.
+ sleep 2
+
+ # Clear the log so that we don't emit a warning the first time
+ # we check it.
+ set fd [open $inotify_log_file w]
+ close $fd
+ }
+
+ # Block writes to all banned variables, and invocation of all
+ # banned procedures...
+ global banned_variables
+ global banned_procedures
+ global banned_traced
+ if (!$banned_traced) {
+ foreach banned_var $banned_variables {
+ global "$banned_var"
+ trace add variable "$banned_var" write error
+ }
+ foreach banned_proc $banned_procedures {
+ global "$banned_proc"
+ trace add execution "$banned_proc" enter error
+ }
+ set banned_traced 1
+ }
+
+ # We set LC_ALL, LC_CTYPE, and LANG to C so that we get the same
+ # messages as expected.
+ setenv LC_ALL C
+ setenv LC_CTYPE C
+ setenv LANG C
- gdb_clear_suppressed
+ # Don't let a .inputrc file or an existing setting of INPUTRC mess
+ # up the test results. Certain tests (style tests and TUI tests)
+ # want to set the terminal to a non-"dumb" value, and for those we
+ # want to disable bracketed paste mode. Versions of Readline
+ # before 8.0 will not understand this and will issue a warning.
+ # We tried using a $if to guard it, but Readline 8.1 had a bug in
+ # its version-comparison code that prevented this for working.
+ setenv INPUTRC [cached_file inputrc "set enable-bracketed-paste off"]
+
+ # This disables style output, which would interfere with many
+ # tests.
+ setenv TERM "dumb"
+
+ # If DEBUGINFOD_URLS is set, gdb will try to download sources and
+ # debug info for f.i. system libraries. Prevent this.
+ unset -nocomplain ::env(DEBUGINFOD_URLS)
+
+ # Ensure that GDBHISTFILE and GDBHISTSIZE are removed from the
+ # environment, we don't want these modifications to the history
+ # settings.
+ unset -nocomplain ::env(GDBHISTFILE)
+ unset -nocomplain ::env(GDBHISTSIZE)
+
+ # Ensure that XDG_CONFIG_HOME is not set. Some tests setup a fake
+ # home directory in order to test loading settings from gdbinit.
+ # If XDG_CONFIG_HOME is set then GDB will load a gdbinit from
+ # there (if one is present) rather than the home directory setup
+ # in the test.
+ unset -nocomplain ::env(XDG_CONFIG_HOME)
+
+ # Initialize GDB's pty with a fixed size, to make sure we avoid pagination
+ # during startup. See "man expect" for details about stty_init.
+ global stty_init
+ set stty_init "rows 25 cols 80"
+
+ # Some tests (for example gdb.base/maint.exp) shell out from gdb to use
+ # grep. Clear GREP_OPTIONS to make the behavior predictable,
+ # especially having color output turned on can cause tests to fail.
+ setenv GREP_OPTIONS ""
+
+ # Clear $gdbserver_reconnect_p.
+ global gdbserver_reconnect_p
+ set gdbserver_reconnect_p 1
+ unset gdbserver_reconnect_p
+
+ # Clear $last_loaded_file
+ global last_loaded_file
+ unset -nocomplain last_loaded_file
+
+ # Reset GDB number of instances
+ global gdb_instances
+ set gdb_instances 0
+
+ set cleanfiles {}
set gdb_test_file_name [file rootname [file tail $test_file_name]]
if [info exists use_gdb_stub] {
unset use_gdb_stub
}
+
+ gdb_setup_known_globals
+
+ if { [info procs ::gdb_tcl_unknown] != "" } {
+ # Dejagnu overrides proc unknown. The dejagnu version may trigger in a
+ # test-case but abort the entire test run. To fix this, we install a
+ # local version here, which reverts dejagnu's override, and restore
+ # dejagnu's version in gdb_finish.
+ rename ::unknown ::dejagnu_unknown
+ proc unknown { args } {
+ # Use tcl's unknown.
+ set cmd [lindex $args 0]
+ unresolved "testcase aborted due to invalid command name: $cmd"
+ return [uplevel 1 ::gdb_tcl_unknown $args]
+ }
+ }
}
# Return a path using GDB_PARALLEL.
file mkdir $dir
# If running on MinGW, replace /c/foo with c:/foo
if { [ishost *-*-mingw*] } {
- set dir [regsub {^/([a-z])/} $dir {\1:/}]
+ set dir [exec sh -c "cd ${dir} && pwd -W"]
}
return [file join $dir $basename]
}
proc standard_output_file_with_gdb_instance {basename} {
global gdb_instances
- set count [expr $gdb_instances - 1 ]
+ set count $gdb_instances
if {$count == 0} {
return [standard_output_file $basename]
return $filename
}
+ set dir [file dirname $filename]
+ file mkdir $dir
+
set tmp_filename $filename.[pid]
set fd [open $tmp_filename w]
puts $fd $txt
# Without any arguments, the .exp file's base name is used to
# compute the source file name. The ".c" extension is added in this case.
# If ARGS is not empty, each entry is a source file specification.
-# If the specification starts with a ".", it is treated as a suffix
+# If the specification starts with a "." or "-", it is treated as a suffix
# to append to the .exp file's base name.
# If the specification is the empty string, it is treated as if it
# were ".c".
# Handle an extension.
if {$arg == ""} {
set arg $testfile.c
- } elseif {[string range $arg 0 0] == "."} {
- set arg $testfile$arg
+ } else {
+ set first [string range $arg 0 0]
+ if { $first == "." || $first == "-" } {
+ set arg $testfile$arg
+ }
}
set $varname $arg
# if the banned variables and procedures are already traced.
set banned_traced 0
-proc gdb_init { test_file_name } {
- # Reset the timeout value to the default. This way, any testcase
- # that changes the timeout value without resetting it cannot affect
- # the timeout used in subsequent testcases.
- global gdb_test_timeout
- global timeout
- set timeout $gdb_test_timeout
+# Global array that holds the name of all global variables at the time
+# a test script is started. After the test script has completed any
+# global not in this list is deleted.
+array set gdb_known_globals {}
- if { [regexp ".*gdb\.reverse\/.*" $test_file_name]
- && [target_info exists gdb_reverse_timeout] } {
- set timeout [target_info gdb_reverse_timeout]
- }
+# Setup the GDB_KNOWN_GLOBALS array with the names of all current
+# global variables.
+proc gdb_setup_known_globals {} {
+ global gdb_known_globals
- # If GDB_INOTIFY is given, check for writes to '.'. This is a
- # debugging tool to help confirm that the test suite is
- # parallel-safe. You need "inotifywait" from the
- # inotify-tools package to use this.
- global GDB_INOTIFY inotify_pid
- if {[info exists GDB_INOTIFY] && ![info exists inotify_pid]} {
- global outdir tool inotify_log_file
-
- set exclusions {outputs temp gdb[.](log|sum) cache}
- set exclusion_re ([join $exclusions |])
-
- set inotify_log_file [standard_temp_file inotify.out]
- set inotify_pid [exec inotifywait -r -m -e move,create,delete . \
- --exclude $exclusion_re \
- |& tee -a $outdir/$tool.log $inotify_log_file &]
-
- # Wait for the watches; hopefully this is long enough.
- sleep 2
-
- # Clear the log so that we don't emit a warning the first time
- # we check it.
- set fd [open $inotify_log_file w]
- close $fd
+ array set gdb_known_globals {}
+ foreach varname [info globals] {
+ set gdb_known_globals($varname) 1
}
+}
- # Block writes to all banned variables, and invocation of all
- # banned procedures...
- global banned_variables
- global banned_procedures
- global banned_traced
- if (!$banned_traced) {
- foreach banned_var $banned_variables {
- global "$banned_var"
- trace add variable "$banned_var" write error
- }
- foreach banned_proc $banned_procedures {
- global "$banned_proc"
- trace add execution "$banned_proc" enter error
+# Cleanup the global namespace. Any global not in the
+# GDB_KNOWN_GLOBALS array is unset, this ensures we don't "leak"
+# globals from one test script to another.
+proc gdb_cleanup_globals {} {
+ global gdb_known_globals gdb_persistent_globals
+
+ foreach varname [info globals] {
+ if {![info exists gdb_known_globals($varname)]} {
+ if { [info exists gdb_persistent_globals($varname)] } {
+ continue
+ }
+ uplevel #0 unset $varname
}
- set banned_traced 1
}
+}
- # We set LC_ALL, LC_CTYPE, and LANG to C so that we get the same
- # messages as expected.
- setenv LC_ALL C
- setenv LC_CTYPE C
- setenv LANG C
-
- # Don't let a .inputrc file or an existing setting of INPUTRC mess up
- # the test results. Even if /dev/null doesn't exist on the particular
- # platform, the readline library will use the default setting just by
- # failing to open the file. OTOH, opening /dev/null successfully will
- # also result in the default settings being used since nothing will be
- # read from this file.
- setenv INPUTRC "/dev/null"
-
- # This disables style output, which would interfere with many
- # tests.
- setenv TERM "dumb"
-
- # Ensure that GDBHISTFILE and GDBHISTSIZE are removed from the
- # environment, we don't want these modifications to the history
- # settings.
- unset -nocomplain ::env(GDBHISTFILE)
- unset -nocomplain ::env(GDBHISTSIZE)
-
- # Initialize GDB's pty with a fixed size, to make sure we avoid pagination
- # during startup. See "man expect" for details about stty_init.
- global stty_init
- set stty_init "rows 25 cols 80"
-
- # Some tests (for example gdb.base/maint.exp) shell out from gdb to use
- # grep. Clear GREP_OPTIONS to make the behavior predictable,
- # especially having color output turned on can cause tests to fail.
- setenv GREP_OPTIONS ""
-
- # Clear $gdbserver_reconnect_p.
- global gdbserver_reconnect_p
- set gdbserver_reconnect_p 1
- unset gdbserver_reconnect_p
-
- # Clear $last_loaded_file
- global last_loaded_file
- unset -nocomplain last_loaded_file
-
- # Reset GDB number of instances
- global gdb_instances
- set gdb_instances 0
+# Create gdb_tcl_unknown, a copy tcl's ::unknown, provided it's present as a
+# proc.
+set temp [interp create]
+if { [interp eval $temp "info procs ::unknown"] != "" } {
+ set old_args [interp eval $temp "info args ::unknown"]
+ set old_body [interp eval $temp "info body ::unknown"]
+ eval proc gdb_tcl_unknown {$old_args} {$old_body}
+}
+interp delete $temp
+unset temp
- return [default_gdb_init $test_file_name]
+# GDB implementation of ${tool}_init. Called right before executing the
+# test-case.
+# Overridable function -- you can override this function in your
+# baseboard file.
+proc gdb_init { args } {
+ # A baseboard file overriding this proc and calling the default version
+ # should behave the same as this proc. So, don't add code here, but to
+ # the default version instead.
+ return [default_gdb_init {*}$args]
}
+# GDB implementation of ${tool}_finish. Called right after executing the
+# test-case.
proc gdb_finish { } {
global gdbserver_reconnect_p
global gdb_prompt
global cleanfiles
+ global known_globals
+
+ if { [info procs ::gdb_tcl_unknown] != "" } {
+ # Restore dejagnu's version of proc unknown.
+ rename ::unknown ""
+ rename ::dejagnu_unknown ::unknown
+ }
# Exit first, so that the files are no longer in use.
gdb_exit
}
set banned_traced 0
}
+
+ global gdb_finish_hooks
+ foreach gdb_finish_hook $gdb_finish_hooks {
+ $gdb_finish_hook
+ }
+ set gdb_finish_hooks [list]
+
+ gdb_cleanup_globals
}
global debug_format
return -1
}
set readelf_program [gdb_find_readelf]
- set res [catch {exec $readelf_program -d $executable} output]
+ # We're not testing readelf -d | grep "FLAGS_1.*Flags:.*PIE"
+ # because the PIE flag is not set by all versions of gold, see PR
+ # binutils/26039.
+ set res [catch {exec $readelf_program -h $executable} output]
if { $res != 0 } {
return -1
}
- set res [regexp -line {\(FLAGS_1\).*Flags:.* PIE($| )} $output]
+ set res [regexp -line {^[ \t]*Type:[ \t]*DYN \((Position-Independent Executable|Shared object) file\)$} \
+ $output]
if { $res == 1 } {
return 1
}
gdb_load "$exe"
# Set breakpoint on main.
- gdb_test_multiple "break main" "break main" {
+ gdb_test_multiple "break -q main" "break -q main" {
-re "Breakpoint.*${gdb_prompt} $" {
}
-re "${gdb_prompt} $" {
|| [istarget *-*-cygwin*] || [istarget *-*-mingw32*]
|| [istarget *-*-*djgpp*] || [istarget *-*-go32*]
|| [istarget *-wince-pe] || [istarget *-*-mingw32ce*]
- || [istarget *-*-symbianelf*]
|| [istarget *-*-osf*]
|| [istarget *-*-dicos*]
|| [istarget *-*-nto*]
# Starts fresh GDB binary and loads an optional executable into GDB.
# Usage: clean_restart [executable]
# EXECUTABLE is the basename of the binary.
+# Return -1 if starting gdb or loading the executable failed.
proc clean_restart { args } {
global srcdir
global subdir
+ global errcnt
+ global warncnt
if { [llength $args] > 1 } {
error "bad number of args: [llength $args]"
}
gdb_exit
+
+ # This is a clean restart, so reset error and warning count.
+ set errcnt 0
+ set warncnt 0
+
+ # We'd like to do:
+ # if { [gdb_start] == -1 } {
+ # return -1
+ # }
+ # but gdb_start is a ${tool}_start proc, which doesn't have a defined
+ # return value. So instead, we test for errcnt.
gdb_start
+ if { $errcnt > 0 } {
+ return -1
+ }
+
gdb_reinitialize_dir $srcdir/$subdir
if { [llength $args] >= 1 } {
set executable [lindex $args 0]
set binfile [standard_output_file ${executable}]
- gdb_load ${binfile}
+ return [gdb_load ${binfile}]
}
+
+ return 0
}
# Prepares for testing by calling build_executable_full, then
return ${val}
}
+# Retrieve the value of local var EXP in the inferior. DEFAULT is used as
+# fallback if print fails. TEST is the test message to use. It can be
+# omitted, in which case a test message is built from EXP.
+
+proc get_local_valueof { exp default {test ""} } {
+ global gdb_prompt
+
+ if {$test == "" } {
+ set test "get local valueof \"${exp}\""
+ }
+
+ set val ${default}
+ gdb_test_multiple "info locals ${exp}" "$test" {
+ -re "$exp = (\[^\r\n\]*)\[\r\n\]*$gdb_prompt $" {
+ set val $expect_out(1,string)
+ pass "$test"
+ }
+ timeout {
+ fail "$test (timeout)"
+ }
+ }
+ return ${val}
+}
+
# Retrieve the value of EXP in the inferior, as a signed decimal value
# (using "print /d"). DEFAULT is used as fallback if print fails.
# TEST is the test message to use. It can be omitted, in which case
return 0
} else {
verbose -log "run_on_host failed: $output"
- fail $test
+ if { $output == "spawn failed" } {
+ unsupported $test
+ } else {
+ fail $test
+ }
return -1
}
}
# being.
proc multi_line { args } {
+ if { [llength $args] == 1 } {
+ set hint "forgot {*} before list argument?"
+ error "multi_line called with one argument ($hint)"
+ }
return [join $args "\r\n"]
}
# Open the file for logging gdb input
proc gdb_stdin_log_init { } {
- global in_file
+ gdb_persistent_global in_file
if {[info exists in_file]} {
# Close existing file.
}
}
- #Write to the log
+ # Write to the log and make sure the output is there, even in case
+ # of crash.
puts -nonewline $in_file "$message"
+ flush $in_file
}
# Write the command line used to invocate gdb to the cmd file.
}
# Does the compiler support CTF debug output using '-gt' compiler
-# flag? If not then we should skip these tests.
+# flag? If not then we should skip these tests. We should also
+# skip them if libctf was explicitly disabled.
gdb_caching_proc skip_ctf_tests {
- return ![gdb_can_simple_compile ctfdebug {
+ global enable_libctf
+
+ if {$enable_libctf eq "no"} {
+ return 1
+ }
+
+ set can_ctf [gdb_can_simple_compile ctfdebug {
int main () {
return 0;
}
} executable "additional_flags=-gt"]
+
+ return [expr {!$can_ctf}]
+}
+
+# Return 1 if compiler supports -gstatement-frontiers. Otherwise,
+# return 0.
+
+gdb_caching_proc supports_statement_frontiers {
+ return [gdb_can_simple_compile supports_statement_frontiers {
+ int main () {
+ return 0;
+ }
+ } executable "additional_flags=-gstatement-frontiers"]
+}
+
+# Return 1 if compiler supports -mmpx -fcheck-pointer-bounds. Otherwise,
+# return 0.
+
+gdb_caching_proc supports_mpx_check_pointer_bounds {
+ set flags "additional_flags=-mmpx additional_flags=-fcheck-pointer-bounds"
+ return [gdb_can_simple_compile supports_mpx_check_pointer_bounds {
+ int main () {
+ return 0;
+ }
+ } executable $flags]
+}
+
+# Return 1 if compiler supports -fcf-protection=. Otherwise,
+# return 0.
+
+gdb_caching_proc supports_fcf_protection {
+ return [gdb_can_simple_compile supports_fcf_protection {
+ int main () {
+ return 0;
+ }
+ } executable "additional_flags=-fcf-protection=full"]
+}
+
+# Return 1 if symbols were read in using -readnow. Otherwise, return 0.
+
+proc readnow { args } {
+ if { [llength $args] == 1 } {
+ set re [lindex $args 0]
+ } else {
+ set re ""
+ }
+
+ set readnow_p 0
+ # Given the listing from the following command can be very verbose, match
+ # the patterns line-by-line. This prevents timeouts from waiting for
+ # too much data to come at once.
+ set cmd "maint print objfiles $re"
+ gdb_test_multiple $cmd "" -lbl {
+ -re "\r\n.gdb_index: faked for \"readnow\"" {
+ # Record the we've seen the above pattern.
+ set readnow_p 1
+ exp_continue
+ }
+ -re -wrap "" {
+ # We don't care about any other input.
+ }
+ }
+
+ return $readnow_p
+}
+
+# Return index name if symbols were read in using an index.
+# Otherwise, return "".
+
+proc have_index { objfile } {
+
+ set res ""
+ set cmd "maint print objfiles $objfile"
+ gdb_test_multiple $cmd "" -lbl {
+ -re "\r\n.gdb_index: faked for \"readnow\"" {
+ set res ""
+ exp_continue
+ }
+ -re "\r\n.gdb_index:" {
+ set res "gdb_index"
+ exp_continue
+ }
+ -re "\r\n.debug_names:" {
+ set res "debug_names"
+ exp_continue
+ }
+ -re -wrap "" {
+ # We don't care about any other input.
+ }
+ }
+
+ return $res
+}
+
+# Return 1 if partial symbols are available. Otherwise, return 0.
+
+proc psymtabs_p { } {
+ global gdb_prompt
+
+ set cmd "maint info psymtab"
+ gdb_test_multiple $cmd "" {
+ -re "$cmd\r\n$gdb_prompt $" {
+ return 0
+ }
+ -re -wrap "" {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# Verify that partial symtab expansion for $filename has state $readin.
+
+proc verify_psymtab_expanded { filename readin } {
+ global gdb_prompt
+
+ set cmd "maint info psymtab"
+ set test "$cmd: $filename: $readin"
+ set re [multi_line \
+ " \{ psymtab \[^\r\n\]*$filename\[^\r\n\]*" \
+ " readin $readin" \
+ ".*"]
+
+ gdb_test_multiple $cmd $test {
+ -re "$cmd\r\n$gdb_prompt $" {
+ unsupported $gdb_test_name
+ }
+ -re -wrap $re {
+ pass $gdb_test_name
+ }
+ }
+}
+
+# Add a .gdb_index section to PROGRAM.
+# PROGRAM is assumed to be the output of standard_output_file.
+# Returns the 0 if there is a failure, otherwise 1.
+#
+# STYLE controls which style of index to add, if needed. The empty
+# string (the default) means .gdb_index; "-dwarf-5" means .debug_names.
+
+proc add_gdb_index { program {style ""} } {
+ global srcdir GDB env BUILD_DATA_DIRECTORY
+ set contrib_dir "$srcdir/../contrib"
+ set env(GDB) "$GDB --data-directory=$BUILD_DATA_DIRECTORY"
+ set result [catch "exec $contrib_dir/gdb-add-index.sh $style $program" output]
+ if { $result != 0 } {
+ verbose -log "result is $result"
+ verbose -log "output is $output"
+ return 0
+ }
+
+ return 1
+}
+
+# Add a .gdb_index section to PROGRAM, unless it alread has an index
+# (.gdb_index/.debug_names). Gdb doesn't support building an index from a
+# program already using one. Return 1 if a .gdb_index was added, return 0
+# if it already contained an index, and -1 if an error occurred.
+#
+# STYLE controls which style of index to add, if needed. The empty
+# string (the default) means .gdb_index; "-dwarf-5" means .debug_names.
+
+proc ensure_gdb_index { binfile {style ""} } {
+ set testfile [file tail $binfile]
+ set test "check if index present"
+ gdb_test_multiple "mt print objfiles ${testfile}" $test {
+ -re -wrap "gdb_index.*" {
+ return 0
+ }
+ -re -wrap "debug_names.*" {
+ return 0
+ }
+ -re -wrap "Psymtabs.*" {
+ if { [add_gdb_index $binfile $style] != "1" } {
+ return -1
+ }
+ return 1
+ }
+ }
+ return -1
+}
+
+# Return 1 if executable contains .debug_types section. Otherwise, return 0.
+
+proc debug_types { } {
+ global hex
+
+ set cmd "maint info sections"
+ gdb_test_multiple $cmd "" {
+ -re -wrap "at $hex: .debug_types.*" {
+ return 1
+ }
+ -re -wrap "" {
+ return 0
+ }
+ }
+
+ return 0
+}
+
+# Return the addresses in the line table for FILE for which is_stmt is true.
+
+proc is_stmt_addresses { file } {
+ global decimal
+ global hex
+
+ set is_stmt [list]
+
+ gdb_test_multiple "maint info line-table $file" "" {
+ -re "\r\n$decimal\[ \t\]+$decimal\[ \t\]+($hex)\[ \t\]+Y\[^\r\n\]*" {
+ lappend is_stmt $expect_out(1,string)
+ exp_continue
+ }
+ -re -wrap "" {
+ }
+ }
+
+ return $is_stmt
+}
+
+# Return 1 if hex number VAL is an element of HEXLIST.
+
+proc hex_in_list { val hexlist } {
+ # Normalize val by removing 0x prefix, and leading zeros.
+ set val [regsub ^0x $val ""]
+ set val [regsub ^0+ $val "0"]
+
+ set re 0x0*$val
+ set index [lsearch -regexp $hexlist $re]
+ return [expr $index != -1]
+}
+
+# Override proc NAME to proc OVERRIDE for the duration of the execution of
+# BODY.
+
+proc with_override { name override body } {
+ # Implementation note: It's possible to implement the override using
+ # rename, like this:
+ # rename $name save_$name
+ # rename $override $name
+ # set code [catch {uplevel 1 $body} result]
+ # rename $name $override
+ # rename save_$name $name
+ # but there are two issues here:
+ # - the save_$name might clash with an existing proc
+ # - the override is no longer available under its original name during
+ # the override
+ # So, we use this more elaborate but cleaner mechanism.
+
+ # Save the old proc.
+ set old_args [info args $name]
+ set old_body [info body $name]
+
+ # Install the override.
+ set new_args [info args $override]
+ set new_body [info body $override]
+ eval proc $name {$new_args} {$new_body}
+
+ # Execute body.
+ set code [catch {uplevel 1 $body} result]
+
+ # Restore old proc.
+ eval proc $name {$old_args} {$old_body}
+
+ # Return as appropriate.
+ if { $code == 1 } {
+ global errorInfo errorCode
+ return -code error -errorinfo $errorInfo -errorcode $errorCode $result
+ } elseif { $code > 1 } {
+ return -code $code $result
+ }
+
+ return $result
+}
+
+# Setup tuiterm.exp environment. To be used in test-cases instead of
+# "load_lib tuiterm.exp". Calls initialization function and schedules
+# finalization function.
+proc tuiterm_env { } {
+ load_lib tuiterm.exp
+}
+
+# Dejagnu has a version of note, but usage is not allowed outside of dejagnu.
+# Define a local version.
+proc gdb_note { message } {
+ verbose -- "NOTE: $message" 0
+}
+
+# Return 1 if compiler supports -fuse-ld=gold, otherwise return 0.
+gdb_caching_proc have_fuse_ld_gold {
+ set me "have_fuse_ld_gold"
+ set flags "additional_flags=-fuse-ld=gold"
+ set src { int main() { return 0; } }
+ return [gdb_simple_compile $me $src executable $flags]
+}
+
+# Return 1 if compiler supports scalar_storage_order attribute, otherwise
+# return 0.
+gdb_caching_proc supports_scalar_storage_order_attribute {
+ set me "supports_scalar_storage_order_attribute"
+ set src {
+ #include <string.h>
+ struct sle {
+ int v;
+ } __attribute__((scalar_storage_order("little-endian")));
+ struct sbe {
+ int v;
+ } __attribute__((scalar_storage_order("big-endian")));
+ struct sle sle;
+ struct sbe sbe;
+ int main () {
+ sle.v = sbe.v = 0x11223344;
+ int same = memcmp (&sle, &sbe, sizeof (int)) == 0;
+ int sso = !same;
+ return sso;
+ }
+ }
+ if { ![gdb_simple_compile $me $src executable ""] } {
+ return 0
+ }
+
+ set result [remote_exec target $obj]
+ set status [lindex $result 0]
+ set output [lindex $result 1]
+ if { $output != "" } {
+ return 0
+ }
+
+ return $status
+}
+
+# Return 1 if compiler supports __GNUC__, otherwise return 0.
+gdb_caching_proc supports_gnuc {
+ set me "supports_gnuc"
+ set src {
+ #ifndef __GNUC__
+ #error "No gnuc"
+ #endif
+ }
+ return [gdb_simple_compile $me $src object ""]
+}
+
+# Return 1 if target supports mpx, otherwise return 0.
+gdb_caching_proc have_mpx {
+ global srcdir
+
+ set me "have_mpx"
+ if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } {
+ verbose "$me: target does not support mpx, returning 0" 2
+ return 0
+ }
+
+ # Compile a test program.
+ set src {
+ #include "nat/x86-cpuid.h"
+
+ int main() {
+ unsigned int eax, ebx, ecx, edx;
+
+ if (!__get_cpuid (1, &eax, &ebx, &ecx, &edx))
+ return 0;
+
+ if ((ecx & bit_OSXSAVE) == bit_OSXSAVE)
+ {
+ if (__get_cpuid_max (0, (void *)0) < 7)
+ return 0;
+
+ __cpuid_count (7, 0, eax, ebx, ecx, edx);
+
+ if ((ebx & bit_MPX) == bit_MPX)
+ return 1;
+
+ }
+ return 0;
+ }
+ }
+ set compile_flags "incdir=${srcdir}/.."
+ if {![gdb_simple_compile $me $src executable $compile_flags]} {
+ return 0
+ }
+
+ set result [remote_exec target $obj]
+ set status [lindex $result 0]
+ set output [lindex $result 1]
+ if { $output != "" } {
+ set status 0
+ }
+
+ remote_file build delete $obj
+
+ verbose "$me: returning $status" 2
+ return $status
+}
+
+# Return 1 if target supports avx, otherwise return 0.
+gdb_caching_proc have_avx {
+ global srcdir
+
+ set me "have_avx"
+ if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } {
+ verbose "$me: target does not support avx, returning 0" 2
+ return 0
+ }
+
+ # Compile a test program.
+ set src {
+ #include "nat/x86-cpuid.h"
+
+ int main() {
+ unsigned int eax, ebx, ecx, edx;
+
+ if (!x86_cpuid (1, &eax, &ebx, &ecx, &edx))
+ return 0;
+
+ if ((ecx & (bit_AVX | bit_OSXSAVE)) == (bit_AVX | bit_OSXSAVE))
+ return 1;
+ else
+ return 0;
+ }
+ }
+ set compile_flags "incdir=${srcdir}/.."
+ if {![gdb_simple_compile $me $src executable $compile_flags]} {
+ return 0
+ }
+
+ set result [remote_exec target $obj]
+ set status [lindex $result 0]
+ set output [lindex $result 1]
+ if { $output != "" } {
+ set status 0
+ }
+
+ remote_file build delete $obj
+
+ verbose "$me: returning $status" 2
+ return $status
}
# Always load compatibility stuff.
load_lib future.exp
+
+proc drain_gdbserver_output { } {
+ if { [info exists ::server_spawn_id] } {
+ #puts "gonna expect"
+ gdb_expect {
+ -i "$::server_spawn_id"
+ -timeout 0
+
+ -re ".+" {
+ exp_continue
+ #puts "consumed: $expect_out(buffer)"
+ }
+
+
+ }
+ #puts "expected"
+ }
+}
projects / deliverable / binutils-gdb.git / blobdiff