-# Copyright 1992-2016 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.
}
# A regexp that matches the pagination prompt.
-set pagination_prompt [string_to_regexp "---Type <return> to continue, or q <return> to quit---"]
+set pagination_prompt \
+ "--Type <RET> for more, q to quit, c to continue without paging--"
# The variable fullname_syntax_POSIX is a regexp which matches a POSIX
# absolute path ie. /foo/
set octal "\[0-7\]+"
-set inferior_exited_re "(\\\[Inferior \[0-9\]+ \\(.*\\) exited)"
+set inferior_exited_re "(?:\\\[Inferior \[0-9\]+ \\(\[^\n\r\]*\\) exited)"
+
+# A regular expression that matches a value history number.
+# E.g., $1, $2, etc.
+set valnum_re "\\\$$decimal"
### Only procedures should come after this point.
#
proc gdb_unload {} {
- global verbose
global GDB
global gdb_prompt
send_gdb "file\n"
-re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
-re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
-re "A program is being debugged already.*Are you sure you want to change the file.*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "Discard symbol table from .*y or n.*$" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "$gdb_prompt $" {}
set deleted 0
gdb_test_multiple "delete breakpoints" "$msg" {
-re "Delete all breakpoints.*y or n.*$" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "$gdb_prompt $" {
}
}
+# Returns true iff the target supports using the "run" command.
+
+proc target_can_use_run_cmd {} {
+ if [target_info exists use_gdb_stub] {
+ # In this case, when we connect, the inferior is already
+ # running.
+ return 0
+ }
+
+ # Assume yes.
+ return 1
+}
+
# 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"
set start_attempt 0
}
-re "Line.* Jump anyway.*y or n. $" {
- send_gdb "y\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.
gdb_expect 60 {
-re "The program .* has been started already.*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-notransfer -re "Starting program: \[^\r\n\]*" {}
# 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 {
-re "The program .* has been started already.*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-notransfer -re "Starting program: \[^\r\n\]*" {
return -1
}
+# 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 { {inferior_args {}} } {
+ global gdb_prompt use_gdb_stub
+
+ foreach command [gdb_init_commands] {
+ send_gdb "$command\n"
+ gdb_expect 30 {
+ -re "$gdb_prompt $" { }
+ default {
+ perror "gdb_init_command for target failed"
+ return -1
+ }
+ }
+ }
+
+ if $use_gdb_stub {
+ return -1
+ }
+
+ send_gdb "starti $inferior_args\n"
+ gdb_expect 60 {
+ -re "The program .* has been started already.*y or n. $" {
+ send_gdb "y\n" answer
+ exp_continue
+ }
+ -re "Starting program: \[^\r\n\]*" {
+ return 0
+ }
+ }
+ return -1
+}
+
# 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, and passfail.
+# 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
set break_message "Temporary breakpoint"
}
+ if {[lsearch -exact $args qualified] != -1} {
+ append break_command " -qualified"
+ }
+
set print_pass 0
set print_fail 1
set no_message_loc [lsearch -exact $args no-message]
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)"
}
}
-re "The target does not support running in non-stop mode.\r\n$gdb_prompt $" {
if { $print_fail } {
- unsupported "Non-stop mode not supported"
+ unsupported "non-stop mode not supported"
}
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.
global gdb_prompt
set full_name "continue to breakpoint: $name"
+ set kfail_pattern "Process record does not support instruction 0xfae64 at.*"
gdb_test_multiple "continue" $full_name {
-re "(?:Breakpoint|Temporary breakpoint) .* (at|in) $location_pattern\r\n$gdb_prompt $" {
pass $full_name
}
+ -re "\[\r\n\]*(?:$kfail_pattern)\[\r\n\]+$gdb_prompt $" {
+ kfail "gdb/25038" $full_name
+ }
}
}
while {$count < 10} {
gdb_expect {
-re "Quit this debugging session\\? \\(y or n\\) $" {
- send_gdb "n\n"
+ send_gdb "n\n" answer
incr count
}
-re "Create a core file of GDB\\? \\(y or n\\) $" {
- send_gdb "n\n"
+ send_gdb "n\n" answer
incr count
}
-re "$gdb_prompt $" {
}
-# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS
+# gdb_test_multiple COMMAND MESSAGE [ -prompt PROMPT_REGEXP] [ -lbl ]
+# EXPECT_ARGUMENTS
# Send a command to gdb; test the result.
#
# COMMAND is the command to execute, send to GDB with send_gdb. If
# this is the null string no command is sent.
# MESSAGE is a message to be printed with the built-in failure patterns
# if one of them matches. If MESSAGE is empty COMMAND will be used.
+# -prompt PROMPT_REGEXP specifies a regexp matching the expected prompt
+# after the command output. If empty, defaults to "$gdb_prompt $".
+# -lbl specifies that line-by-line matching will be used.
# EXPECT_ARGUMENTS will be fed to expect in addition to the standard
# patterns. Pattern elements will be evaluated in the caller's
# context; action elements will be executed in the caller's context.
#
# gdb_test_multiple "print foo" "test foo" {
# -re "expected output 1" {
-# pass "print foo"
+# pass "test foo"
+# }
+# -re "expected output 2" {
+# fail "test foo"
+# }
+# }
+#
+# Within action elements you can also make use of the variable
+# gdb_test_name. This variable is setup automatically by
+# gdb_test_multiple, and contains the value of MESSAGE. You can then
+# write this, which is equivalent to the above:
+#
+# gdb_test_multiple "print foo" "test foo" {
+# -re "expected output 1" {
+# pass $gdb_test_name
# }
# -re "expected output 2" {
-# fail "print foo"
+# fail $gdb_test_name
# }
# }
#
# expected from $gdb_spawn_id. IOW, callers do not need to worry
# about resetting "-i" back to $gdb_spawn_id explicitly.
#
-proc gdb_test_multiple { command message user_code } {
+# In EXPECT_ARGUMENTS we can use a -wrap pattern flag, that wraps the regexp
+# pattern as gdb_test wraps its message argument.
+# This allows us to rewrite:
+# gdb_test <command> <pattern> <message>
+# into:
+# gdb_test_multiple <command> <message> {
+# -re -wrap <pattern> {
+# pass $gdb_test_name
+# }
+# }
+#
+# In EXPECT_ARGUMENTS, a pattern flag -early can be used. It makes sure the
+# pattern is inserted before any implicit pattern added by gdb_test_multiple.
+# Using this pattern flag, we can f.i. setup a kfail for an assertion failure
+# <assert> during gdb_continue_to_breakpoint by the rewrite:
+# gdb_continue_to_breakpoint <msg> <pattern>
+# into:
+# set breakpoint_pattern "(?:Breakpoint|Temporary breakpoint) .* (at|in)"
+# gdb_test_multiple "continue" "continue to breakpoint: <msg>" {
+# -early -re "internal-error: <assert>" {
+# setup_kfail gdb/nnnnn "*-*-*"
+# exp_continue
+# }
+# -re "$breakpoint_pattern <pattern>\r\n$gdb_prompt $" {
+# pass $gdb_test_name
+# }
+# }
+#
+proc gdb_test_multiple { command message args } {
global verbose use_gdb_stub
global gdb_prompt pagination_prompt
global GDB
upvar expect_out expect_out
global any_spawn_id
+ set line_by_line 0
+ set prompt_regexp ""
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set arg [lindex $args $i]
+ if { $arg == "-prompt" } {
+ incr i
+ set prompt_regexp [lindex $args $i]
+ } elseif { $arg == "-lbl" } {
+ set line_by_line 1
+ } else {
+ set user_code $arg
+ break
+ }
+ }
+ if { [expr $i + 1] < [llength $args] } {
+ error "Too many arguments to gdb_test_multiple"
+ } elseif { ![info exists user_code] } {
+ error "Too few arguments to gdb_test_multiple"
+ }
+
+ if { "$prompt_regexp" == "" } {
+ set prompt_regexp "$gdb_prompt $"
+ }
+
if { $message == "" } {
set message $command
}
set subst_code [uplevel list $subst_code]
set processed_code ""
+ set early_processed_code ""
+ # The variable current_list holds the name of the currently processed
+ # list, either processed_code or early_processed_code.
+ set current_list "processed_code"
set patterns ""
set expecting_action 0
set expecting_arg 0
+ set wrap_pattern 0
foreach item $user_code subst_item $subst_code {
if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } {
- lappend processed_code $item
+ lappend $current_list $item
continue
}
if { $item == "-indices" || $item == "-re" || $item == "-ex" } {
- lappend processed_code $item
+ lappend $current_list $item
+ continue
+ }
+ if { $item == "-early" } {
+ set current_list "early_processed_code"
continue
}
if { $item == "-timeout" || $item == "-i" } {
set expecting_arg 1
- lappend processed_code $item
+ lappend $current_list $item
+ continue
+ }
+ if { $item == "-wrap" } {
+ set wrap_pattern 1
continue
}
if { $expecting_arg } {
set expecting_arg 0
- lappend processed_code $subst_item
+ lappend $current_list $subst_item
continue
}
if { $expecting_action } {
- lappend processed_code "uplevel [list $item]"
+ lappend $current_list "uplevel [list $item]"
set expecting_action 0
# Cosmetic, no effect on the list.
- append processed_code "\n"
+ append $current_list "\n"
+ # End the effect of -early, it only applies to one action.
+ set current_list "processed_code"
continue
}
set expecting_action 1
- lappend processed_code $subst_item
+ if { $wrap_pattern } {
+ # Wrap subst_item as is done for the gdb_test PATTERN argument.
+ lappend $current_list \
+ "\[\r\n\]*(?:$subst_item)\[\r\n\]+$gdb_prompt $"
+ set wrap_pattern 0
+ } else {
+ lappend $current_list $subst_item
+ }
if {$patterns != ""} {
append patterns "; "
}
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."
}
}
}
- set code {
+ drain_gdbserver_output
+
+ set code $early_processed_code
+ append code {
-re ".*A problem internal to GDB has been detected" {
fail "$message (GDB internal error)"
gdb_internal_error_resync
if { $message != "" } {
fail "$message"
}
- gdb_suppress_entire_file "GDB died"
set result -1
}
}
append code $processed_code
+
+ # Reset the spawn id, in case the processed code used -i.
append code {
- # Reset the spawn id, in case the processed code used -i.
-i "$gdb_spawn_id"
+ }
- -re "Ending remote debugging.*$gdb_prompt $" {
+ append code {
+ -re "Ending remote debugging.*$prompt_regexp" {
if ![isnative] then {
warning "Can`t communicate to remote target."
}
gdb_start
set result -1
}
- -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
+ -re "Undefined\[a-z\]* command:.*$prompt_regexp" {
perror "Undefined command \"$command\"."
fail "$message"
set result 1
}
- -re "Ambiguous command.*$gdb_prompt $" {
+ -re "Ambiguous command.*$prompt_regexp" {
perror "\"$command\" is not a unique command name."
fail "$message"
set result 1
}
- -re "$inferior_exited_re with code \[0-9\]+.*$gdb_prompt $" {
+ -re "$inferior_exited_re with code \[0-9\]+.*$prompt_regexp" {
if ![string match "" $message] then {
set errmsg "$message (the program exited)"
} else {
fail "$errmsg"
set result -1
}
- -re "$inferior_exited_re normally.*$gdb_prompt $" {
+ -re "$inferior_exited_re normally.*$prompt_regexp" {
if ![string match "" $message] then {
set errmsg "$message (the program exited)"
} else {
fail "$errmsg"
set result -1
}
- -re "The program is not being run.*$gdb_prompt $" {
+ -re "The program is not being run.*$prompt_regexp" {
if ![string match "" $message] then {
set errmsg "$message (the program is no longer running)"
} else {
fail "$errmsg"
set result -1
}
- -re "\r\n$gdb_prompt $" {
+ -re "\r\n$prompt_regexp" {
if ![string match "" $message] then {
fail "$message"
}
set result -1
}
-re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " {
- send_gdb "n\n"
- gdb_expect -re "$gdb_prompt $"
+ send_gdb "n\n" answer
+ gdb_expect -re "$prompt_regexp"
fail "$message (got interactive prompt)"
set result -1
}
-re "\\\[0\\\] cancel\r\n\\\[1\\\] all.*\r\n> $" {
send_gdb "0\n"
- gdb_expect -re "$gdb_prompt $"
+ gdb_expect -re "$prompt_regexp"
fail "$message (got breakpoint menu)"
set result -1
}
- # Patterns below apply to any spawn id specified.
+ -i $gdb_spawn_id
+ eof {
+ perror "GDB process no longer exists"
+ set wait_status [wait -i $gdb_spawn_id]
+ verbose -log "GDB process exited with wait status $wait_status"
+ if { $message != "" } {
+ fail "$message"
+ }
+ return -1
+ }
+ }
+
+ if {$line_by_line} {
+ append code {
+ -re "\r\n\[^\r\n\]*(?=\r\n)" {
+ exp_continue
+ }
+ }
+ }
+
+ # Now patterns that apply to any spawn id specified.
+ append code {
-i $any_spawn_id
eof {
perror "Process no longer exists"
}
}
+ # remote_expect calls the eof section if there is an error on the
+ # expect call. We already have eof sections above, and we don't
+ # want them to get called in that situation. Since the last eof
+ # section becomes the error section, here we define another eof
+ # section, but with an empty spawn_id list, so that it won't ever
+ # match.
+ append code {
+ -i "" eof {
+ # This comment is here because the eof section must not be
+ # the empty string, otherwise remote_expect won't realize
+ # it exists.
+ }
+ }
+
+ # Create gdb_test_name in the parent scope. If this variable
+ # already exists, which it might if we have nested calls to
+ # gdb_test_multiple, then preserve the old value, otherwise,
+ # create a new variable in the parent scope.
+ upvar gdb_test_name gdb_test_name
+ if { [info exists gdb_test_name] } {
+ set gdb_test_name_old "$gdb_test_name"
+ }
+ 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
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.
#
set command [lindex $args 0]
set pattern [lindex $args 1]
- if [llength $args]==5 {
+ set user_code {}
+ lappend user_code {
+ -re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" {
+ if ![string match "" $message] then {
+ pass "$message"
+ }
+ }
+ }
+
+ if { [llength $args] == 5 } {
set question_string [lindex $args 3]
set response_string [lindex $args 4]
+ lappend user_code {
+ -re "(${question_string})$" {
+ send_gdb "$response_string\n"
+ exp_continue
+ }
+ }
+ }
+
+ set user_code [join $user_code]
+ return [gdb_test_multiple $command $message $user_code]
+}
+
+# Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR.
+proc version_at_least { major minor at_least_major at_least_minor} {
+ if { $major > $at_least_major } {
+ return 1
+ } elseif { $major == $at_least_major \
+ && $minor >= $at_least_minor } {
+ return 1
} else {
- set question_string "^FOOBAR$"
+ return 0
}
+}
- return [gdb_test_multiple $command $message {
- -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
- if ![string match "" $message] then {
- pass "$message"
- }
+# Return 1 if tcl version used is at least MAJOR.MINOR
+proc tcl_version_at_least { major minor } {
+ global tcl_version
+ regexp {^([0-9]+)\.([0-9]+)$} $tcl_version \
+ dummy tcl_version_major tcl_version_minor
+ return [version_at_least $tcl_version_major $tcl_version_minor \
+ $major $minor]
+}
+
+if { [tcl_version_at_least 8 5] == 0 } {
+ # lrepeat was added in tcl 8.5. Only add if missing.
+ proc lrepeat { n element } {
+ if { [string is integer -strict $n] == 0 } {
+ error "expected integer but got \"$n\""
}
- -re "(${question_string})$" {
- send_gdb "$response_string\n"
- exp_continue
- }
- }]
+ if { $n < 0 } {
+ error "bad count \"$n\": must be integer >= 0"
+ }
+ set res [list]
+ for {set i 0} {$i < $n} {incr i} {
+ lappend res $element
+ }
+ return $res
+ }
}
# gdb_test_no_output COMMAND MESSAGE
# This is useful when the sequence is long and contains ".*", a single
# regexp to match the entire output can get a timeout much easier.
#
-# COMMAND is the command to send.
+# COMMAND is the command to execute, send to GDB with send_gdb. If
+# this is the null string no command is sent.
# TEST_NAME is passed to pass/fail. COMMAND is used if TEST_NAME is "".
# 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
- send_gdb "$command\n"
- return [gdb_expect_list $test_name "$gdb_prompt $" $expected_output_list]
+
+ if { $command != "" } {
+ send_gdb "$command\n"
+ }
+
+ 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
regsub -all "\n" $pattern "\r\n" pattern
if [llength $args]==3 then {
set message [lindex $args 2]
- } else {
- set message $command
+ return [gdb_test $command $pattern $message]
}
- return [gdb_test $command $pattern $message]
+ return [gdb_test $command $pattern]
}
# Wrapper around gdb_test_multiple that looks for a list of expected
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
+# with 'set print max-depth' set to various depths. OUTPUTS is a list
+# of `n` different patterns to match at each of the depths from 0 to
+# (`n` - 1).
+#
+# This proc does one final check with the max-depth set to 'unlimited'
+# which is tested against the last pattern in the OUTPUTS list. The
+# OUTPUTS list is therefore required to match every depth from 0 to a
+# depth where the whole of EXP is printed with no ellipsis.
+#
+# This proc leaves the 'set print max-depth' set to 'unlimited'.
+proc gdb_print_expr_at_depths {exp outputs} {
+ for { set depth 0 } { $depth <= [llength $outputs] } { incr depth } {
+ if { $depth == [llength $outputs] } {
+ set expected_result [lindex $outputs [expr [llength $outputs] - 1]]
+ set depth_string "unlimited"
+ } else {
+ set expected_result [lindex $outputs $depth]
+ set depth_string $depth
+ }
+
+ with_test_prefix "exp='$exp': depth=${depth_string}" {
+ gdb_test_no_output "set print max-depth ${depth_string}"
+ gdb_test "p $exp" "$expected_result"
+ }
+ }
+}
+
\f
# Issue a PASS and return true if evaluating CONDITION in the caller's
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
send_gdb "dir\n"
gdb_expect 60 {
-re "Reinitialize source path to empty.*y or n. " {
- send_gdb "y\n"
+ send_gdb "y\n" answer
gdb_expect 60 {
-re "Source directories searched.*$gdb_prompt $" {
send_gdb "dir $subdir\n"
proc default_gdb_exit {} {
global GDB
global INTERNAL_GDBFLAGS GDBFLAGS
- global verbose
global gdb_spawn_id inferior_spawn_id
global inotify_log_file
- gdb_stop_suppressing_tests
-
if ![info exists gdb_spawn_id] {
return
}
send_gdb "quit\n"
gdb_expect 10 {
-re "y or n" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "DOSEXIT code" { }
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.
proc gdb_file_cmd { arg } {
global gdb_prompt
- global verbose
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] {
}
# The file command used to kill the remote target. For the benefit
- # of the testsuite, preserve this behavior.
- send_gdb "kill\n"
+ # of the testsuite, preserve this behavior. Mark as optional so it doesn't
+ # get written to the stdin log.
+ send_gdb "kill\n" optional
gdb_expect 120 {
-re "Kill the program being debugged. .y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
verbose "\t\tKilling previous program being debugged"
exp_continue
}
}
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.*done.*$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.*done.*$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.*done.*$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. $" {
- send_gdb "y\n"
- gdb_expect 120 {
- -re "Reading symbols from.*done.*$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
- }
- }
+ if { $new_symbol_table > 0 } {
+ perror [join [list "Couldn't load $basename,"
+ "interactive prompt loop detected."]]
+ return -1
+ }
+ send_gdb "y\n" answer
+ 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
}
}
}
-# Default gdb_spawn procedure.
+# 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 use_gdb_stub
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 use_gdb_stub [target_info exists use_gdb_stub]
verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS"
+ gdb_write_cmd_file "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS"
if [info exists gdb_spawn_id] {
return 0
}
set gdb_spawn_id $res
+ set ::gdb_tty_name $::last_spawn_tty_name
return 0
}
# Default gdb_start procedure.
proc default_gdb_start { } {
- global gdb_prompt pagination_prompt
+ global gdb_prompt
global gdb_spawn_id
global inferior_spawn_id
return 0
}
+ # Keep track of the number of times GDB has been launched.
+ global gdb_instances
+ incr gdb_instances
+
+ gdb_stdin_log_init
+
set res [gdb_spawn]
if { $res != 0} {
return $res
# When running over NFS, particularly if running many simultaneous
# tests on different hosts all using the same server, things can
# get really slow. Give gdb at least 3 minutes to start up.
- set loop_again 1
- while { $loop_again } {
- set loop_again 0
- gdb_expect 360 {
- -re "$pagination_prompt" {
- verbose "Hit pagination during startup. Pressing enter to continue."
- send_gdb "\n"
- set loop_again 1
- }
- -re "\[\r\n\]$gdb_prompt $" {
- verbose "GDB initialized."
- }
- -re "$gdb_prompt $" {
- perror "GDB never initialized."
- unset gdb_spawn_id
- return -1
- }
- timeout {
- perror "(timeout) GDB never initialized after 10 seconds."
- remote_close host
- unset gdb_spawn_id
- return -1
- }
+ gdb_expect 360 {
+ -re "\[\r\n\]$gdb_prompt $" {
+ verbose "GDB initialized."
+ }
+ -re "$gdb_prompt $" {
+ perror "GDB never initialized."
+ unset gdb_spawn_id
+ return -1
+ }
+ timeout {
+ perror "(timeout) GDB never initialized after 10 seconds."
+ remote_close host
+ unset gdb_spawn_id
+ return -1
+ }
+ eof {
+ perror "(eof) GDB never initialized."
+ unset gdb_spawn_id
+ return -1
}
}
warning "Couldn't set the width to 0."
}
}
+
+ gdb_debug_init
return 0
}
# 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 0
}
-# Return a 1 if I don't even want to try to test java.
-
-proc skip_java_tests {} {
- return 0
-}
-
# Return a 1 if I don't even want to try to test D.
proc skip_d_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.
proc skip_python_tests_prompt { prompt_regexp } {
global gdb_py_is_py3k
- global gdb_py_is_py24
- gdb_test_multiple "python print ('test')" "verify python support" {
- -re "not supported.*$prompt_regexp" {
- unsupported "Python support is disabled."
- return 1
+ gdb_test_multiple "python print ('test')" "verify python support" \
+ -prompt "$prompt_regexp" {
+ -re "not supported.*$prompt_regexp" {
+ unsupported "Python support is disabled."
+ return 1
+ }
+ -re "$prompt_regexp" {}
}
- -re "$prompt_regexp" {}
- }
- set gdb_py_is_py24 0
- gdb_test_multiple "python print (sys.version_info\[0\])" "check if python 3" {
- -re "3.*$prompt_regexp" {
- set gdb_py_is_py3k 1
- }
- -re ".*$prompt_regexp" {
- set gdb_py_is_py3k 0
- }
- }
- if { $gdb_py_is_py3k == 0 } {
- gdb_test_multiple "python print (sys.version_info\[1\])" "check if python 2.4" {
- -re "\[45\].*$prompt_regexp" {
- set gdb_py_is_py24 1
- }
+ gdb_test_multiple "python print (sys.version_info\[0\])" "check if python 3" \
+ -prompt "$prompt_regexp" {
+ -re "3.*$prompt_regexp" {
+ set gdb_py_is_py3k 1
+ }
-re ".*$prompt_regexp" {
- set gdb_py_is_py24 0
- }
- }
- }
+ set gdb_py_is_py3k 0
+ }
+ }
return 0
}
if {([istarget *-*-linux*]
|| [istarget *-*-*bsd*]
|| [istarget *-*-solaris2*]
- || [istarget arm*-*-symbianelf*]
|| [istarget *-*-mingw*]
|| [istarget *-*-cygwin*]
|| [istarget *-*-pe*])} {
upvar 1 $var myvar
foreach myvar $list {
with_test_prefix "$var=$myvar" {
- uplevel 1 $body
+ 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
}
}
}
+# Like TCL's native proc, but defines a procedure that wraps its body
+# within 'with_test_prefix "$proc_name" { ... }'.
+proc proc_with_prefix {name arguments body} {
+ # Define the advertised proc.
+ proc $name $arguments [list with_test_prefix $name $body]
+}
+
+
# Run BODY in the context of the caller. After BODY is run, the variables
# listed in VARS will be reset to the values they had before BODY was run.
#
}
}
+# 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.
+#
+# This procedure doesn't check if DIR is a valid directory, so you
+# have to make sure of that.
+
+proc with_cwd { dir body } {
+ set saved_dir [pwd]
+ 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
+ }
+}
# Run tests in BODY with GDB prompt and variable $gdb_prompt set to
# PROMPT. When BODY is finished, restore GDB prompt and variable
set board_info($board,fileid) $spawn_id
}
+# Clear the default spawn id.
+
+proc clear_gdb_spawn_id {} {
+ global gdb_spawn_id
+ global board board_info
+
+ unset -nocomplain gdb_spawn_id
+ set board [host_info name]
+ unset -nocomplain board_info($board,fileid)
+}
+
# Run BODY with SPAWN_ID as current spawn id.
proc with_spawn_id { spawn_id body } {
global gdb_spawn_id
- set saved_spawn_id $gdb_spawn_id
+ if [info exists gdb_spawn_id] {
+ set saved_spawn_id $gdb_spawn_id
+ }
+
switch_gdb_spawn_id $spawn_id
set code [catch {uplevel 1 $body} result]
- switch_gdb_spawn_id $saved_spawn_id
+ if [info exists saved_spawn_id] {
+ switch_gdb_spawn_id $saved_spawn_id
+ } else {
+ clear_gdb_spawn_id
+ }
if {$code == 1} {
global errorInfo errorCode
}
}
+# Run BODY with timeout factor FACTOR if check-read1 is used.
+
+proc with_read1_timeout_factor { factor body } {
+ if { [info exists ::env(READ1)] == 1 && $::env(READ1) == 1 } {
+ # Use timeout factor
+ } else {
+ # Reset timeout factor
+ set factor 1
+ }
+ return [uplevel [list with_timeout_factor $factor $body]]
+}
+
# Return 1 if _Complex types are supported, otherwise, return 0.
gdb_caching_proc support_complex_tests {
- # Set up, compile, and execute a test program containing _Complex types.
- # Include the current process ID in the file names to prevent conflicts
- # with invocations for multiple testsuites.
- set src [standard_temp_file complex[pid].c]
- set exe [standard_temp_file complex[pid].x]
- gdb_produce_source $src {
+ if { [gdb_skip_float_test] } {
+ # If floating point is not supported, _Complex is not
+ # supported.
+ return 0
+ }
+
+ # Compile a test program containing _Complex types.
+
+ return [gdb_can_simple_compile complex {
int main() {
_Complex float cf;
_Complex double cd;
_Complex long double cld;
return 0;
}
- }
-
- verbose "compiling testfile $src" 2
- set compile_flags {debug nowarnings quiet}
- set lines [gdb_compile $src $exe executable $compile_flags]
- file delete $src
- file delete $exe
+ } executable]
+}
- if ![string match "" $lines] then {
- verbose "testfile compilation failed, returning 0" 2
- set result 0
- } else {
- set result 1
- }
+# Return 1 if compiling go is supported.
+gdb_caching_proc support_go_compile {
- return $result
+ return [gdb_can_simple_compile go-hello {
+ package main
+ import "fmt"
+ func main() {
+ fmt.Println("hello world")
+ }
+ } executable go]
}
# Return 1 if GDB can get a type for siginfo from the target, otherwise
}
}
+# 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 {} {
gdb_caching_proc is_elf_target {
set me "is_elf_target"
- set src [standard_temp_file is_elf_target[pid].c]
- set obj [standard_temp_file is_elf_target[pid].o]
-
- gdb_produce_source $src {
- int foo () {return 0;}
- }
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
-
- file delete $src
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
+ set src { int foo () {return 0;} }
+ if {![gdb_simple_compile elf_target $src]} {
+ return 0
}
set fp_obj [open $obj "r"]
# This cannot be decided simply from looking at the target string,
# as it might depend on externally passed compiler options like -m64.
gdb_caching_proc is_ilp32_target {
- set me "is_ilp32_target"
-
- set src [standard_temp_file ilp32[pid].c]
- set obj [standard_temp_file ilp32[pid].o]
-
- gdb_produce_source $src {
+ return [gdb_can_simple_compile is_ilp32_target {
int dummy[sizeof (int) == 4
&& sizeof (void *) == 4
&& sizeof (long) == 4 ? 1 : -1];
- }
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
- file delete $src
- file delete $obj
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
- }
-
- verbose "$me: returning 1" 2
- return 1
+ }]
}
# Return 1 if target is LP64.
# This cannot be decided simply from looking at the target string,
# as it might depend on externally passed compiler options like -m64.
gdb_caching_proc is_lp64_target {
- set me "is_lp64_target"
-
- set src [standard_temp_file lp64[pid].c]
- set obj [standard_temp_file lp64[pid].o]
-
- gdb_produce_source $src {
+ return [gdb_can_simple_compile is_lp64_target {
int dummy[sizeof (int) == 4
&& sizeof (void *) == 8
&& sizeof (long) == 8 ? 1 : -1];
- }
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
- file delete $src
- file delete $obj
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
- }
-
- verbose "$me: returning 1" 2
- return 1
+ }]
}
# Return 1 if target has 64 bit addresses.
# This cannot be decided simply from looking at the target string,
# as it might depend on externally passed compiler options like -m64.
gdb_caching_proc is_64_target {
- set me "is_64_target"
-
- set src [standard_temp_file is64[pid].c]
- set obj [standard_temp_file is64[pid].o]
-
- gdb_produce_source $src {
+ return [gdb_can_simple_compile is_64_target {
int function(void) { return 3; }
int dummy[sizeof (&function) == 8 ? 1 : -1];
- }
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
- file delete $src
- file delete $obj
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
- }
-
- verbose "$me: returning 1" 2
- return 1
+ }]
}
# Return 1 if target has x86_64 registers - either amd64 or x32.
return 0
}
- set me "is_amd64_regs_target"
+ return [gdb_can_simple_compile is_amd64_regs_target {
+ int main (void) {
+ asm ("incq %rax");
+ asm ("incq %r15");
- set src [standard_temp_file reg64[pid].s]
- set obj [standard_temp_file reg64[pid].o]
-
- set list {}
- foreach reg \
- {rax rbx rcx rdx rsi rdi rbp rsp r8 r9 r10 r11 r12 r13 r14 r15} {
- lappend list "\tincq %$reg"
+ return 0;
}
- gdb_produce_source $src [join $list \n]
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
- file delete $src
- file delete $obj
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
- }
-
- verbose "$me: returning 1" 2
- return 1
+ }]
}
# Return 1 if this target is an x86 or x86-64 with -m32.
return 0
}
- set me "is_aarch32_target"
-
- set src [standard_temp_file aarch32[pid].s]
- set obj [standard_temp_file aarch32[pid].o]
-
set list {}
foreach reg \
{r0 r1 r2 r3} {
lappend list "\tmov $reg, $reg"
}
- gdb_produce_source $src [join $list \n]
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $obj object {quiet}]
- file delete $src
- file delete $obj
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 0" 2
- return 0
- }
- verbose "$me: returning 1" 2
- return 1
+ return [gdb_can_simple_compile aarch32 [join $list \n]]
}
# Return 1 if this target is an aarch64, either lp64 or ilp32.
}
# Make sure we have a compiler that understands altivec.
- set compile_flags {debug nowarnings}
if [get_compiler_info] {
warning "Could not get compiler info"
return 1
}
if [test_compiler_info gcc*] {
- set compile_flags "$compile_flags additional_flags=-maltivec"
+ set compile_flags "additional_flags=-maltivec"
} elseif [test_compiler_info xlc*] {
- set compile_flags "$compile_flags additional_flags=-qaltivec"
+ set compile_flags "additional_flags=-qaltivec"
} else {
verbose "Could not compile with altivec support, returning 1" 2
return 1
}
- # Set up, compile, and execute a test program containing VMX instructions.
- # Include the current process ID in the file names to prevent conflicts
- # with invocations for multiple testsuites.
- set src [standard_temp_file vmx[pid].c]
- set exe [standard_temp_file vmx[pid].x]
-
- gdb_produce_source $src {
+ # Compile a test program containing VMX instructions.
+ set src {
int main() {
#ifdef __MACH__
asm volatile ("vor v0,v0,v0");
return 0;
}
}
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $exe executable $compile_flags]
- file delete $src
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 1" 2
+ if {![gdb_simple_compile $me $src executable $compile_flags]} {
return 1
}
- # No error message, compilation succeeded so now run it via gdb.
+ # Compilation succeeded so now run it via gdb.
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
- gdb_load "$exe"
+ gdb_load "$obj"
gdb_run_cmd
gdb_expect {
-re ".*Illegal instruction.*${gdb_prompt} $" {
}
}
gdb_exit
- remote_file build delete $exe
+ remote_file build delete $obj
verbose "$me: returning $skip_vmx_tests" 2
return $skip_vmx_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.
-
-gdb_caching_proc skip_vsx_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_vsx_tests"
+ set me "skip_power_isa_3_1_tests"
- # Some simulators are known to not support Altivec instructions, so
- # they won't support VSX instructions as well.
- if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } {
- verbose "$me: target known to not support VSX, returning 1" 2
+ # 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.
+
+gdb_caching_proc skip_vsx_tests {
+ global srcdir subdir gdb_prompt inferior_exited_re
+
+ set me "skip_vsx_tests"
+
+ # Some simulators are known to not support Altivec instructions, so
+ # they won't support VSX instructions as well.
+ if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } {
+ verbose "$me: target known to not support VSX, returning 1" 2
return 1
}
# Make sure we have a compiler that understands altivec.
- set compile_flags {debug nowarnings quiet}
if [get_compiler_info] {
warning "Could not get compiler info"
return 1
}
if [test_compiler_info gcc*] {
- set compile_flags "$compile_flags additional_flags=-mvsx"
+ set compile_flags "additional_flags=-mvsx"
} elseif [test_compiler_info xlc*] {
- set compile_flags "$compile_flags additional_flags=-qasm=gcc"
+ set compile_flags "additional_flags=-qasm=gcc"
} else {
verbose "Could not compile with vsx support, returning 1" 2
return 1
}
- set src [standard_temp_file vsx[pid].c]
- set exe [standard_temp_file vsx[pid].x]
-
- gdb_produce_source $src {
+ # Compile a test program containing VSX instructions.
+ set src {
int main() {
double a[2] = { 1.0, 2.0 };
#ifdef __MACH__
return 0;
}
}
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $exe executable $compile_flags]
- file delete $src
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 1" 2
+ if {![gdb_simple_compile $me $src executable $compile_flags]} {
return 1
}
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
- gdb_load "$exe"
+ gdb_load "$obj"
gdb_run_cmd
gdb_expect {
-re ".*Illegal instruction.*${gdb_prompt} $" {
}
}
gdb_exit
- remote_file build delete $exe
+ remote_file build delete $obj
verbose "$me: returning $skip_vsx_tests" 2
return $skip_vsx_tests
set me "skip_tsx_tests"
- set src [standard_temp_file tsx[pid].c]
- set exe [standard_temp_file tsx[pid].x]
-
- gdb_produce_source $src {
- int main() {
- asm volatile ("xbegin .L0");
- asm volatile ("xend");
- asm volatile (".L0: nop");
- return 0;
- }
+ # Compile a test program.
+ set src {
+ int main() {
+ asm volatile ("xbegin .L0");
+ asm volatile ("xend");
+ asm volatile (".L0: nop");
+ return 0;
+ }
}
-
- verbose "$me: compiling testfile $src" 2
- set lines [gdb_compile $src $exe executable {nowarnings quiet}]
- file delete $src
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed." 2
+ if {![gdb_simple_compile $me $src executable]} {
return 1
}
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
- gdb_load "$exe"
+ gdb_load "$obj"
gdb_run_cmd
gdb_expect {
-re ".*Illegal instruction.*${gdb_prompt} $" {
}
}
gdb_exit
- remote_file build delete $exe
+ remote_file build delete $obj
verbose "$me: returning $skip_tsx_tests" 2
return $skip_tsx_tests
}
-# Run a test on the target to see if it supports btrace hardware. Return 0 if so,
+# 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_btrace_tests {
+gdb_caching_proc skip_avx512bf16_tests {
global srcdir subdir gdb_prompt inferior_exited_re
- set me "skip_btrace_tests"
+ set me "skip_avx512bf16_tests"
if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } {
- verbose "$me: target does not support btrace, returning 1" 2
+ 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
}
- # Set up, compile, and execute a test program.
- # Include the current process ID in the file names to prevent conflicts
- # with invocations for multiple testsuites.
- set src [standard_temp_file btrace[pid].c]
- set exe [standard_temp_file btrace[pid].x]
+ # No error message, compilation succeeded so now run it via gdb.
- gdb_produce_source $src {
- int main(void) { return 0; }
+ 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: compiling testfile $src" 2
- set compile_flags {debug nowarnings quiet}
- set lines [gdb_compile $src $exe executable $compile_flags]
+ verbose "$me: returning $skip_avx512bf16_tests" 2
+ return $skip_avx512bf16_tests
+}
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 1" 2
- file delete $src
+# 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.
+
+gdb_caching_proc skip_btrace_tests {
+ global srcdir subdir gdb_prompt inferior_exited_re
+
+ set me "skip_btrace_tests"
+ if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } {
+ verbose "$me: target does not support btrace, returning 1" 2
+ return 1
+ }
+
+ # Compile a test program.
+ set src { int main() { return 0; } }
+ if {![gdb_simple_compile $me $src executable]} {
return 1
}
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
- gdb_load $exe
+ gdb_load $obj
if ![runto_main] {
- file delete $src
return 1
}
- file delete $src
# In case of an unexpected output, we return 2 as a fail value.
set skip_btrace_tests 2
gdb_test_multiple "record btrace" "check btrace support" {
}
}
gdb_exit
- remote_file build delete $exe
+ remote_file build delete $obj
verbose "$me: returning $skip_btrace_tests" 2
return $skip_btrace_tests
return 1
}
- # Set up, compile, and execute a test program.
- # Include the current process ID in the file names to prevent conflicts
- # with invocations for multiple testsuites.
- set src [standard_temp_file btrace[pid].c]
- set exe [standard_temp_file btrace[pid].x]
-
- gdb_produce_source $src {
- int main(void) { return 0; }
- }
-
- verbose "$me: compiling testfile $src" 2
- set compile_flags {debug nowarnings quiet}
- set lines [gdb_compile $src $exe executable $compile_flags]
-
- if ![string match "" $lines] then {
- verbose "$me: testfile compilation failed, returning 1" 2
- file delete $src
+ # Compile a test program.
+ set src { int main() { return 0; } }
+ if {![gdb_simple_compile $me $src executable]} {
return 1
}
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
- gdb_load $exe
+ gdb_load $obj
if ![runto_main] {
- file delete $src
return 1
}
- file delete $src
# In case of an unexpected output, we return 2 as a fail value.
set skip_btrace_tests 2
- gdb_test_multiple "record btrace pt" "check btrace support" {
+ gdb_test_multiple "record btrace pt" "check btrace pt support" {
-re "You can't do that when your target is.*\r\n$gdb_prompt $" {
set skip_btrace_tests 1
}
-re "Could not enable branch tracing.*\r\n$gdb_prompt $" {
set skip_btrace_tests 1
}
- -re "GDB does not support.*\r\n$gdb_prompt $" {
+ -re "support was disabled at compile time.*\r\n$gdb_prompt $" {
set skip_btrace_tests 1
}
-re "^record btrace pt\r\n$gdb_prompt $" {
}
}
gdb_exit
- remote_file build delete $exe
+ remote_file build delete $obj
verbose "$me: returning $skip_btrace_tests" 2
return $skip_btrace_tests
}
+# Run a test on the target to see if it supports Aarch64 SVE hardware.
+# Return 0 if so, 1 if it does not. Note this causes a restart of GDB.
+
+gdb_caching_proc skip_aarch64_sve_tests {
+ global srcdir subdir gdb_prompt inferior_exited_re
+
+ set me "skip_aarch64_sve_tests"
+
+ if { ![is_aarch64_target]} {
+ return 1
+ }
+
+ set compile_flags "{additional_flags=-march=armv8-a+sve}"
+
+ # Compile a test program containing SVE instructions.
+ set src {
+ int main() {
+ asm volatile ("ptrue p0.b");
+ return 0;
+ }
+ }
+ if {![gdb_simple_compile $me $src executable $compile_flags]} {
+ return 1
+ }
+
+ # Compilation succeeded so now run it via gdb.
+ clean_restart $obj
+ gdb_run_cmd
+ gdb_expect {
+ -re ".*Illegal instruction.*${gdb_prompt} $" {
+ verbose -log "\n$me sve hardware not detected"
+ set skip_sve_tests 1
+ }
+ -re ".*$inferior_exited_re normally.*${gdb_prompt} $" {
+ verbose -log "\n$me: sve hardware detected"
+ set skip_sve_tests 0
+ }
+ default {
+ warning "\n$me: default case taken"
+ set skip_sve_tests 1
+ }
+ }
+ gdb_exit
+ remote_file build delete $obj
+
+ verbose "$me: returning $skip_sve_tests" 2
+ return $skip_sve_tests
+}
+
+
+# A helper that compiles a test case to see if __int128 is supported.
+proc gdb_int128_helper {lang} {
+ return [gdb_can_simple_compile "i128-for-$lang" {
+ __int128 x;
+ int main() { return 0; }
+ } executable $lang]
+}
+
+# Return true if the C compiler understands the __int128 type.
+gdb_caching_proc has_int128_c {
+ return [gdb_int128_helper c]
+}
+
+# Return true if the C++ compiler understands the __int128 type.
+gdb_caching_proc has_int128_cxx {
+ return [gdb_int128_helper c++]
+}
+
+# Return true if the IFUNC feature is unsupported.
+gdb_caching_proc skip_ifunc_tests {
+ if [gdb_can_simple_compile ifunc {
+ extern void f_ ();
+ typedef void F (void);
+ F* g (void) { return &f_; }
+ void f () __attribute__ ((ifunc ("g")));
+ } object] {
+ return 0
+ } else {
+ return 1
+ }
+}
+
# Return whether we should skip tests for showing inlined functions in
# backtraces. Requires get_compiler_info and get_debug_format.
|| [istarget "x86_64-*-*"]
|| [istarget "ia64-*-*"]
|| [istarget "arm*-*-*"]
- || [istarget "aarch64*-*-*"]} {
+ || [istarget "aarch64*-*-*"]
+ || [istarget "s390*-*-*"] } {
return 0
}
return $ok
}
-# Return 0 if we should skip tests that require the libstdc++ stap
+# Return 1 if we should skip tests that require the libstdc++ stap
# probes. This must be invoked while gdb is running, after shared
-# libraries have been loaded.
+# libraries have been loaded. PROMPT_REGEXP is the expected prompt.
+
+proc skip_libstdcxx_probe_tests_prompt { prompt_regexp } {
+ set supported 0
+ gdb_test_multiple "info probe" "check for stap probe in libstdc++" \
+ -prompt "$prompt_regexp" {
+ -re ".*libstdcxx.*catch.*\r\n$prompt_regexp" {
+ set supported 1
+ }
+ -re "\r\n$prompt_regexp" {
+ }
+ }
+ set skip [expr !$supported]
+ return $skip
+}
+
+# As skip_libstdcxx_probe_tests_prompt, with gdb_prompt.
proc skip_libstdcxx_probe_tests {} {
global gdb_prompt
-
- set ok 0
- gdb_test_multiple "info probe" "check for stap probe in libstdc++" {
- -re ".*libstdcxx.*catch.*\r\n$gdb_prompt $" {
- set ok 1
- }
- -re "\r\n$gdb_prompt $" {
- }
- }
- return $ok
+ return [skip_libstdcxx_probe_tests_prompt "$gdb_prompt $"]
}
# Return 1 if we should skip tests of the "compile" feature.
return $result
}
-# Helper for gdb_is_target_remote. PROMPT_REGEXP is the expected
-# prompt.
-
-proc gdb_is_target_remote_prompt { prompt_regexp } {
+# Helper for gdb_is_target_* procs. TARGET_NAME is the name of the target
+# we're looking for (used to build the test name). TARGET_STACK_REGEXP
+# is a regexp that will match the output of "maint print target-stack" if
+# the target in question is currently pushed. PROMPT_REGEXP is a regexp
+# matching the expected prompt after the command output.
- set test "probe for target remote"
- gdb_test_multiple "maint print target-stack" $test {
- -re ".*emote serial target in gdb-specific protocol.*$prompt_regexp" {
- pass $test
- return 1
- }
- -re "$prompt_regexp" {
- pass $test
+proc gdb_is_target_1 { target_name target_stack_regexp prompt_regexp } {
+ set test "probe for target ${target_name}"
+ gdb_test_multiple "maint print target-stack" $test \
+ -prompt "$prompt_regexp" {
+ -re "${target_stack_regexp}${prompt_regexp}" {
+ pass $test
+ return 1
+ }
+ -re "$prompt_regexp" {
+ pass $test
+ }
}
- }
return 0
}
+# Helper for gdb_is_target_remote where the expected prompt is variable.
+
+proc gdb_is_target_remote_prompt { prompt_regexp } {
+ return [gdb_is_target_1 "remote" ".*emote serial target in gdb-specific protocol.*" $prompt_regexp]
+}
+
# Check whether we're testing with the remote or extended-remote
# targets.
-proc gdb_is_target_remote {} {
+proc gdb_is_target_remote { } {
global gdb_prompt
return [gdb_is_target_remote_prompt "$gdb_prompt $"]
}
+# Check whether we're testing with the native target.
+
+proc gdb_is_target_native { } {
+ global gdb_prompt
+
+ return [gdb_is_target_1 "native" ".*native \\(Native process\\).*" "$gdb_prompt $"]
+}
+
# Return the effective value of use_gdb_stub.
#
# If the use_gdb_stub global has been set (it is set when the gdb process is
# 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
global gdb_prompt
set is_gdbserver -1
- set test "Probing for GDBserver"
+ set test "probing for GDBserver"
gdb_test_multiple "monitor help" $test {
-re "The following monitor commands are supported.*Quit GDBserver.*$gdb_prompt $" {
# We have to use -E and -o together, despite the comments
# above, because of how DejaGnu handles remote host testing.
set ppout "$outdir/compiler.i"
- gdb_compile "${ifile}" "$ppout" preprocess [list "$arg" quiet]
+ gdb_compile "${ifile}" "$ppout" preprocess [list "$arg" quiet getting_compiler_info]
set file [open $ppout r]
set cppout [read $file]
close $file
} else {
- set cppout [ gdb_compile "${ifile}" "" preprocess [list "$arg" quiet] ]
+ set cppout [ gdb_compile "${ifile}" "" preprocess [list "$arg" quiet getting_compiler_info] ]
}
eval log_file $saved_log
}
# Set the legacy symbols.
- set gcc_compiled 0
- if { [regexp "^gcc-1-" "$compiler_info" ] } { set gcc_compiled 1 }
- if { [regexp "^gcc-2-" "$compiler_info" ] } { set gcc_compiled 2 }
- if { [regexp "^gcc-3-" "$compiler_info" ] } { set gcc_compiled 3 }
- if { [regexp "^gcc-4-" "$compiler_info" ] } { set gcc_compiled 4 }
- if { [regexp "^gcc-5-" "$compiler_info" ] } { set gcc_compiled 5 }
+ set gcc_compiled 0
+ regexp "^gcc-(\[0-9\]+)-" "$compiler_info" matchall gcc_compiled
# Log what happened.
verbose -log "get_compiler_info: $compiler_info"
return [string match $compiler $compiler_info]
}
+# 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 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
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]
}
+# Determine options that we always want to pass to the compiler.
+gdb_caching_proc universal_compile_options {
+ set me "universal_compile_options"
+ set options {}
+
+ set src [standard_temp_file ccopts[pid].c]
+ set obj [standard_temp_file ccopts[pid].o]
+
+ gdb_produce_source $src {
+ int foo(void) { return 0; }
+ }
+
+ # Try an option for disabling colored diagnostics. Some compilers
+ # yield colored diagnostics by default (when run from a tty) unless
+ # such an option is specified.
+ set opt "additional_flags=-fdiagnostics-color=never"
+ set lines [target_compile $src $obj object [list "quiet" $opt]]
+ if [string match "" $lines] then {
+ # Seems to have worked; use the option.
+ lappend options $opt
+ }
+ file delete $src
+ file delete $obj
+
+ verbose "$me: returning $options" 2
+ return $options
+}
+
+# Compile the code in $code to a file based on $name, using the flags
+# $compile_flag as well as debug, nowarning and quiet.
+# Return 1 if code can be compiled
+# Leave the file name of the resulting object in the upvar object.
+
+proc gdb_simple_compile {name code {type object} {compile_flags {}} {object obj}} {
+ upvar $object obj
+
+ switch -regexp -- $type {
+ "executable" {
+ set postfix "x"
+ }
+ "object" {
+ set postfix "o"
+ }
+ "preprocess" {
+ set postfix "i"
+ }
+ "assembly" {
+ set postfix "s"
+ }
+ }
+ set ext "c"
+ foreach flag $compile_flags {
+ if { "$flag" == "go" } {
+ set ext "go"
+ break
+ }
+ }
+ set src [standard_temp_file $name-[pid].$ext]
+ set obj [standard_temp_file $name-[pid].$postfix]
+ set compile_flags [concat $compile_flags {debug nowarnings quiet}]
+
+ gdb_produce_source $src $code
+
+ verbose "$name: compiling testfile $src" 2
+ set lines [gdb_compile $src $obj $type $compile_flags]
+
+ file delete $src
+
+ if ![string match "" $lines] then {
+ verbose "$name: compilation failed, returning 0" 2
+ return 0
+ }
+ return 1
+}
+
+# Compile the code in $code to a file based on $name, using the flags
+# $compile_flag as well as debug, nowarning and quiet.
+# Return 1 if code can be compiled
+# Delete all created files and objects.
+
+proc gdb_can_simple_compile {name code {type object} {compile_flags ""}} {
+ set ret [gdb_simple_compile $name $code $type $compile_flags temp_obj]
+ file delete $temp_obj
+ return $ret
+}
+
# Some targets need to always link a special object in. Save its path here.
global gdb_saved_set_unbuffered_mode_obj
set gdb_saved_set_unbuffered_mode_obj ""
# dynamically load libraries at runtime. For example, on Linux, this adds
# -ldl so that the test can use dlopen.
# - nowarnings: Inhibit all compiler warnings.
+# - pie: Force creation of PIE executables.
+# - nopie: Prevent creation of PIE executables.
#
# And here are some of the not too obscure options understood by DejaGnu that
# influence the compilation:
# - 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
# Add platform-specific options if a shared library was specified using
# "shlib=librarypath" in OPTIONS.
- set new_options ""
+ set new_options {}
+ if {[lsearch -exact $options rust] != -1} {
+ # -fdiagnostics-color is not a rustcc option.
+ } else {
+ 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 ""]
+ if [test_compiler_info "gcc-*"] {
+ lappend new_options "additional_flags=-J${mod_path}"
+ }
+ }
+
set shlib_found 0
set shlib_load 0
+ set getting_compiler_info 0
foreach opt $options {
- if [regexp {^shlib=(.*)} $opt dummy_var shlib_name] {
+ if {[regexp {^shlib=(.*)} $opt dummy_var shlib_name]
+ && $type == "executable"} {
if [test_compiler_info "xlc-*"] {
# IBM xlc compiler doesn't accept shared library named other
# than .so: use "-Wl," to bypass this
lappend new_options "early_flags=-Wl,--no-as-needed"
}
}
- } elseif { $opt == "shlib_load" } {
+ } elseif { $opt == "shlib_load" && $type == "executable" } {
set shlib_load 1
+ } elseif { $opt == "getting_compiler_info" } {
+ # If this is set, calling test_compiler_info will cause recursion.
+ set getting_compiler_info 1
} else {
lappend new_options $opt
}
}
+ # Ensure stack protector is disabled for GCC, as this causes problems with
+ # DWARF line numbering.
+ # See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88432
+ # This option defaults to on for Debian/Ubuntu.
+ if { $getting_compiler_info == 0
+ && [test_compiler_info {gcc-*-*}]
+ && !([test_compiler_info {gcc-[0-3]-*}]
+ || [test_compiler_info {gcc-4-0-*}])
+ && [lsearch -exact $options rust] == -1} {
+ # Put it at the front to not override any user-provided value.
+ lappend new_options "early_flags=-fno-stack-protector"
+ }
+
# Because we link with libraries using their basename, we may need
# (depending on the platform) to set a special rpath value, to allow
# the executable to find the libraries it depends on.
# 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"
verbose "options are $options"
verbose "source is $source $dest $type $options"
- if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init }
+ gdb_wrapper_init
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}"
}
set options [lreplace $options $nowarnings $nowarnings $flag]
}
+ # Replace the "pie" option with the appropriate compiler and linker flags
+ # to enable PIE executables.
+ set pie [lsearch -exact $options pie]
+ if {$pie != -1} {
+ if [target_info exists gdb,pie_flag] {
+ set flag "additional_flags=[target_info gdb,pie_flag]"
+ } else {
+ # For safety, use fPIE rather than fpie. On AArch64, m68k, PowerPC
+ # and SPARC, fpie can cause compile errors due to the GOT exceeding
+ # a maximum size. On other architectures the two flags are
+ # identical (see the GCC manual). Note Debian9 and Ubuntu16.10
+ # onwards default GCC to using fPIE. If you do require fpie, then
+ # it can be set using the pie_flag.
+ set flag "additional_flags=-fPIE"
+ }
+ set options [lreplace $options $pie $pie $flag]
+
+ if [target_info exists gdb,pie_ldflag] {
+ set flag "ldflags=[target_info gdb,pie_ldflag]"
+ } else {
+ set flag "ldflags=-pie"
+ }
+ lappend options "$flag"
+ }
+
+ # 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 "additional_flags=[target_info gdb,nopie_flag]"
+ } else {
+ 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" } {
if { ([istarget "*-*-mingw*"]
|| [istarget "*-*-*djgpp"]
# Force output to unbuffered mode, by linking in an object file
# with a global contructor that calls setvbuf.
#
- # Compile the special object seperatelly for two reasons:
+ # Compile the special object separately for two reasons:
# 1) Insulate it from $options.
# 2) Avoid compiling it for every gdb_compile invocation,
# which is time consuming, especially if we're remote
regsub "\[\r\n\]*$" "$result" "" result
regsub "^\[\r\n\]*" "$result" "" result
- if {[lsearch $options quiet] < 0} {
+ if { $type == "executable" && $result == "" \
+ && ($nopie != -1 || $pie != -1) } {
+ set is_pie [exec_is_pie "$dest"]
+ if { $nopie != -1 && $is_pie == 1 } {
+ set result "nopie failed to prevent PIE executable"
+ } elseif { $pie != -1 && $is_pie == 0 } {
+ set result "pie failed to generate PIE executable"
+ }
+ }
+
+ if {[lsearch $options quiet] < 0} {
# We shall update this on a per language basis, to avoid
# changing the entire testsuite in one go.
if {[lsearch $options f77] >= 0} {
# against several different thread libraries, to see which one this
# system has.
proc gdb_compile_pthreads {source dest type options} {
+ if {$type != "executable"} {
+ return [gdb_compile $source $dest $type $options]
+ }
set built_binfile 0
set why_msg "unrecognized error"
foreach lib {-lpthreads -lpthread -lthread ""} {
}
}
if {!$built_binfile} {
- unsupported "Couldn't compile [file tail $source]: ${why_msg}"
+ unsupported "couldn't compile [file tail $source]: ${why_msg}"
return -1
}
}
# 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 {[gdb_compile $source "${outdir}/${sourcebase}.o" object $obj_options] != ""} {
- return -1
- }
- lappend objects ${outdir}/${sourcebase}.o
+ if {[file extension $source] == ".o"} {
+ # Already a .o file.
+ lappend objects $source
+ 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 {
+ 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
}
}
}
if {!$built_binfile} {
- unsupported "Couldn't compile $sources: ${why_msg}"
+ unsupported "couldn't compile $sources: ${why_msg}"
return -1
}
}
}
}
if {!$built_binfile} {
- unsupported "Couldn't compile [file tail $source]: ${why_msg}"
+ unsupported "couldn't compile [file tail $source]: ${why_msg}"
return -1
}
}
-proc send_gdb { string } {
- global suppress_flag
- if { $suppress_flag } {
- return "suppressed"
- }
+# Build an OpenMP program from SOURCE. See prefatory comment for
+# gdb_compile, above, for discussion of the parameters to this proc.
+
+proc gdb_compile_openmp {source dest type options} {
+ lappend options "additional_flags=-fopenmp"
+ return [gdb_compile $source $dest $type $options]
+}
+
+# Send a command to GDB.
+# For options for TYPE see gdb_stdin_log_write
+
+proc send_gdb { string {type standard}} {
+ 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
}
# Copy the listed library to the target.
proc gdb_load_shlib { file } {
+ global gdb_spawn_id
+
+ if ![info exists gdb_spawn_id] {
+ perror "gdb_load_shlib: GDB is not running"
+ }
+
set dest [gdb_remote_download target [shlib_target_file $file]]
if {[is_remote target]} {
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
+
+ # 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
- gdb_clear_suppressed
+ # 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.
set dir [make_gdb_parallel_path outputs $subdir $gdb_test_file_name]
file mkdir $dir
+ # If running on MinGW, replace /c/foo with c:/foo
+ if { [ishost *-*-mingw*] } {
+ set dir [exec sh -c "cd ${dir} && pwd -W"]
+ }
return [file join $dir $basename]
}
+# Turn BASENAME into a full file name in the standard output directory. If
+# GDB has been launched more than once then append the count, starting with
+# a ".1" postfix.
+
+proc standard_output_file_with_gdb_instance {basename} {
+ global gdb_instances
+ set count $gdb_instances
+
+ if {$count == 0} {
+ return [standard_output_file $basename]
+ }
+ return [standard_output_file ${basename}.${count}]
+}
+
# Return the name of a file in our standard temporary directory.
proc standard_temp_file {basename} {
return [file join $dir $basename]
}
+# Rename file A to file B, if B does not already exists. Otherwise, leave B
+# 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
+ }
+ return 1
+}
+
+# Create a file with name FILENAME and contents TXT in the cache directory.
+# If EXECUTABLE, mark the new file for execution.
+
+proc cached_file { filename txt {executable 0}} {
+ set filename [make_gdb_parallel_path cache $filename]
+
+ if { [file exists $filename] } {
+ return $filename
+ }
+
+ set dir [file dirname $filename]
+ file mkdir $dir
+
+ set tmp_filename $filename.[pid]
+ set fd [open $tmp_filename w]
+ puts $fd $txt
+ close $fd
+
+ if { $executable } {
+ exec chmod +x $tmp_filename
+ }
+ tentative_rename $tmp_filename $filename
+
+ return $filename
+}
+
# Set 'testfile', 'srcfile', and 'binfile'.
#
# ARGS is a list of source file specifications.
# 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
+
+ array set gdb_known_globals {}
+ foreach varname [info globals] {
+ set gdb_known_globals($varname) 1
}
+}
- # 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
+# 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
- set exclusions {outputs temp gdb[.](log|sum) cache}
- set exclusion_re ([join $exclusions |])
+ foreach varname [info globals] {
+ if {![info exists gdb_known_globals($varname)]} {
+ if { [info exists gdb_persistent_globals($varname)] } {
+ continue
+ }
+ uplevel #0 unset $varname
+ }
+ }
+}
- 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 &]
+# 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
- # 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
-
- # 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"
-
- # The gdb.base/readline.exp arrow key test relies on the standard VT100
- # bindings, so make sure that an appropriate terminal is selected.
- # The same bug doesn't show up if we use ^P / ^N instead.
- setenv TERM "vt100"
-
- # 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
-
- 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
proc get_debug_format { } {
global gdb_prompt
- global verbose
global expect_out
global debug_format
send_gdb "run\n"
gdb_expect {
-re "The program .* has been started already.*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "Starting program.*$gdb_prompt $"\
}
}
+# Return true if EXECUTABLE contains a .gdb_index or .debug_names index section.
+
+proc exec_has_index_section { executable } {
+ set readelf_program [gdb_find_readelf]
+ set res [catch {exec $readelf_program -S $executable \
+ | grep -E "\.gdb_index|\.debug_names" }]
+ if { $res == 0 } {
+ return 1
+ }
+ return 0
+}
+
+# Return list with major and minor version of readelf, or an empty list.
+gdb_caching_proc readelf_version {
+ set readelf_program [gdb_find_readelf]
+ set res [catch {exec $readelf_program --version} output]
+ if { $res != 0 } {
+ return [list]
+ }
+ set lines [split $output \n]
+ set line [lindex $lines 0]
+ set res [regexp {[ \t]+([0-9]+)[.]([0-9]+)[^ \t]*$} \
+ $line dummy major minor]
+ if { $res != 1 } {
+ return [list]
+ }
+ return [list $major $minor]
+}
+
+# Return 1 if readelf prints the PIE flag, 0 if is doesn't, and -1 if unknown.
+proc readelf_prints_pie { } {
+ set version [readelf_version]
+ if { [llength $version] == 0 } {
+ return -1
+ }
+ set major [lindex $version 0]
+ set minor [lindex $version 1]
+ # It would be better to construct a PIE executable and test if the PIE
+ # flag is printed by readelf, but we cannot reliably construct a PIE
+ # executable if the multilib_flags dictate otherwise
+ # (--target_board=unix/-no-pie/-fno-PIE).
+ return [version_at_least $major $minor 2 26]
+}
+
+# Return 1 if EXECUTABLE is a Position Independent Executable, 0 if it is not,
+# and -1 if unknown.
+
+proc exec_is_pie { executable } {
+ set res [readelf_prints_pie]
+ if { $res != 1 } {
+ return -1
+ }
+ set readelf_program [gdb_find_readelf]
+ # 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 {^[ \t]*Type:[ \t]*DYN \((Position-Independent Executable|Shared object) file\)$} \
+ $output]
+ if { $res == 1 } {
+ return 1
+ }
+ return 0
+}
+
# Return true if a test should be skipped due to lack of floating
# point support or GDB can't fetch the contents from floating point
# registers.
# NOTE: This must be called while gdb is *not* running.
gdb_caching_proc gdb_skip_xml_test {
+ global gdb_spawn_id
global gdb_prompt
global srcdir
+ if { [info exists gdb_spawn_id] } {
+ error "GDB must not be running in gdb_skip_xml_tests."
+ }
+
set xml_file [gdb_remote_download host "${srcdir}/gdb.xml/trivial.xml"]
gdb_start
gdb_caching_proc gdb_has_argv0 {
set result 0
- # Set up, compile, and execute a test program to check whether
- # argv[0] is available.
- set src [standard_temp_file has_argv0[pid].c]
- set exe [standard_temp_file has_argv0[pid].x]
-
- gdb_produce_source $src {
+ # Compile and execute a test program to check whether argv[0] is available.
+ gdb_simple_compile has_argv0 {
int main (int argc, char **argv) {
return 0;
}
- }
+ } executable
- gdb_compile $src $exe executable {debug}
# Helper proc.
proc gdb_has_argv0_1 { exe } {
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} $" {
return $retval
}
- set result [gdb_has_argv0_1 $exe]
+ set result [gdb_has_argv0_1 $obj]
gdb_exit
- file delete $src
- file delete $exe
+ file delete $obj
if { !$result
&& ([istarget *-*-linux*]
|| [istarget *-*-cygwin*] || [istarget *-*-mingw32*]
|| [istarget *-*-*djgpp*] || [istarget *-*-go32*]
|| [istarget *-wince-pe] || [istarget *-*-mingw32ce*]
- || [istarget *-*-symbianelf*]
|| [istarget *-*-osf*]
|| [istarget *-*-dicos*]
|| [istarget *-*-nto*]
# Test the output of GDB_COMMAND matches the pattern obtained
# by concatenating all elements of EXPECTED_LINES. This makes
# it possible to split otherwise very long string into pieces.
-# If third argument is not empty, it's used as the name of the
+# If third argument TESTNAME is not empty, it's used as the name of the
# test to be printed on pass/fail.
-proc help_test_raw { gdb_command expected_lines args } {
- set message $gdb_command
- if [llength $args]>0 then {
- set message [lindex $args 0]
- }
+proc help_test_raw { gdb_command expected_lines {testname {}} } {
set expected_output [join $expected_lines ""]
- gdb_test "${gdb_command}" "${expected_output}" $message
+ if {$testname != {}} {
+ gdb_test "${gdb_command}" "${expected_output}" $testname
+ return
+ }
+
+ gdb_test "${gdb_command}" "${expected_output}"
}
-# Test the output of "help COMMAND_CLASS". EXPECTED_INITIAL_LINES
+# A regexp that matches the end of help CLASS|PREFIX_COMMAND
+set help_list_trailer {
+ "Type \"apropos word\" to search for commands related to \"word\"\.[\r\n]+"
+ "Type \"apropos -v word\" for full documentation of commands related to \"word\"\.[\r\n]+"
+ "Command name abbreviations are allowed if unambiguous\."
+}
+
+# Test the output of "help COMMAND_CLASS". EXPECTED_INITIAL_LINES
# are regular expressions that should match the beginning of output,
-# before the list of commands in that class. The presence of
-# command list and standard epilogue will be tested automatically.
+# before the list of commands in that class.
+# LIST_OF_COMMANDS are regular expressions that should match the
+# list of commands in that class. If empty, the command list will be
+# matched automatically. The presence of standard epilogue will be tested
+# automatically.
+# If last argument TESTNAME is not empty, it's used as the name of the
+# test to be printed on pass/fail.
# Notice that the '[' and ']' characters don't need to be escaped for strings
# wrapped in {} braces.
-proc test_class_help { command_class expected_initial_lines args } {
+proc test_class_help { command_class expected_initial_lines {list_of_commands {}} {testname {}} } {
+ global help_list_trailer
+ if {[llength $list_of_commands]>0} {
+ set l_list_of_commands {"List of commands:[\r\n]+[\r\n]+"}
+ set l_list_of_commands [concat $l_list_of_commands $list_of_commands]
+ set l_list_of_commands [concat $l_list_of_commands {"[\r\n]+[\r\n]+"}]
+ } else {
+ set l_list_of_commands {"List of commands\:.*[\r\n]+"}
+ }
set l_stock_body {
- "List of commands\:.*[\r\n]+"
"Type \"help\" followed by command name for full documentation\.[\r\n]+"
- "Type \"apropos word\" to search for commands related to \"word\"\.[\r\n]+"
- "Command name abbreviations are allowed if unambiguous\."
}
- set l_entire_body [concat $expected_initial_lines $l_stock_body]
+ set l_entire_body [concat $expected_initial_lines $l_list_of_commands \
+ $l_stock_body $help_list_trailer]
+
+ help_test_raw "help ${command_class}" $l_entire_body $testname
+}
- eval [list help_test_raw "help ${command_class}" $l_entire_body] $args
+# Like test_class_help but specialised to test "help user-defined".
+proc test_user_defined_class_help { {list_of_commands {}} {testname {}} } {
+ test_class_help "user-defined" {
+ "User-defined commands\.[\r\n]+"
+ "The commands in this class are those defined by the user\.[\r\n]+"
+ "Use the \"define\" command to define a command\.[\r\n]+"
+ } $list_of_commands $testname
}
+
# COMMAND_LIST should have either one element -- command to test, or
# two elements -- abbreviated command to test, and full command the first
# element is abbreviation of.
# before the list of subcommands. The presence of
# subcommand list and standard epilogue will be tested automatically.
proc test_prefix_command_help { command_list expected_initial_lines args } {
+ global help_list_trailer
set command [lindex $command_list 0]
if {[llength $command_list]>1} {
set full_command [lindex $command_list 1]
# be expanded in this list.
set l_stock_body [list\
"List of $full_command subcommands\:.*\[\r\n\]+"\
- "Type \"help $full_command\" followed by $full_command subcommand name for full documentation\.\[\r\n\]+"\
- "Type \"apropos word\" to search for commands related to \"word\"\.\[\r\n\]+"\
- "Command name abbreviations are allowed if unambiguous\."]
- set l_entire_body [concat $expected_initial_lines $l_stock_body]
+ "Type \"help $full_command\" followed by $full_command subcommand name for full documentation\.\[\r\n\]+"]
+ set l_entire_body [concat $expected_initial_lines $l_stock_body $help_list_trailer]
if {[llength $args]>0} {
help_test_raw "help ${command}" $l_entire_body [lindex $args 0]
} else {
}
set func gdb_compile
- set func_index [lsearch -regexp $options {^(pthreads|shlib|shlib_pthreads)$}]
+ set func_index [lsearch -regexp $options {^(pthreads|shlib|shlib_pthreads|openmp)$}]
if {$func_index != -1} {
set func "${func}_[lindex $options $func_index]"
}
if { ! [regexp "^/" "$s"] } then {
set s "$srcdir/$subdir/$s"
}
- if { [gdb_compile "${s}" "${binfile}${i}.o" object $local_options] != "" } {
+ if { [$func "${s}" "${binfile}${i}.o" object $local_options] != "" } {
untested $testname
return -1
}
# 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 0
}
-proc get_valueof { fmt exp default } {
+# Retrieve the value of EXP in the inferior, represented in format
+# specified in FMT (using "printFMT"). 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_valueof { fmt exp default {test ""} } {
global gdb_prompt
- set test "get valueof \"${exp}\""
+ if {$test == "" } {
+ set test "get valueof \"${exp}\""
+ }
+
set val ${default}
gdb_test_multiple "print${fmt} ${exp}" "$test" {
- -re "\\$\[0-9\]* = (.*)\[\r\n\]*$gdb_prompt $" {
+ -re "\\$\[0-9\]* = (\[^\r\n\]*)\[\r\n\]*$gdb_prompt $" {
+ set val $expect_out(1,string)
+ pass "$test"
+ }
+ timeout {
+ fail "$test (timeout)"
+ }
+ }
+ 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 ($val)"
+ pass "$test"
}
timeout {
fail "$test (timeout)"
return ${val}
}
-proc get_integer_valueof { exp default } {
+# 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
+# a test message is built from EXP.
+
+proc get_integer_valueof { exp default {test ""} } {
global gdb_prompt
- set test "get integer valueof \"${exp}\""
+ if {$test == ""} {
+ set test "get integer valueof \"${exp}\""
+ }
+
set val ${default}
gdb_test_multiple "print /d ${exp}" "$test" {
-re "\\$\[0-9\]* = (\[-\]*\[0-9\]*).*$gdb_prompt $" {
set val $expect_out(1,string)
- pass "$test ($val)"
+ pass "$test"
}
timeout {
fail "$test (timeout)"
# Retrieve the value of EXP in the inferior, as an hexadecimal value
# (using "print /x"). DEFAULT is used as fallback if print fails.
-# TEST is the test message to use. If can be ommitted, in which case
+# TEST is the test message to use. It can be omitted, in which case
# a test message is built from EXP.
proc get_hexadecimal_valueof { exp default {test ""} } {
return ${val}
}
-proc get_sizeof { type default } {
- return [get_integer_valueof "sizeof (${type})" $default]
+# Retrieve the size of TYPE in the inferior, as a decimal value. 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 'sizeof (TYPE)'.
+
+proc get_sizeof { type default {test ""} } {
+ return [get_integer_valueof "sizeof (${type})" $default $test]
}
proc get_target_charset { } {
return "UTF-8"
}
+# Get the address of VAR.
+
+proc get_var_address { var } {
+ global gdb_prompt hex
+
+ # Match output like:
+ # $1 = (int *) 0x0
+ # $5 = (int (*)()) 0
+ # $6 = (int (*)()) 0x24 <function_bar>
+
+ gdb_test_multiple "print &${var}" "get address of ${var}" {
+ -re "\\\$\[0-9\]+ = \\(.*\\) (0|$hex)( <${var}>)?\[\r\n\]+${gdb_prompt} $"
+ {
+ pass "get address of ${var}"
+ if { $expect_out(1,string) == "0" } {
+ return "0x0"
+ } else {
+ return $expect_out(1,string)
+ }
+ }
+ }
+ return ""
+}
+
+# Return the frame number for the currently selected frame
+proc get_current_frame_number {{test_name ""}} {
+ global gdb_prompt
+
+ if { $test_name == "" } {
+ set test_name "get current frame number"
+ }
+ set frame_num -1
+ gdb_test_multiple "frame" $test_name {
+ -re "#(\[0-9\]+) .*$gdb_prompt $" {
+ set frame_num $expect_out(1,string)
+ }
+ }
+ return $frame_num
+}
+
# Get the current value for remotetimeout and return it.
proc get_remotetimeout { } {
global gdb_prompt
}
}
+# Get the target's current endianness and return it.
+proc get_endianness { } {
+ global gdb_prompt
+
+ gdb_test_multiple "show endian" "determine endianness" {
+ -re ".* (little|big) endian.*\r\n$gdb_prompt $" {
+ # Pass silently.
+ return $expect_out(1,string)
+ }
+ }
+ return "little"
+}
+
# ROOT and FULL are file names. Returns the relative path from ROOT
# to FULL. Note that FULL must be in a subdirectory of ROOT.
# For example, given ROOT = /usr/bin and FULL = /usr/bin/ls, this
return [eval file join [lrange $full_split $len end]]
}
-# Log gdb command line and script if requested.
-if {[info exists TRANSCRIPT]} {
- rename send_gdb real_send_gdb
- rename remote_spawn real_remote_spawn
- rename remote_close real_remote_close
-
- global gdb_transcript
- set gdb_transcript ""
-
- global gdb_trans_count
- set gdb_trans_count 1
-
- proc remote_spawn {args} {
- global gdb_transcript gdb_trans_count outdir
-
- if {$gdb_transcript != ""} {
- close $gdb_transcript
- }
- set gdb_transcript [open [file join $outdir transcript.$gdb_trans_count] w]
- puts $gdb_transcript [lindex $args 1]
- incr gdb_trans_count
-
- return [uplevel real_remote_spawn $args]
- }
-
- proc remote_close {args} {
- global gdb_transcript
-
- if {$gdb_transcript != ""} {
- close $gdb_transcript
- set gdb_transcript ""
- }
-
- return [uplevel real_remote_close $args]
- }
-
- proc send_gdb {args} {
- global gdb_transcript
-
- if {$gdb_transcript != ""} {
- puts -nonewline $gdb_transcript [lindex $args 0]
- }
-
- return [uplevel real_send_gdb $args]
- }
-}
-
# If GDB_PARALLEL exists, then set up the parallel-mode directories.
if {[info exists GDB_PARALLEL]} {
if {[is_remote host]} {
# for linker symbol prefixes.
gdb_caching_proc gdb_target_symbol_prefix {
- # Set up and compile a simple test program...
- set src [standard_temp_file main[pid].c]
- set exe [standard_temp_file main[pid].x]
+ # Compile a simple test program...
+ set src { int main() { return 0; } }
+ if {![gdb_simple_compile target_symbol_prefix $src executable]} {
+ return 0
+ }
- gdb_produce_source $src {
- int main() {
- return 0;
- }
+ set prefix ""
+
+ set objdump_program [gdb_find_objdump]
+ set result [catch "exec $objdump_program --syms $obj" output]
+
+ if { $result == 0 \
+ && ![regexp -lineanchor \
+ { ([^ a-zA-Z0-9]*)main$} $output dummy prefix] } {
+ verbose "gdb_target_symbol_prefix: Could not find main in objdump output; returning null prefix" 2
}
- verbose "compiling testfile $src" 2
- set compile_flags {debug nowarnings quiet}
- set lines [gdb_compile $src $exe executable $compile_flags]
+ file delete $obj
+
+ return $prefix
+}
- set prefix ""
+# Return 1 if target supports scheduler locking, otherwise return 0.
- if ![string match "" $lines] then {
- verbose "gdb_target_symbol_prefix: testfile compilation failed, returning null prefix" 2
- } else {
- set objdump_program [gdb_find_objdump]
- set result [catch "exec $objdump_program --syms $exe" output]
+gdb_caching_proc target_supports_scheduler_locking {
+ global gdb_prompt
+
+ set me "gdb_target_supports_scheduler_locking"
+
+ set src { int main() { return 0; } }
+ if {![gdb_simple_compile $me $src executable]} {
+ return 0
+ }
+
+ clean_restart $obj
+ if ![runto_main] {
+ return 0
+ }
- if { $result == 0 \
- && ![regexp -lineanchor \
- { ([^ a-zA-Z0-9]*)main$} $output dummy prefix] } {
- verbose "gdb_target_symbol_prefix: Could not find main in objdump output; returning null prefix" 2
+ set supports_schedule_locking -1
+ set current_schedule_locking_mode ""
+
+ set test "reading current scheduler-locking mode"
+ gdb_test_multiple "show scheduler-locking" $test {
+ -re "Mode for locking scheduler during execution is \"(\[\^\"\]*)\".*$gdb_prompt" {
+ set current_schedule_locking_mode $expect_out(1,string)
+ }
+ -re "$gdb_prompt $" {
+ set supports_schedule_locking 0
+ }
+ timeout {
+ set supports_schedule_locking 0
}
}
- file delete $src
- file delete $exe
+ if { $supports_schedule_locking == -1 } {
+ set test "checking for scheduler-locking support"
+ gdb_test_multiple "set scheduler-locking $current_schedule_locking_mode" $test {
+ -re "Target '\[^'\]+' cannot support this command\..*$gdb_prompt $" {
+ set supports_schedule_locking 0
+ }
+ -re "$gdb_prompt $" {
+ set supports_schedule_locking 1
+ }
+ timeout {
+ set supports_schedule_locking 0
+ }
+ }
+ }
- return $prefix
+ if { $supports_schedule_locking == -1 } {
+ set supports_schedule_locking 0
+ }
+
+ gdb_exit
+ remote_file build delete $obj
+ verbose "$me: returning $supports_schedule_locking" 2
+ return $supports_schedule_locking
+}
+
+# Return 1 if compiler supports use of nested functions. Otherwise,
+# return 0.
+
+gdb_caching_proc support_nested_function_tests {
+ # Compile a test program containing a nested function
+ return [gdb_can_simple_compile nested_func {
+ int main () {
+ int foo () {
+ return 0;
+ }
+ return foo ();
+ }
+ } executable]
}
# gdb_target_symbol returns the provided symbol with the correct prefix
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"]
}
-# Always load compatibility stuff.
-load_lib future.exp
+# Similar to the above, but while multi_line is meant to be used to
+# match GDB output, this one is meant to be used to build strings to
+# send as GDB input.
+
+proc multi_line_input { args } {
+ return [join $args "\n"]
+}
+
+# Return the version of the DejaGnu framework.
+#
+# The return value is a list containing the major, minor and patch version
+# numbers. If the version does not contain a minor or patch number, they will
+# be set to 0. For example:
+#
+# 1.6 -> {1 6 0}
+# 1.6.1 -> {1 6 1}
+# 2 -> {2 0 0}
+
+proc dejagnu_version { } {
+ # The frame_version variable is defined by DejaGnu, in runtest.exp.
+ global frame_version
+
+ verbose -log "DejaGnu version: $frame_version"
+ verbose -log "Expect version: [exp_version]"
+ verbose -log "Tcl version: [info tclversion]"
+
+ set dg_ver [split $frame_version .]
+
+ while { [llength $dg_ver] < 3 } {
+ lappend dg_ver 0
+ }
+
+ return $dg_ver
+}
+
+# Define user-defined command COMMAND using the COMMAND_LIST as the
+# command's definition. The terminating "end" is added automatically.
+
+proc gdb_define_cmd {command command_list} {
+ global gdb_prompt
+
+ set input [multi_line_input {*}$command_list "end"]
+ set test "define $command"
+
+ gdb_test_multiple "define $command" $test {
+ -re "End with" {
+ gdb_test_multiple $input $test {
+ -re "\r\n$gdb_prompt " {
+ }
+ }
+ }
+ }
+}
+
+# Override the 'cd' builtin with a version that ensures that the
+# log file keeps pointing at the same file. We need this because
+# unfortunately the path to the log file is recorded using an
+# relative path name, and, we sometimes need to close/reopen the log
+# after changing the current directory. See get_compiler_info.
+
+rename cd builtin_cd
+
+proc cd { dir } {
+
+ # Get the existing log file flags.
+ set log_file_info [log_file -info]
+
+ # Split the flags into args and file name.
+ set log_file_flags ""
+ set log_file_file ""
+ foreach arg [ split "$log_file_info" " "] {
+ if [string match "-*" $arg] {
+ lappend log_file_flags $arg
+ } else {
+ lappend log_file_file $arg
+ }
+ }
+
+ # If there was an existing file, ensure it is an absolute path, and then
+ # reset logging.
+ if { $log_file_file != "" } {
+ set log_file_file [file normalize $log_file_file]
+ log_file
+ log_file $log_file_flags "$log_file_file"
+ }
+
+ # Call the builtin version of cd.
+ builtin_cd $dir
+}
+
+# Return a list of all languages supported by GDB, suitable for use in
+# 'set language NAME'. This doesn't include either the 'local' or
+# 'auto' keywords.
+proc gdb_supported_languages {} {
+ return [list c objective-c c++ d go fortran modula-2 asm pascal \
+ opencl rust minimal ada]
+}
+
+# Check if debugging is enabled for gdb.
+
+proc gdb_debug_enabled { } {
+ global gdbdebug
+
+ # If not already read, get the debug setting from environment or board setting.
+ if {![info exists gdbdebug]} {
+ global env
+ if [info exists env(GDB_DEBUG)] {
+ set gdbdebug $env(GDB_DEBUG)
+ } elseif [target_info exists gdb,debug] {
+ set gdbdebug [target_info gdb,debug]
+ } else {
+ return 0
+ }
+ }
+
+ # Ensure it not empty.
+ return [expr { $gdbdebug != "" }]
+}
+
+# Turn on debugging if enabled, or reset if already on.
+
+proc gdb_debug_init { } {
+
+ global gdb_prompt
+
+ if ![gdb_debug_enabled] {
+ return;
+ }
+
+ # First ensure logging is off.
+ send_gdb "set logging off\n"
+
+ set debugfile [standard_output_file gdb.debug]
+ send_gdb "set logging file $debugfile\n"
+
+ send_gdb "set logging debugredirect\n"
+
+ global gdbdebug
+ foreach entry [split $gdbdebug ,] {
+ send_gdb "set debug $entry 1\n"
+ }
+
+ # Now that everything is set, enable logging.
+ send_gdb "set logging on\n"
+ gdb_expect 10 {
+ -re "Copying output to $debugfile.*Redirecting debug output to $debugfile.*$gdb_prompt $" {}
+ timeout { warning "Couldn't set logging file" }
+ }
+}
+
+# Check if debugging is enabled for gdbserver.
+
+proc gdbserver_debug_enabled { } {
+ # Always disabled for GDB only setups.
+ return 0
+}
+
+# Open the file for logging gdb input
+
+proc gdb_stdin_log_init { } {
+ gdb_persistent_global in_file
+
+ if {[info exists in_file]} {
+ # Close existing file.
+ catch "close $in_file"
+ }
+
+ set logfile [standard_output_file_with_gdb_instance gdb.in]
+ set in_file [open $logfile w]
+}
+
+# Write to the file for logging gdb input.
+# TYPE can be one of the following:
+# "standard" : Default. Standard message written to the log
+# "answer" : Answer to a question (eg "Y"). Not written the log.
+# "optional" : Optional message. Not written to the log.
+
+proc gdb_stdin_log_write { message {type standard} } {
+
+ global in_file
+ if {![info exists in_file]} {
+ return
+ }
+
+ # Check message types.
+ switch -regexp -- $type {
+ "answer" {
+ return
+ }
+ "optional" {
+ return
+ }
+ }
+
+ # 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.
+
+proc gdb_write_cmd_file { cmdline } {
+ set logfile [standard_output_file_with_gdb_instance gdb.cmd]
+ set cmd_file [open $logfile w]
+ puts $cmd_file $cmdline
+ catch "close $cmd_file"
+}
+
+# Compare contents of FILE to string STR. Pass with MSG if equal, otherwise
+# fail with MSG.
+
+proc cmp_file_string { file str msg } {
+ if { ![file exists $file]} {
+ fail "$msg"
+ return
+ }
+
+ set caught_error [catch {
+ set fp [open "$file" r]
+ set file_contents [read $fp]
+ close $fp
+ } error_message]
+ if { $caught_error } then {
+ error "$error_message"
+ fail "$msg"
+ return
+ }
+
+ if { $file_contents == $str } {
+ pass "$msg"
+ } else {
+ fail "$msg"
+ }
+}
+
+# Does the compiler support CTF debug output using '-gt' compiler
+# 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 {
+ 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