X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gdb%2Ftestsuite%2Flib%2Fgdb.exp;h=8be2a7240a94e0f2d5744933dc1ed8fd25d5cee5;hb=8e1d0c49c139082ac4992a51c87860a805043b5f;hp=9260e9a530af4f3e090063d7bfbfef5723aca366;hpb=dbc528229122320946ed69ba24fcd0d6a0127998;p=binutils-gdb.git diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp index 9260e9a530a..8be2a7240a9 100644 --- a/gdb/testsuite/lib/gdb.exp +++ b/gdb/testsuite/lib/gdb.exp @@ -1,5 +1,5 @@ # Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -# 2003, 2004, 2005, 2007, 2008 Free Software Foundation, Inc. +# 2003, 2004, 2005, 2007, 2008, 2009, 2010 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 @@ -42,12 +42,23 @@ if ![info exists GDB] { } verbose "using GDB = $GDB" 2 +# GDBFLAGS is available for the user to set on the command line. +# E.g. make check RUNTESTFLAGS=GDBFLAGS=mumble +# Testcases may use it to add additional flags, but they must: +# - append new flags, not overwrite +# - restore the original value when done global GDBFLAGS if ![info exists GDBFLAGS] { - set GDBFLAGS "-nx" + set GDBFLAGS "" } verbose "using GDBFLAGS = $GDBFLAGS" 2 +# INTERNAL_GDBFLAGS contains flags that the testsuite requires. +global INTERNAL_GDBFLAGS +if ![info exists INTERNAL_GDBFLAGS] { + set INTERNAL_GDBFLAGS "-nw -nx" +} + # The variable gdb_prompt is a regexp which matches the gdb prompt. # Set it if it is not already set. global gdb_prompt @@ -57,17 +68,17 @@ if ![info exists gdb_prompt] then { # The variable fullname_syntax_POSIX is a regexp which matches a POSIX # absolute path ie. /foo/ -set fullname_syntax_POSIX "/.*/" +set fullname_syntax_POSIX {/[^\n]*/} # The variable fullname_syntax_UNC is a regexp which matches a Windows # UNC path ie. \\D\foo\ -set fullname_syntax_UNC {\\\\[^\\]+\\.+\\} +set fullname_syntax_UNC {\\\\[^\\]+\\[^\n]+\\} # The variable fullname_syntax_DOS_CASE is a regexp which matches a # particular DOS case that GDB most likely will output # ie. \foo\, but don't match \\.*\ -set fullname_syntax_DOS_CASE {\\[^\\].*\\} +set fullname_syntax_DOS_CASE {\\[^\\][^\n]*\\} # The variable fullname_syntax_DOS is a regexp which matches a DOS path # ie. a:\foo\ && a:foo\ -set fullname_syntax_DOS {[a-zA-Z]:.*\\} +set fullname_syntax_DOS {[a-zA-Z]:[^\n]*\\} # The variable fullname_syntax is a regexp which matches what GDB considers # an absolute path. It is currently debatable if the Windows style paths # d:foo and \abc should be considered valid as an absolute path. @@ -94,22 +105,16 @@ set octal "\[0-7\]+" # proc default_gdb_version {} { global GDB - global GDBFLAGS + global INTERNAL_GDBFLAGS GDBFLAGS global gdb_prompt - set fileid [open "gdb_cmd" w]; - puts $fileid "q"; - close $fileid; - set cmdfile [remote_download host "gdb_cmd"]; - set output [remote_exec host "$GDB -nw --command $cmdfile"] - remote_file build delete "gdb_cmd"; - remote_file host delete "$cmdfile"; + set output [remote_exec host "$GDB $INTERNAL_GDBFLAGS --version"] set tmp [lindex $output 1]; set version "" regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version if ![is_remote host] { - clone_output "[which $GDB] version $version $GDBFLAGS\n" + clone_output "[which $GDB] version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" } else { - clone_output "$GDB on remote host version $version $GDBFLAGS\n" + clone_output "$GDB on remote host version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" } } @@ -310,13 +315,13 @@ proc gdb_start_cmd {args} { } send_gdb "start $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" exp_continue } - # Use -notransfer here so that test cases (like chng-sym.exp) - # may test for additional start-up messages. -notransfer -re "Starting program: \[^\r\n\]*" { return 0 } @@ -325,7 +330,8 @@ proc gdb_start_cmd {args} { } # Set a breakpoint at FUNCTION. If there is an additional argument it is -# a list of options; the supported options are allow-pending and temporary. +# a list of options; the supported options are allow-pending, temporary, +# and no-message. proc gdb_breakpoint { function args } { global gdb_prompt @@ -337,19 +343,28 @@ proc gdb_breakpoint { function args } { } set break_command "break" + set break_message "Breakpoint" if {[lsearch -exact [lindex $args 0] temporary] != -1} { set break_command "tbreak" + set break_message "Temporary breakpoint" + } + + set no_message 0 + if {[lsearch -exact [lindex $args 0] no-message] != -1} { + set no_message 1 } send_gdb "$break_command $function\n" # The first two regexps are what we get with -g, the third is without -g. gdb_expect 30 { - -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} - -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} - -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {} - -re "Breakpoint \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" { + -re "$break_message \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} + -re "$break_message \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} + -re "$break_message \[0-9\]* at .*$gdb_prompt $" {} + -re "$break_message \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" { if {$pending_response == "n"} { - fail "setting breakpoint at $function" + if { $no_message == 0 } { + fail "setting breakpoint at $function" + } return 0 } } @@ -357,8 +372,18 @@ proc gdb_breakpoint { function args } { send_gdb "$pending_response\n" exp_continue } - -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 } - timeout { fail "setting breakpoint at $function (timeout)" ; return 0 } + -re "$gdb_prompt $" { + if { $no_message == 0 } { + fail "setting breakpoint at $function" + } + return 0 + } + timeout { + if { $no_message == 0 } { + fail "setting breakpoint at $function (timeout)" + } + return 0 + } } return 1; } @@ -395,6 +420,10 @@ proc runto { function args } { fail "running to $function in runto" return 0 } + eof { + fail "running to $function in runto (end of file)" + return 0 + } timeout { fail "running to $function in runto (timeout)" return 0 @@ -430,13 +459,13 @@ proc runto_main { } { ### worked. Use NAME as part of the test name; each call to ### continue_to_breakpoint should use a NAME which is unique within ### that test file. -proc gdb_continue_to_breakpoint {name} { +proc gdb_continue_to_breakpoint {name {location_pattern .*}} { global gdb_prompt set full_name "continue to breakpoint: $name" send_gdb "continue\n" gdb_expect { - -re "Breakpoint .* at .*\r\n$gdb_prompt $" { + -re "Breakpoint .* (at|in) $location_pattern\r\n$gdb_prompt $" { pass $full_name } -re ".*$gdb_prompt $" { @@ -572,12 +601,23 @@ proc gdb_test_multiple { command message user_code } { set processed_code "" set patterns "" set expecting_action 0 + set expecting_arg 0 foreach item $user_code subst_item $subst_code { if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } { lappend processed_code $item continue } - if {$item == "-indices" || $item == "-re" || $item == "-ex"} { + if { $item == "-indices" || $item == "-re" || $item == "-ex" } { + lappend processed_code $item + continue + } + if { $item == "-timeout" } { + set expecting_arg 1 + lappend processed_code $item + continue + } + if { $expecting_arg } { + set expecting_arg 0 lappend processed_code $item continue } @@ -707,7 +747,7 @@ proc gdb_test_multiple { command message user_code } { fail "$errmsg" set result -1 } - -re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" { + -re "Program exited normally.*$gdb_prompt $" { if ![string match "" $message] then { set errmsg "$message (the program exited)" } else { @@ -737,10 +777,16 @@ proc gdb_test_multiple { command message user_code } { fail "$message" set result -1 } - -re "\\(y or n\\) " { + -re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " { send_gdb "n\n" - perror "Got interactive prompt." - fail "$message" + gdb_expect -re "$gdb_prompt $" + 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 $" + fail "$message (got breakpoint menu)" set result -1 } eof { @@ -990,7 +1036,7 @@ proc gdb_reinitialize_dir { subdir } { # proc default_gdb_exit {} { global GDB - global GDBFLAGS + global INTERNAL_GDBFLAGS GDBFLAGS global verbose global gdb_spawn_id; @@ -1000,7 +1046,7 @@ proc default_gdb_exit {} { return; } - verbose "Quitting $GDB $GDBFLAGS" + verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" if { [is_remote host] && [board_info host exists fileid] } { send_gdb "quit\n"; @@ -1130,14 +1176,30 @@ proc gdb_file_cmd { arg } { proc default_gdb_start { } { global verbose global GDB - global GDBFLAGS + global INTERNAL_GDBFLAGS GDBFLAGS global gdb_prompt global timeout global gdb_spawn_id; + global env gdb_stop_suppressing_tests; - verbose "Spawning $GDB -nw $GDBFLAGS" + set env(LC_CTYPE) 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. + set env(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. + set env(TERM) "vt100" + + verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" if [info exists gdb_spawn_id] { return 0; @@ -1149,7 +1211,7 @@ proc default_gdb_start { } { exit 1 } } - set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"]; + set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS [host_info gdb_opts]"]; if { $res < 0 || $res == "" } { perror "Spawning $GDB failed." return 1; @@ -1193,6 +1255,26 @@ proc default_gdb_start { } { 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 + +proc gdb_compile_test {src output} { + 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]" + } +} + # Return a 1 for configurations for which we don't even want to try to # test C++. @@ -1212,12 +1294,51 @@ proc skip_cplus_tests {} { return 0 } +# 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 a 1 if I don't even want to try to test FORTRAN. proc skip_fortran_tests {} { return 0 } +# Return a 1 if I don't even want to try to test ada. + +proc skip_ada_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 for configurations that do not support Python scripting. + +proc skip_python_tests {} { + global gdb_prompt + gdb_test_multiple "python print 'test'" "verify python support" { + -re "not supported.*$gdb_prompt $" { + unsupported "Python support is disabled." + return 1 + } + -re "$gdb_prompt $" {} + } + + return 0 +} + # Return a 1 if we should skip shared library tests. proc skip_shlib_tests {} { @@ -1329,6 +1450,92 @@ proc skip_altivec_tests {} { return $skip_vmx_tests_saved } +# 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. + +proc skip_vsx_tests {} { + global skip_vsx_tests_saved + global srcdir subdir gdb_prompt + + # Use the cached value, if it exists. + set me "skip_vsx_tests" + if [info exists skip_vsx_tests_saved] { + verbose "$me: returning saved $skip_vsx_tests_saved" 2 + return $skip_vsx_tests_saved + } + + # 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 [set skip_vsx_tests_saved 1] + } + + # Make sure we have a compiler that understands altivec. + set compile_flags {debug nowarnings quiet} + if [get_compiler_info not-used] { + warning "Could not get compiler info" + return 1 + } + if [test_compiler_info gcc*] { + set compile_flags "$compile_flags additional_flags=-mvsx" + } elseif [test_compiler_info xlc*] { + set compile_flags "$compile_flags additional_flags=-qvsx" + } else { + verbose "Could not compile with vsx support, returning 1" 2 + return 1 + } + + set src vsx[pid].c + set exe vsx[pid].x + + set f [open $src "w"] + puts $f "int main() {" + puts $f "#ifdef __MACH__" + puts $f " asm volatile (\"lxvd2x v0,v0,v0\");" + puts $f "#else" + puts $f " asm volatile (\"lxvd2x 0,0,0\");" + puts $f "#endif" + puts $f " return 0; }" + close $f + + 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 + return [set skip_vsx_tests_saved 1] + } + + # No error message, compilation succeeded so now run it via gdb. + + gdb_exit + gdb_start + gdb_reinitialize_dir $srcdir/$subdir + gdb_load "$exe" + gdb_run_cmd + gdb_expect { + -re ".*Illegal instruction.*${gdb_prompt} $" { + verbose -log "\n$me VSX hardware not detected" + set skip_vsx_tests_saved 1 + } + -re ".*Program exited normally.*${gdb_prompt} $" { + verbose -log "\n$me: VSX hardware detected" + set skip_vsx_tests_saved 0 + } + default { + warning "\n$me: default case taken" + set skip_vsx_tests_saved 1 + } + } + gdb_exit + remote_file build delete $exe + + verbose "$me: returning $skip_vsx_tests_saved" 2 + return $skip_vsx_tests_saved +} + # Skip all the tests in the file if you are not on an hppa running # hpux target. @@ -1338,6 +1545,37 @@ proc skip_hp_tests {} { return $skip_hp } +# Return whether we should skip tests for showing inlined functions in +# backtraces. Requires get_compiler_info and get_debug_format. + +proc skip_inline_frame_tests {} { + # GDB only recognizes inlining information in DWARF 2 (DWARF 3). + if { ! [test_debug_format "DWARF 2"] } { + return 1 + } + + # GCC before 4.1 does not emit DW_AT_call_file / DW_AT_call_line. + if { ([test_compiler_info "gcc-2-*"] + || [test_compiler_info "gcc-3-*"] + || [test_compiler_info "gcc-4-0-*"]) } { + return 1 + } + + return 0 +} + +# Return whether we should skip tests for showing variables from +# inlined functions. Requires get_compiler_info and get_debug_format. + +proc skip_inline_var_tests {} { + # GDB only recognizes inlining information in DWARF 2 (DWARF 3). + if { ! [test_debug_format "DWARF 2"] } { + return 1 + } + + return 0 +} + set compiler_info "unknown" set gcc_compiled 0 set hp_cc_compiler 0 @@ -1422,7 +1660,17 @@ proc get_compiler_info {binfile args} { # Run $ifile through the right preprocessor. # Toggle gdb.log to keep the compiler output out of the log. log_file - set cppout [ gdb_compile "${ifile}" "" preprocess [list "$args" quiet] ] + if [is_remote host] { + # 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 "$args" quiet] + set file [open $ppout r] + set cppout [read $file] + close $file + } else { + set cppout [ gdb_compile "${ifile}" "" preprocess [list "$args" quiet] ] + } log_file -a "$outdir/$tool.log" # Eval the output. @@ -1494,12 +1742,24 @@ proc test_compiler_info { {compiler ""} } { return [string match $compiler $compiler_info] } +proc current_target_name { } { + global target_info + if [info exists target_info(target,name)] { + set answer $target_info(target,name) + } else { + set answer "" + } + return $answer +} + set gdb_wrapper_initialized 0 +set gdb_wrapper_target "" proc gdb_wrapper_init { args } { global gdb_wrapper_initialized; global gdb_wrapper_file; global gdb_wrapper_flags; + global gdb_wrapper_target if { $gdb_wrapper_initialized == 1 } { return; } @@ -1514,13 +1774,21 @@ proc gdb_wrapper_init { args } { } } set gdb_wrapper_initialized 1 + set gdb_wrapper_target [current_target_name] } +# 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 "" + proc gdb_compile {source dest type options} { global GDB_TESTCASE_OPTIONS; global gdb_wrapper_file; global gdb_wrapper_flags; global gdb_wrapper_initialized; + global srcdir + global objdir + global gdb_saved_set_unbuffered_mode_obj set outdir [file dirname $dest] @@ -1528,6 +1796,7 @@ proc gdb_compile {source dest type options} { # "shlib=librarypath" in OPTIONS. set new_options "" set shlib_found 0 + set shlib_load 0 foreach opt $options { if [regexp {^shlib=(.*)} $opt dummy_var shlib_name] { if [test_compiler_info "xlc-*"] { @@ -1541,33 +1810,44 @@ proc gdb_compile {source dest type options} { } else { lappend source $shlib_name } - if {$shlib_found == 0} { + if { $shlib_found == 0 } { set shlib_found 1 - if { ([test_compiler_info "gcc-*"] - && ([istarget "powerpc*-*-aix*"] - || [istarget "rs6000*-*-aix*"] )) } { - lappend options "additional_flags=-L${outdir}" - } elseif { [istarget "mips-sgi-irix*"] } { - lappend options "additional_flags=-rpath ${outdir}" - } + if { ([istarget "*-*-mingw*"] + || [istarget *-*-cygwin*]) } { + lappend new_options "additional_flags=-Wl,--enable-auto-import" + } } } elseif { $opt == "shlib_load" } { - if { ([istarget "*-*-mingw*"] - || [istarget *-*-cygwin*] - || [istarget *-*-pe*] - || [istarget arm*-*-symbianelf*] - || [istarget hppa*-*-hpux*])} { - # Do not need anything. - } elseif { [istarget *-*-openbsd*] } { - lappend new_options "additional_flags=-Wl,-rpath,${outdir}" - } else { - lappend new_options "libs=-ldl" - lappend new_options "additional_flags=-Wl,-rpath,\\\$ORIGIN" - } + set shlib_load 1 } else { lappend new_options $opt } } + + # We typically link to shared libraries using an absolute path, and + # that's how they are found at runtime. If we are going to + # dynamically load one by basename, we must specify rpath. If we + # are using a remote host, DejaGNU will link to the shared library + # using a relative path, so again we must specify an rpath. + if { $shlib_load || ($shlib_found && [is_remote host]) } { + if { ([istarget "*-*-mingw*"] + || [istarget *-*-cygwin*] + || [istarget *-*-pe*] + || [istarget hppa*-*-hpux*])} { + # Do not need anything. + } elseif { [istarget *-*-openbsd*] } { + lappend new_options "additional_flags=-Wl,-rpath,${outdir}" + } elseif { [istarget arm*-*-symbianelf*] } { + if { $shlib_load } { + lappend new_options "libs=-ldl" + } + } else { + if { $shlib_load } { + lappend new_options "libs=-ldl" + } + lappend new_options "additional_flags=-Wl,-rpath,\\\$ORIGIN" + } + } set options $new_options if [target_info exists gdb_stub] { @@ -1607,6 +1887,49 @@ proc gdb_compile {source dest type options} { set options [lreplace $options $nowarnings $nowarnings $flag] } + if { $type == "executable" } { + if { ([istarget "*-*-mingw*"] + || [istarget "*-*-*djgpp"] + || [istarget "*-*-cygwin*"])} { + # 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: + # 1) Insulate it from $options. + # 2) Avoid compiling it for every gdb_compile invocation, + # which is time consuming, especially if we're remote + # host testing. + # + if { $gdb_saved_set_unbuffered_mode_obj == "" } { + verbose "compiling gdb_saved_set_unbuffered_obj" + set unbuf_src ${srcdir}/lib/set_unbuffered_mode.c + set unbuf_obj ${objdir}/set_unbuffered_mode.o + + set result [gdb_compile "${unbuf_src}" "${unbuf_obj}" object {nowarnings}] + if { $result != "" } { + return $result + } + + set gdb_saved_set_unbuffered_mode_obj ${objdir}/set_unbuffered_mode_saved.o + # Link a copy of the output object, because the + # original may be automatically deleted. + remote_exec host "cp -f $unbuf_obj $gdb_saved_set_unbuffered_mode_obj" + } else { + verbose "gdb_saved_set_unbuffered_obj already compiled" + } + + # Rely on the internal knowledge that the global ctors are ran in + # reverse link order. In that case, we can use ldflags to + # avoid copying the object file to the host multiple + # times. + # This object can only be added if standard libraries are + # used. Thus, we need to disable it if -nostdlib option is used + if {[lsearch -regexp $options "-nostdlib"] < 0 } { + lappend options "ldflags=$gdb_saved_set_unbuffered_mode_obj" + } + } + } + set result [target_compile $source $dest $type $options]; # Prune uninteresting compiler (and linker) output. @@ -1614,9 +1937,15 @@ proc gdb_compile {source dest type options} { regsub "\[\r\n\]*$" "$result" "" result; regsub "^\[\r\n\]*" "$result" "" result; - - if { $result != "" && [lsearch $options quiet] == -1} { - clone_output "gdb compile failed, $result" + + 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} { + gdb_compile_test $source $result + } elseif { $result != "" } { + clone_output "gdb compile failed, $result" + } } return $result; } @@ -1628,7 +1957,7 @@ proc gdb_compile {source dest type options} { proc gdb_compile_pthreads {source dest type options} { set built_binfile 0 set why_msg "unrecognized error" - foreach lib {-lpthreads -lpthread -lthread} { + foreach lib {-lpthreads -lpthread -lthread ""} { # This kind of wipes out whatever libs the caller may have # set. Or maybe theirs will override ours. How infelicitous. set options_with_lib [concat $options [list libs=$lib quiet]] @@ -1805,7 +2134,7 @@ proc gdb_expect { args } { if [info exists atimeout] { if { ![info exists gtimeout] || $gtimeout < $atimeout } { - set $gtimeout $atimeout; + set gtimeout $atimeout; } } else { if ![info exists gtimeout] { @@ -2032,6 +2361,22 @@ proc gdb_load_cmd { args } { return -1 } +# Return the filename to download to the target and load on the target +# for this shared library. Normally just LIBNAME, unless shared libraries +# for this target have separate link and load images. + +proc shlib_target_file { libname } { + return $libname +} + +# Return the filename GDB will load symbols from when debugging this +# shared library. Normally just LIBNAME, unless shared libraries for +# this target have separate link and load images. + +proc shlib_symbol_file { libname } { + return $libname +} + # gdb_download # # Copy a file to the remote target and return its target filename. @@ -2055,7 +2400,7 @@ proc gdb_load_shlibs { args } { } foreach file $args { - gdb_download $file + gdb_download [shlib_target_file $file] } # Even if the target supplies full paths for shared libraries, @@ -2091,6 +2436,7 @@ proc gdb_continue { function } { proc default_gdb_init { args } { global gdb_wrapper_initialized + global gdb_wrapper_target global cleanfiles set cleanfiles {} @@ -2099,12 +2445,16 @@ proc default_gdb_init { args } { # Make sure that the wrapper is rebuilt # with the appropriate multilib option. - set gdb_wrapper_initialized 0 + if { $gdb_wrapper_target != [current_target_name] } { + set gdb_wrapper_initialized 0 + } # Unlike most tests, we have a small number of tests that generate # a very large amount of output. We therefore increase the expect # buffer size to be able to contain the entire test output. match_max -d 30000 + # Also set this value for the currently running GDB. + match_max [match_max -d] # We want to add the name of the TCL testcase to the PASS/FAIL messages. if { [llength $args] > 0 } { @@ -2122,7 +2472,22 @@ proc default_gdb_init { args } { } } +# The default timeout used when testing GDB commands. We want to use +# the same timeout as the default dejagnu timeout, unless the user has +# already provided a specific value (probably through a site.exp file). +global gdb_test_timeout +if ![info exists gdb_test_timeout] { + set gdb_test_timeout $timeout +} + proc gdb_init { args } { + # 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 + return [eval default_gdb_init $args]; } @@ -2442,6 +2807,7 @@ proc gdb_skip_bogus_test { msg } { # Return true if a test should be skipped due to lack of XML support # in the host GDB. +# NOTE: This must be called while gdb is *not* running. proc gdb_skip_xml_test { } { global gdb_prompt @@ -2467,8 +2833,8 @@ proc gdb_skip_xml_test { } { # Note: the procedure gdb_gnu_strip_debug will produce an executable called # ${binfile}.dbglnk, which is just like the executable ($binfile) but without # the debuginfo. Instead $binfile has a .gnu_debuglink section which contains -# the name of a debuginfo only file. This file will be stored in the -# gdb.base/.debug subdirectory. +# the name of a debuginfo only file. This file will be stored in the same +# subdirectory. # Functions for separate debug info testing @@ -2477,27 +2843,9 @@ proc gdb_skip_xml_test { } { # at the end of the process we have: # foo.stripped --> foo w/o debug info -# .debug/foo.debug --> foo's debug info +# foo.debug --> foo's debug info # foo --> like foo, but with a new .gnu_debuglink section pointing to foo.debug. -# Return the name of the file in which we should stor EXEC's separated -# debug info. EXEC contains the full path. -proc separate_debug_filename { exec } { - - # In a .debug subdirectory off the same directory where the testcase - # executable is going to be. Something like: - # /gdb/testsuite/gdb.base/.debug/blah.debug. - # This is the default location where gdb expects to findi - # the debug info file. - - set exec_dir [file dirname $exec] - set exec_file [file tail $exec] - set debug_dir [file join $exec_dir ".debug"] - set debug_file [file join $debug_dir "${exec_file}.debug"] - - return $debug_file -} - # Return the build-id hex string (usually 160 bits as 40 hex characters) # converted to the form: .build-id/ab/cdef1234...89.debug # Return "" if no build-id found. @@ -2523,27 +2871,26 @@ proc build_id_debug_filename_get { exec } { } # Convert it to hex. binary scan $data H* data - set data [regsub {^..} $data {\0/}] + regsub {^..} $data {\0/} data return ".build-id/${data}.debug"; } # Create stripped files for DEST, replacing it. If ARGS is passed, it is a # list of optional flags. The only currently supported flag is no-main, # which removes the symbol entry for main from the separate debug file. +# +# Function returns zero on success. Function will return non-zero failure code +# on some targets not supporting separate debug info (such as i386-msdos). proc gdb_gnu_strip_debug { dest args } { - set debug_file [separate_debug_filename $dest] + # Use the first separate debug info file location searched by GDB so the + # run cannot be broken by some stale file searched with higher precedence. + set debug_file "${dest}.debug" + set strip_to_file_program [transform strip] set objcopy_program [transform objcopy] - # Make sure the directory that will hold the separated debug - # info actually exists. - set debug_dir [file dirname $debug_file] - if {! [file isdirectory $debug_dir]} { - file mkdir $debug_dir - } - set debug_link [file tail $debug_file] set stripped_file "${dest}.stripped" @@ -2556,6 +2903,11 @@ proc gdb_gnu_strip_debug { dest args } { return 1 } + # Workaround PR binutils/10802: + # Preserve the 'x' bit also for PIEs (Position Independent Executables). + set perm [file attributes ${dest} -permissions] + file attributes ${stripped_file} -permissions $perm + # Get rid of everything but the debug info, and store result in debug_file # This will be in the .debug subdirectory, see above. set result [catch "exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}" output] @@ -2592,7 +2944,12 @@ proc gdb_gnu_strip_debug { dest args } { return 1 } - return 0 + # Workaround PR binutils/10802: + # Preserve the 'x' bit also for PIEs (Position Independent Executables). + set perm [file attributes ${stripped_file} -permissions] + file attributes ${dest} -permissions $perm + + return 0 } # Test the output of GDB_COMMAND matches the pattern obtained @@ -2712,10 +3069,179 @@ proc clean_restart { executable } { # Please refer to build_executable for parameter description. proc prepare_for_testing { testname executable {sources ""} {options {debug}}} { - if {[build_executable $testname $executable $sources] == -1} { + if {[build_executable $testname $executable $sources $options] == -1} { return -1 } clean_restart $executable return 0 } + +proc get_valueof { fmt exp default } { + global gdb_prompt + + set test "get valueof \"${exp}\"" + set val ${default} + gdb_test_multiple "print${fmt} ${exp}" "$test" { + -re "\\$\[0-9\]* = (.*)\[\r\n\]*$gdb_prompt $" { + set val $expect_out(1,string) + pass "$test ($val)" + } + timeout { + fail "$test (timeout)" + } + } + return ${val} +} + +proc get_integer_valueof { exp default } { + global gdb_prompt + + 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)" + } + timeout { + fail "$test (timeout)" + } + } + return ${val} +} + +proc get_hexadecimal_valueof { exp default } { + global gdb_prompt + send_gdb "print /x ${exp}\n" + set test "get hexadecimal valueof \"${exp}\"" + gdb_expect { + -re "\\$\[0-9\]* = (0x\[0-9a-zA-Z\]+).*$gdb_prompt $" { + set val $expect_out(1,string) + pass "$test" + } + timeout { + set val ${default} + fail "$test (timeout)" + } + } + return ${val} +} + +proc get_sizeof { type default } { + return [get_integer_valueof "sizeof (${type})" $default] +} + +# 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] + } +} + +proc core_find {binfile {deletefiles {}} {arg ""}} { + global objdir subdir + + set destcore "$binfile.core" + file delete $destcore + + # Create a core file named "$destcore" rather than just "core", to + # avoid problems with sys admin types that like to regularly prune all + # files named "core" from the system. + # + # Arbitrarily try setting the core size limit to "unlimited" since + # this does not hurt on systems where the command does not work and + # allows us to generate a core on systems where it does. + # + # Some systems append "core" to the name of the program; others append + # the name of the program to "core"; still others (like Linux, as of + # May 2003) create cores named "core.PID". In the latter case, we + # could have many core files lying around, and it may be difficult to + # tell which one is ours, so let's run the program in a subdirectory. + set found 0 + set coredir "${objdir}/${subdir}/coredir.[getpid]" + file mkdir $coredir + catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >/dev/null 2>&1\"" + # remote_exec host "${binfile}" + foreach i "${coredir}/core ${coredir}/core.coremaker.c ${binfile}.core" { + if [remote_file build exists $i] { + remote_exec build "mv $i $destcore" + set found 1 + } + } + # Check for "core.PID". + if { $found == 0 } { + set names [glob -nocomplain -directory $coredir core.*] + if {[llength $names] == 1} { + set corefile [file join $coredir [lindex $names 0]] + remote_exec build "mv $corefile $destcore" + set found 1 + } + } + if { $found == 0 } { + # The braindamaged HPUX shell quits after the ulimit -c above + # without executing ${binfile}. So we try again without the + # ulimit here if we didn't find a core file above. + # Oh, I should mention that any "braindamaged" non-Unix system has + # the same problem. I like the cd bit too, it's really neat'n stuff. + catch "system \"(cd ${objdir}/${subdir}; ${binfile}; true) >/dev/null 2>&1\"" + foreach i "${objdir}/${subdir}/core ${objdir}/${subdir}/core.coremaker.c ${binfile}.core" { + if [remote_file build exists $i] { + remote_exec build "mv $i $destcore" + set found 1 + } + } + } + + # Try to clean up after ourselves. + foreach deletefile $deletefiles { + remote_file build delete [file join $coredir $deletefile] + } + remote_exec build "rmdir $coredir" + + if { $found == 0 } { + warning "can't generate a core file - core tests suppressed - check ulimit -c" + return "" + } + return $destcore +}