-# Copyright 1992-2019 Free Software Foundation, Inc.
+# Copyright 1992-2020 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
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.
#
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 $" {
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 } {
# 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\]*" {}
# 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\]*" {
send_gdb "starti $args\n"
gdb_expect 60 {
-re "The program .* has been started already.*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
exp_continue
}
-re "Starting program: \[^\r\n\]*" {
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 [ -promp 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 "; "
}
}
}
- set code {
+ 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
}
append code {
- -re "Ending remote debugging.*$gdb_prompt $" {
+ -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
}
}
}
+ 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
}
}
+ # 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
set command [lindex $args 0]
set pattern [lindex $args 1]
- if [llength $args]==5 {
- set question_string [lindex $args 3]
- set response_string [lindex $args 4]
- } else {
- set question_string "^FOOBAR$"
- }
-
- return [gdb_test_multiple $command $message {
+ set user_code {}
+ lappend user_code {
-re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" {
if ![string match "" $message] then {
pass "$message"
}
}
- -re "(${question_string})$" {
- send_gdb "$response_string\n"
- exp_continue
+ }
+
+ 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 {
+ return 0
+ }
+}
+
+# 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\""
+ }
+ 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
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
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
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" { }
proc gdb_file_cmd { arg } {
global gdb_prompt
- global verbose
global GDB
global last_loaded_file
}
# 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
}
return 0
}
-re "Load new symbol table from \".*\".*y or n. $" {
- send_gdb "y\n"
+ send_gdb "y\n" answer
gdb_expect 120 {
-re "Reading symbols from.*$gdb_prompt $" {
verbose "\t\tLoaded $arg with new symbol table into $GDB"
set 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
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
warning "Couldn't set the width to 0."
}
}
+
+ gdb_debug_init
return 0
}
proc skip_python_tests_prompt { prompt_regexp } {
global gdb_py_is_py3k
- 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" {}
- }
- 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
- }
- }
+ 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_py3k 0
+ }
+ }
return 0
}
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
}
}
}
}
}
+# 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 {
} executable]
}
+# Return 1 if compiling go is supported.
+gdb_caching_proc support_go_compile {
+
+ 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 0.
# Compile a test program.
set src { int main() { return 0; } }
if {![gdb_simple_compile $me $src executable]} {
- return 0
+ return 1
}
# No error message, compilation succeeded so now run it via gdb.
# Compile a test program.
set src { int main() { return 0; } }
if {![gdb_simple_compile $me $src executable]} {
- return 0
+ return 1
}
# No error message, compilation succeeded so now run it via gdb.
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.
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 {
- -re "${target_stack_regexp}${prompt_regexp}" {
- pass $test
- return 1
- }
- -re "$prompt_regexp" {
- pass $test
+ 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
}
global gdb_wrapper_flags
global gdb_wrapper_target
+ # If the wrapper is initialized but the wrapper file cannot be
+ # found anymore, the wrapper file must be built again.
+ if { $gdb_wrapper_initialized == 1 && \
+ [info exists gdb_wrapper_file] && \
+ ![file exists $gdb_wrapper_file] } {
+ verbose "reinitializing the wrapper"
+ set gdb_wrapper_initialized 0
+ }
+
if { $gdb_wrapper_initialized == 1 } { return; }
if {[target_info exists needs_status_wrapper] && \
[target_info needs_status_wrapper] != "0"} {
- set result [build_wrapper "testglue.o"]
+ set result [build_wrapper [standard_output_file "testglue.o"]]
if { $result != "" } {
set gdb_wrapper_file [lindex $result 0]
set gdb_wrapper_flags [lindex $result 1]
set postfix "s"
}
}
- set src [standard_temp_file $name-[pid].c]
+ 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}]
} else {
set new_options [universal_compile_options]
}
+
+ # Place (and look for) Fortran `.mod` files in the output
+ # directory for this specific test.
+ if {[lsearch -exact $options f77] != -1 \
+ || [lsearch -exact $options f90] != -1 } {
+ # Fortran compile.
+ set mod_path [standard_output_file ""]
+ lappend new_options "additional_flags=-J${mod_path}"
+ }
+
set shlib_found 0
set shlib_load 0
set getting_compiler_info 0
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" && \
# 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 { $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.
# 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 ""} {
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
+ set sourcebase [file tail $source]
+ if {[file extension $source] == ".o"} {
+ # Already a .o file.
+ lappend objects $source
+ } elseif {[gdb_compile $source "${outdir}/${sourcebase}.o" object \
+ $obj_options] != ""} {
+ return -1
+ } else {
+ lappend objects ${outdir}/${sourcebase}.o
+ }
}
set link_options $options
}
}
-proc send_gdb { string } {
+# 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}} {
global suppress_flag
if { $suppress_flag } {
return "suppressed"
}
+ gdb_stdin_log_write $string $type
return [remote_send host "$string"]
}
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 [regsub {^/([a-z])/} $dir {\1:/}]
+ }
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 [expr $gdb_instances - 1 ]
+
+ 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 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.
# tests.
setenv TERM "dumb"
+ # Ensure that GDBHISTFILE and GDBHISTSIZE are removed from the
+ # environment, we don't want these modifications to the history
+ # settings.
+ unset -nocomplain ::env(GDBHISTFILE)
+ unset -nocomplain ::env(GDBHISTSIZE)
+
# Initialize GDB's pty with a fixed size, to make sure we avoid pagination
# during startup. See "man expect" for details about stty_init.
global stty_init
set gdbserver_reconnect_p 1
unset gdbserver_reconnect_p
+ # Clear $last_loaded_file
+ global last_loaded_file
+ unset -nocomplain last_loaded_file
+
+ # Reset GDB number of instances
+ global gdb_instances
+ set gdb_instances 0
+
return [default_gdb_init $test_file_name]
}
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]
+ set res [catch {exec $readelf_program -d $executable} output]
+ if { $res != 0 } {
+ return -1
+ }
+ set res [regexp -line {\(FLAGS_1\).*Flags:.* PIE($| )} $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.
# 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}"
+}
+
+# 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
+# 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]
- eval [list help_test_raw "help ${command_class}" $l_entire_body] $args
+ help_test_raw "help ${command_class}" $l_entire_body $testname
}
+# 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
}
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]} {
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
# prepended. (See gdb_target_symbol_prefix, above.)
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 { } {
return 0
}
+# Open the file for logging gdb input
+
+proc gdb_stdin_log_init { } {
+ 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
+ puts -nonewline $in_file "$message"
+}
+
+# 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.
+
+gdb_caching_proc skip_ctf_tests {
+ return ![gdb_can_simple_compile ctfdebug {
+ int main () {
+ return 0;
+ }
+ } executable "additional_flags=-gt"]
+}
+
# Always load compatibility stuff.
load_lib future.exp
projects / binutils-gdb.git / blobdiff