# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 # Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # Please email any bugs, comments, and/or additions to this file to: # bug-gdb@prep.ai.mit.edu # This file was written by Fred Fish. (fnf@cygnus.com) # Generic gdb subroutines that should work for any target. If these # need to be modified for any target, it can be done with a variable # or by passing arguments. load_lib libgloss.exp global GDB global CHILL_LIB global CHILL_RT0 if ![info exists CHILL_LIB] { set CHILL_LIB [findfile $base_dir/../../gcc/ch/runtime/libchill.a "$base_dir/../../gcc/ch/runtime/libchill.a" [transform -lchill]] } verbose "using CHILL_LIB = $CHILL_LIB" 2 if ![info exists CHILL_RT0] { set CHILL_RT0 [findfile $base_dir/../../gcc/ch/runtime/chillrt0.o "$base_dir/../../gcc/ch/runtime/chillrt0.o" ""] } verbose "using CHILL_RT0 = $CHILL_RT0" 2 if [info exists TOOL_EXECUTABLE] { set GDB $TOOL_EXECUTABLE; } if ![info exists GDB] { if ![is_remote host] { set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]] } else { set GDB [transform gdb]; } } verbose "using GDB = $GDB" 2 global GDBFLAGS if ![info exists GDBFLAGS] { set GDBFLAGS "-nx" } verbose "using GDBFLAGS = $GDBFLAGS" 2 # The variable gdb_prompt is a regexp which matches the gdb prompt. # Set it if it is not already set. global gdb_prompt if ![info exists gdb_prompt] then { set gdb_prompt "\[(\]gdb\[)\]" } # Needed for some tests under Cygwin. global EXEEXT global env if ![info exists env(EXEEXT)] { set EXEEXT "" } else { set EXEEXT $env(EXEEXT) } ### Only procedures should come after this point. # # gdb_version -- extract and print the version number of GDB # proc default_gdb_version {} { global GDB global 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 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" } else { clone_output "$GDB on remote host version $version $GDBFLAGS\n" } } proc gdb_version { } { return [default_gdb_version]; } # # gdb_unload -- unload a file if one is loaded # proc gdb_unload {} { global verbose global GDB global gdb_prompt send_gdb "file\n" gdb_expect 60 { -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..*Kill it.*y or n. $"\ { send_gdb "y\n" verbose "\t\tKilling previous program being debugged" exp_continue } -re "Discard symbol table from .*y or n.*$" { send_gdb "y\n" exp_continue } -re "$gdb_prompt $" {} timeout { perror "couldn't unload file in $GDB (timed out)." return -1 } } } # Many of the tests depend on setting breakpoints at various places and # running until that breakpoint is reached. At times, we want to start # with a clean-slate with respect to breakpoints, so this utility proc # lets us do this without duplicating this code everywhere. # proc delete_breakpoints {} { global gdb_prompt # we need a larger timeout value here or this thing just confuses # itself. May need a better implementation if possible. - guo # send_gdb "delete breakpoints\n" gdb_expect 100 { -re "Delete all breakpoints.*y or n.*$" { send_gdb "y\n"; exp_continue } -re "$gdb_prompt $" { # This happens if there were no breakpoints } timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return } } send_gdb "info breakpoints\n" gdb_expect 100 { -re "No breakpoints or watchpoints..*$gdb_prompt $" {} -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return } -re "Delete all breakpoints.*or n.*$" { send_gdb "y\n"; exp_continue } timeout { perror "info breakpoints (timeout)" ; return } } } # # Generic run command. # # The second pattern below matches up to the first newline *only*. # Using ``.*$'' could swallow up output that we attempt to match # elsewhere. # proc gdb_run_cmd {args} { global gdb_prompt if [target_info exists gdb_init_command] { send_gdb "[target_info gdb_init_command]\n"; gdb_expect 30 { -re "$gdb_prompt $" { } default { perror "gdb_init_command for target failed"; return; } } } if [target_info exists use_gdb_stub] { if [target_info exists gdb,do_reload_on_run] { # Specifying no file, defaults to the executable # currently being debugged. if { [gdb_load ""] < 0 } { return; } send_gdb "continue\n"; gdb_expect 60 { -re "Continu\[^\r\n\]*\[\r\n\]" {} default {} } return; } if [target_info exists gdb,start_symbol] { set start [target_info gdb,start_symbol]; } else { set start "start"; } send_gdb "jump *$start\n" set start_attempt 1; while { $start_attempt } { # Cap (re)start attempts at three to ensure that this loop # always eventually fails. Don't worry about trying to be # clever and not send a command when it has failed. if [expr $start_attempt > 3] { perror "Jump to start() failed (retry count exceeded)"; return; } set start_attempt [expr $start_attempt + 1]; gdb_expect 30 { -re "Continuing at \[^\r\n\]*\[\r\n\]" { set start_attempt 0; } -re "No symbol \"_start\" in current.*$gdb_prompt $" { perror "Can't find start symbol to run in gdb_run"; return; } -re "No symbol \"start\" in current.*$gdb_prompt $" { send_gdb "jump *_start\n"; } -re "No symbol.*context.*$gdb_prompt $" { set start_attempt 0; } -re "Line.* Jump anyway.*y or n. $" { send_gdb "y\n" } -re "The program is not being run.*$gdb_prompt $" { if { [gdb_load ""] < 0 } { return; } send_gdb "jump *$start\n"; } timeout { perror "Jump to start() failed (timeout)"; return } } } if [target_info exists gdb_stub] { gdb_expect 60 { -re "$gdb_prompt $" { send_gdb "continue\n" } } } return } send_gdb "run $args\n" # This doesn't work quite right yet. gdb_expect 60 { -re "The program .* has been started already.*y or n. $" { send_gdb "y\n" exp_continue } -re "Starting program: \[^\r\n\]*" {} } } proc gdb_breakpoint { function } { global gdb_prompt global decimal send_gdb "break $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 "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 } timeout { fail "setting breakpoint at $function (timeout)" ; return 0 } } return 1; } # Set breakpoint at function and run gdb until it breaks there. # Since this is the only breakpoint that will be set, if it stops # at a breakpoint, we will assume it is the one we want. We can't # just compare to "function" because it might be a fully qualified, # single quoted C++ function specifier. proc runto { function } { global gdb_prompt global decimal delete_breakpoints if ![gdb_breakpoint $function] { return 0; } gdb_run_cmd # the "at foo.c:36" output we get with -g. # the "in func" output we get without -g. gdb_expect 30 { -re "Break.* at .*:$decimal.*$gdb_prompt $" { return 1 } -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { return 1 } -re "$gdb_prompt $" { fail "running to $function in runto" return 0 } timeout { fail "running to $function in runto (timeout)" return 0 } } return 1 } # # runto_main -- ask gdb to run until we hit a breakpoint at main. # The case where the target uses stubs has to be handled # specially--if it uses stubs, assuming we hit # breakpoint() and just step out of the function. # proc runto_main { } { global gdb_prompt global decimal if ![target_info exists gdb_stub] { return [runto main] } delete_breakpoints gdb_step_for_stub; return 1 } ### Continue, and expect to hit a breakpoint. ### Report a pass or fail, depending on whether it seems to have ### 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} { global gdb_prompt set full_name "continue to breakpoint: $name" send_gdb "continue\n" gdb_expect { -re "Breakpoint .* at .*\r\n$gdb_prompt $" { pass $full_name } -re ".*$gdb_prompt $" { fail $full_name } timeout { fail "$full_name (timeout)" } } } # gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE # 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. # PATTERN is the pattern to match for a PASS, and must NOT include # the \r\n sequence immediately before the gdb prompt. # MESSAGE is an optional message to be printed. If this is # omitted, then the pass/fail messages use the command string as the # message. (If this is the empty string, then sometimes we don't # call pass or fail at all; I don't understand this at all.) # QUESTION is a question GDB may ask in response to COMMAND, like # "are you sure?" # RESPONSE is the response to send if QUESTION appears. # # Returns: # 1 if the test failed, # 0 if the test passes, # -1 if there was an internal error. # proc gdb_test { args } { global verbose global gdb_prompt global GDB upvar timeout timeout if [llength $args]>2 then { set message [lindex $args 2] } else { set message [lindex $args 0] } 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$" } if $verbose>2 then { send_user "Sending \"$command\" to gdb\n" send_user "Looking to match \"$pattern\"\n" send_user "Message is \"$message\"\n" } set result -1 set string "${command}\n"; if { $command != "" } { while { "$string" != "" } { set foo [string first "\n" "$string"]; set len [string length "$string"]; 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; } # since we're checking if each line of the multi-line # command are 'accepted' by GDB here, # we need to set -notransfer expect option so that # command output is not lost for pattern matching # - guo gdb_expect -notransfer 2 { -re "\[\r\n\]" { } timeout { } } set string [string range "$string" [expr $foo + 1] end]; } else { break; } } if { "$string" != "" } { if { [send_gdb "$string"] != "" } { global suppress_flag; if { ! $suppress_flag } { perror "Couldn't send $command to GDB."; } fail "$message"; return $result; } } } if [target_info exists gdb,timeout] { set tmt [target_info gdb,timeout]; } else { if [info exists timeout] { set tmt $timeout; } else { global timeout; if [info exists timeout] { set tmt $timeout; } else { set tmt 60; } } } gdb_expect $tmt { -re "\\*\\*\\* DOSEXIT code.*" { if { $message != "" } { fail "$message"; } gdb_suppress_entire_file "GDB died"; return -1; } -re "Ending remote debugging.*$gdb_prompt $" { if ![isnative] then { warning "Can`t communicate to remote target." } gdb_exit gdb_start set result -1 } -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" { if ![string match "" $message] then { pass "$message" } set result 0 } -re "(${question_string})$" { send_gdb "$response_string\n"; exp_continue; } -re "Undefined\[a-z\]* command:.*$gdb_prompt $" { perror "Undefined command \"$command\"." fail "$message" set result 1 } -re "Ambiguous command.*$gdb_prompt $" { perror "\"$command\" is not a unique command name." fail "$message" set result 1 } -re "Program exited with code \[0-9\]+.*$gdb_prompt $" { if ![string match "" $message] then { set errmsg "$message: the program exited" } else { set errmsg "$command: the program exited" } fail "$errmsg" return -1 } -re "The program is not being run.*$gdb_prompt $" { if ![string match "" $message] then { set errmsg "$message: the program is no longer running" } else { set errmsg "$command: the program is no longer running" } fail "$errmsg" return -1 } -re ".*$gdb_prompt $" { if ![string match "" $message] then { fail "$message" } set result 1 } "" { send_gdb "\n" perror "Window too small." fail "$message" } -re "\\(y or n\\) " { send_gdb "n\n" perror "Got interactive prompt." fail "$message" } eof { perror "Process no longer exists" if { $message != "" } { fail "$message" } return -1 } full_buffer { perror "internal buffer is full." fail "$message" } timeout { if ![string match "" $message] then { fail "$message (timeout)" } set result 1 } } return $result } # 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 # a 0 to be returned to indicate that more tests are likely to fail # as well. proc test_print_reject { args } { global gdb_prompt global verbose if [llength $args]==2 then { set expectthis [lindex $args 1] } else { set expectthis "should never match this bogus string" } set sendthis [lindex $args 0] if $verbose>2 then { send_user "Sending \"$sendthis\" to gdb\n" send_user "Looking to match \"$expectthis\"\n" } send_gdb "$sendthis\n" #FIXME: Should add timeout as parameter. gdb_expect { -re "A .* in expression.*\\.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "Invalid syntax in expression.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "Junk after end of expression.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "Invalid number.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "Invalid character constant.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "No symbol table is loaded.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "No symbol .* in current context.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re "$expectthis.*$gdb_prompt $" { pass "reject $sendthis" return 1 } -re ".*$gdb_prompt $" { fail "reject $sendthis" return 1 } default { fail "reject $sendthis (eof or timeout)" return 0 } } } # Given an input string, adds backslashes as needed to create a # regexp that will match the string. proc string_to_regexp {str} { set result $str regsub -all {[]*+.|()^$\[]} $str {\\&} result return $result } # Same as gdb_test, but the second parameter is not a regexp, # but a string that must match exactly. proc gdb_test_exact { args } { upvar timeout timeout set command [lindex $args 0] # This applies a special meaning to a null string pattern. Without # this, "$pattern\r\n$gdb_prompt $" will match anything, including error # messages from commands that should have no output except a new # prompt. With this, only results of a null string will match a null # string pattern. set pattern [lindex $args 1] if [string match $pattern ""] { set pattern [string_to_regexp [lindex $args 0]] } else { set pattern [string_to_regexp [lindex $args 1]] } # It is most natural to write the pattern argument with only # embedded \n's, especially if you are trying to avoid Tcl quoting # problems. But gdb_expect really wants to see \r\n in patterns. So # transform the pattern here. First transform \r\n back to \n, in # case some users of gdb_test_exact already do the right thing. regsub -all "\r\n" $pattern "\n" pattern 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] } proc gdb_reinitialize_dir { subdir } { global gdb_prompt if [is_remote host] { return ""; } send_gdb "dir\n" gdb_expect 60 { -re "Reinitialize source path to empty.*y or n. " { send_gdb "y\n" gdb_expect 60 { -re "Source directories searched.*$gdb_prompt $" { send_gdb "dir $subdir\n" gdb_expect 60 { -re "Source directories searched.*$gdb_prompt $" { verbose "Dir set to $subdir" } -re "$gdb_prompt $" { perror "Dir \"$subdir\" failed." } } } -re "$gdb_prompt $" { perror "Dir \"$subdir\" failed." } } } -re "$gdb_prompt $" { perror "Dir \"$subdir\" failed." } } } # # gdb_exit -- exit the GDB, killing the target program if necessary # proc default_gdb_exit {} { global GDB global GDBFLAGS global verbose global gdb_spawn_id; gdb_stop_suppressing_tests; if ![info exists gdb_spawn_id] { return; } verbose "Quitting $GDB $GDBFLAGS" if { [is_remote host] && [board_info host exists fileid] } { send_gdb "quit\n"; gdb_expect 10 { -re "y or n" { send_gdb "y\n"; exp_continue; } -re "DOSEXIT code" { } default { } } } if ![is_remote host] { remote_close host; } unset gdb_spawn_id } # # load a file into the debugger. # return a -1 if anything goes wrong. # proc gdb_file_cmd { arg } { global verbose global loadpath global loadfile global GDB global gdb_prompt upvar timeout timeout if [is_remote host] { set arg [remote_download host $arg]; if { $arg == "" } { error "download failed" return -1; } } send_gdb "file $arg\n" gdb_expect 120 { -re "Reading symbols from.*done.*$gdb_prompt $" { verbose "\t\tLoaded $arg into the $GDB" return 0 } -re "has no symbol-table.*$gdb_prompt $" { perror "$arg wasn't compiled with \"-g\"" return -1 } -re "A program is being debugged already.*Kill it.*y or n. $" { send_gdb "y\n" verbose "\t\tKilling previous program being debugged" exp_continue } -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" return 0 } timeout { perror "(timeout) Couldn't load $arg, other program already loaded." return -1 } } } -re "No such file or directory.*$gdb_prompt $" { perror "($arg) No such file or directory\n" return -1 } -re "$gdb_prompt $" { perror "couldn't load $arg into $GDB." return -1 } timeout { perror "couldn't load $arg into $GDB (timed out)." 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 (end of file)." return -1 } } } # # start gdb -- start gdb running, default procedure # # 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. # proc default_gdb_start { } { global verbose global GDB global GDBFLAGS global gdb_prompt global timeout global gdb_spawn_id; gdb_stop_suppressing_tests; verbose "Spawning $GDB -nw $GDBFLAGS" if [info exists gdb_spawn_id] { return 0; } if ![is_remote host] { if { [which $GDB] == 0 } then { perror "$GDB does not exist." exit 1 } } set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"]; if { $res < 0 || $res == "" } { perror "Spawning $GDB failed." return 1; } gdb_expect 360 { -re "\[\r\n\]$gdb_prompt $" { verbose "GDB initialized." } -re "$gdb_prompt $" { perror "GDB never initialized." return -1 } timeout { perror "(timeout) GDB never initialized after 10 seconds." remote_close host; return -1 } } set gdb_spawn_id -1; # force the height to "unlimited", so no pagers get used send_gdb "set height 0\n" gdb_expect 10 { -re "$gdb_prompt $" { verbose "Setting height to 0." 2 } timeout { warning "Couldn't set the height to 0" } } # force the width to "unlimited", so no wraparound occurs send_gdb "set width 0\n" gdb_expect 10 { -re "$gdb_prompt $" { verbose "Setting width to 0." 2 } timeout { warning "Couldn't set the width to 0." } } return 0; } # Return a 1 for configurations for which we don't even want to try to # test C++. proc skip_cplus_tests {} { if { [istarget "d10v-*-*"] } { return 1 } if { [istarget "h8300-*-*"] } { return 1 } return 0 } # * For crosses, the CHILL runtime doesn't build because it can't find # setjmp.h, stdio.h, etc. # * For AIX (as of 16 Mar 95), (a) there is no language code for # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2 # does not get along with AIX's too-clever linker. # * On Irix5, there is a bug whereby set of bool, etc., don't get # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't # work with stub types. # Lots of things seem to fail on the PA, and since it's not a supported # chill target at the moment, don't run the chill tests. proc skip_chill_tests {} { if ![info exists do_chill_tests] { return 1; } eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]] verbose "Skip chill tests is $skip_chill" return $skip_chill } # Skip all the tests in the file if you are not on an hppa running # hpux target. proc skip_hp_tests {} { eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ] verbose "Skip hp tests is $skip_hp" return $skip_hp } proc get_compiler_info {binfile args} { # Create and source the file that provides information about the compiler # used to compile the test case. # Compiler_type can be null or c++. If null we assume c. global srcdir global subdir # These two come from compiler.c. global signed_keyword_not_used global gcc_compiled if {![istarget "hppa*-*-hpux*"]} { if { [llength $args] > 0 } { if {$args == "c++"} { if { [gdb_compile "${srcdir}/lib/compiler.cc" "${binfile}.ci" preprocess {}] != "" } { perror "Couldn't make ${binfile}.ci file" return 1; } } } else { if { [gdb_compile "${srcdir}/lib/compiler.c" "${binfile}.ci" preprocess {}] != "" } { perror "Couldn't make ${binfile}.ci file" return 1; } } } else { if { [llength $args] > 0 } { if {$args == "c++"} { if { [eval gdb_preprocess \ [list "${srcdir}/lib/compiler.cc" "${binfile}.ci"] \ $args] != "" } { perror "Couldn't make ${binfile}.ci file" return 1; } } } elseif { $args != "f77" } { if { [eval gdb_preprocess \ [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \ $args] != "" } { perror "Couldn't make ${binfile}.ci file" return 1; } } } uplevel \#0 { set gcc_compiled 0 } if { [llength $args] == 0 || $args != "f77" } { source ${binfile}.ci } # Most compilers will evaluate comparisons and other boolean # operations to 0 or 1. uplevel \#0 { set true 1 } uplevel \#0 { set false 0 } uplevel \#0 { set hp_cc_compiler 0 } uplevel \#0 { set hp_aCC_compiler 0 } uplevel \#0 { set hp_f77_compiler 0 } uplevel \#0 { set hp_f90_compiler 0 } if { !$gcc_compiled && [istarget "hppa*-*-hpux*"] } { # Check for the HP compilers set compiler [lindex [split [get_compiler $args] " "] 0] catch "exec what $compiler" output if [regexp ".*HP aC\\+\\+.*" $output] { uplevel \#0 { set hp_aCC_compiler 1 } # Use of aCC results in boolean results being displayed as # "true" or "false" uplevel \#0 { set true true } uplevel \#0 { set false false } } elseif [regexp ".*HP C Compiler.*" $output] { uplevel \#0 { set hp_cc_compiler 1 } } elseif [regexp ".*HP-UX f77.*" $output] { uplevel \#0 { set hp_f77_compiler 1 } } elseif [regexp ".*HP-UX f90.*" $output] { uplevel \#0 { set hp_f90_compiler 1 } } } return 0; } proc get_compiler {args} { global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET if { [llength $args] == 0 || ([llength $args] == 1 && [lindex $args 0] == "") } { set which_compiler "c" } else { if { $args =="c++" } { set which_compiler "c++" } elseif { $args =="f77" } { set which_compiler "f77" } else { perror "Unknown compiler type supplied to gdb_preprocess" return "" } } if [info exists CC_FOR_TARGET] { if {$which_compiler == "c"} { set compiler $CC_FOR_TARGET } } if [info exists CXX_FOR_TARGET] { if {$which_compiler == "c++"} { set compiler $CXX_FOR_TARGET } } if [info exists F77_FOR_TARGET] { if {$which_compiler == "f77"} { set compiler $F77_FOR_TARGET } } if { ![info exists compiler] } { if { $which_compiler == "c" } { if {[info exists CC]} { set compiler $CC } } if { $which_compiler == "c++" } { if {[info exists CXX]} { set compiler $CXX } } if {![info exists compiler]} { set compiler [board_info [target_info name] compiler]; if { $compiler == "" } { perror "get_compiler: No compiler found" return "" } } } return $compiler } proc gdb_preprocess {source dest args} { set compiler [get_compiler "$args"] if { $compiler == "" } { return 1 } set cmdline "$compiler -E $source > $dest" verbose "Invoking $compiler -E $source > $dest" verbose -log "Executing on local host: $cmdline" 2 set status [catch "exec ${cmdline}" exec_output] set result [prune_warnings $exec_output] regsub "\[\r\n\]*$" "$result" "" result; regsub "^\[\r\n\]*" "$result" "" result; if { $result != "" } { clone_output "gdb compile failed, $result" } return $result; } proc gdb_compile {source dest type options} { global GDB_TESTCASE_OPTIONS; if [target_info exists gdb_stub] { set options2 { "additional_flags=-Dusestubs" } lappend options "libs=[target_info gdb_stub]"; set options [concat $options2 $options] } if [target_info exists is_vxworks] { set options2 { "additional_flags=-Dvxworks" } lappend options "libs=[target_info gdb_stub]"; set options [concat $options2 $options] } if [info exists GDB_TESTCASE_OPTIONS] { lappend options "additional_flags=$GDB_TESTCASE_OPTIONS"; } verbose "options are $options" verbose "source is $source $dest $type $options" set result [target_compile $source $dest $type $options]; regsub "\[\r\n\]*$" "$result" "" result; regsub "^\[\r\n\]*" "$result" "" result; if { $result != "" } { clone_output "gdb compile failed, $result" } return $result; } proc send_gdb { string } { global suppress_flag; if { $suppress_flag } { return "suppressed"; } return [remote_send host "$string"]; } # # proc gdb_expect { args } { # allow -notransfer expect flag specification, # used by gdb_test routine for multi-line commands. # packed with gtimeout when fed to remote_expect routine, # which is a hack but due to what looks like a res and orig # parsing problem in remote_expect routine (dejagnu/lib/remote.exp): # what's fed into res is not removed from orig. # - guo if { [lindex $args 0] == "-notransfer" } { set notransfer -notransfer; set args [lrange $args 1 end]; } else { set notransfer ""; } if { [llength $args] == 2 && [lindex $args 0] != "-re" } { set gtimeout [lindex $args 0]; set expcode [list [lindex $args 1]]; } else { upvar timeout timeout; set expcode $args; if [target_info exists gdb,timeout] { if [info exists timeout] { if { $timeout < [target_info gdb,timeout] } { set gtimeout [target_info gdb,timeout]; } else { set gtimeout $timeout; } } else { set gtimeout [target_info gdb,timeout]; } } if ![info exists gtimeout] { global timeout; if [info exists timeout] { set gtimeout $timeout; } else { # Eeeeew. set gtimeout 60; } } } 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 "$gtimeout $notransfer" $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; return -code error -errorinfo $errorInfo -errorcode $errorCode $string } elseif {$code == 2} { return -code return $string } elseif {$code == 3} { return } elseif {$code > 4} { return -code $code $string } } # gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs # # Check for long sequence of output by parts. # MESSAGE: is the test message to be printed with the test success/fail. # SENTINEL: Is the terminal pattern indicating that output has finished. # LIST: is the sequence of outputs to match. # If the sentinel is recognized early, it is considered an error. # # Returns: # 1 if the test failed, # 0 if the test passes, # -1 if there was an internal error. # 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 } while { ${index} < [llength ${list}] } { set pattern [lindex ${list} ${index}] set index [expr ${index} + 1] if { ${index} == [llength ${list}] } { if { ${ok} } { gdb_expect { -re "${pattern}${sentinel}" { pass "${test}, pattern ${index} + sentinel" } -re "${sentinel}" { fail "${test}, pattern ${index} + sentinel" set ok 0 } timeout { fail "${test}, pattern ${index} + sentinel (timeout)" set ok 0 } } } else { unresolved "${test}, pattern ${index} + sentinel" } } else { if { ${ok} } { gdb_expect { -re "${pattern}" { pass "${test}, pattern ${index}" } -re "${sentinel}" { fail "${test}, pattern ${index}" set ok 0 } timeout { fail "${test}, pattern ${index} (timeout)" set ok 0 } } } else { unresolved "${test}, pattern ${index}" } } } if { ${ok} } { return 0 } else { return 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; } proc gdb_start { } { default_gdb_start } proc gdb_exit { } { catch default_gdb_exit } # # gdb_load -- load a file into the debugger. # return a -1 if anything goes wrong. # proc gdb_load { arg } { return [gdb_file_cmd $arg] } proc gdb_continue { function } { global decimal return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"]; } proc default_gdb_init { args } { gdb_clear_suppressed; # Uh, this is lame. Really, really, really lame. But there's this *one* # testcase that will fail in random places if we don't increase this. match_max -d 20000 # We want to add the name of the TCL testcase to the PASS/FAIL messages. if { [llength $args] > 0 } { global pf_prefix set file [lindex $args 0]; set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:"; } global gdb_prompt; if [target_info exists gdb_prompt] { set gdb_prompt [target_info gdb_prompt]; } else { set gdb_prompt "\\(gdb\\)" } } proc gdb_init { args } { return [eval default_gdb_init $args]; } proc gdb_finish { } { gdb_exit; } global debug_format set debug_format "unknown" # Run the gdb command "info source" and extract the debugging format # information from the output and save it in debug_format. proc get_debug_format { } { global gdb_prompt global verbose global expect_out global debug_format set debug_format "unknown" send_gdb "info source\n" gdb_expect 10 { -re "Compiled with (.*) debugging format.\r\n$gdb_prompt $" { set debug_format $expect_out(1,string) verbose "debug format is $debug_format" return 1; } -re "No current source file.\r\n$gdb_prompt $" { perror "get_debug_format used when no current source file" return 0; } -re "$gdb_prompt $" { warning "couldn't check debug format (no valid response)." return 1; } timeout { warning "couldn't check debug format (timed out)." return 1; } } } # Like setup_xfail, but takes the name of a debug format (DWARF 1, # COFF, stabs, etc). If that format matches the format that the # current test was compiled with, then the next test is expected to # fail for any target. Returns 1 if the next test or set of tests is # expected to fail, 0 otherwise (or if it is unknown). Must have # previously called get_debug_format. proc setup_xfail_format { format } { global debug_format if [string match $debug_format $format] then { setup_xfail "*-*-*" return 1; } return 0 } proc gdb_step_for_stub { } { global gdb_prompt; if ![target_info exists gdb,use_breakpoint_for_stub] { if [target_info exists gdb_stub_step_command] { set command [target_info gdb_stub_step_command]; } else { set command "step"; } send_gdb "${command}\n"; set tries 0; gdb_expect 60 { -re "(main.* at |.*in .*start).*$gdb_prompt" { return; } -re ".*$gdb_prompt" { incr tries; if { $tries == 5 } { fail "stepping out of breakpoint function"; return; } send_gdb "${command}\n"; exp_continue; } default { fail "stepping out of breakpoint function"; return; } } } send_gdb "where\n"; gdb_expect { -re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" { set file $expect_out(1,string); set linenum [expr $expect_out(2,string) + 1]; set breakplace "${file}:${linenum}"; } default {} } send_gdb "break ${breakplace}\n"; gdb_expect 60 { -re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" { set breakpoint $expect_out(1,string); } -re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" { set breakpoint $expect_out(1,string); } default {} } send_gdb "continue\n"; gdb_expect 60 { -re "Breakpoint ${breakpoint},.*$gdb_prompt" { gdb_test "delete $breakpoint" ".*" ""; return; } default {} } } ### gdb_get_line_number TEXT [FILE] ### ### Search the source file FILE, and return the line number of a line ### containing TEXT. Use this function instead of hard-coding line ### numbers into your test script. ### ### Specifically, this function uses GDB's "search" command to search ### FILE for the first line containing TEXT, and returns its line ### number. Thus, FILE must be a source file, compiled into the ### executable you are running. If omitted, FILE defaults to the ### value of the global variable `srcfile'; most test scripts set ### `srcfile' appropriately at the top anyway. ### ### Use this function to keep your test scripts independent of the ### exact line numbering of the source file. Don't write: ### ### send_gdb "break 20" ### ### This means that if anyone ever edits your test's source file, ### your test could break. Instead, put a comment like this on the ### source file line you want to break at: ### ### /* breakpoint spot: frotz.exp: test name */ ### ### and then write, in your test script (which we assume is named ### frotz.exp): ### ### send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n" ### ### (Yes, Tcl knows how to handle the nested quotes and brackets. ### Try this: ### $ tclsh ### % puts "foo [lindex "bar baz" 1]" ### foo baz ### % ### Tcl is quite clever, for a little stringy language.) proc gdb_get_line_number {text {file /omitted/}} { global gdb_prompt; global srcfile; if {! [string compare $file /omitted/]} { set file $srcfile } set result -1; gdb_test "list ${file}:1,1" ".*" "" send_gdb "search ${text}\n" gdb_expect { -re "\[\r\n\]+(\[0-9\]+)\[ \t\].*${text}.*$gdb_prompt $" { set result $expect_out(1,string) } -re ".*$gdb_prompt $" { fail "find line number containing \"${text}\"" } timeout { fail "find line number containing \"${text}\" (timeout)" } } return $result; } # gdb_continue_to_end: # The case where the target uses stubs has to be handled specially. If a # stub is used, we set a breakpoint at exit because we cannot rely on # exit() behavior of a remote target. # # mssg is the error message that gets printed. proc gdb_continue_to_end {mssg} { if [target_info exists use_gdb_stub] { if {![gdb_breakpoint "exit"]} { return 0 } gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \ "continue until exit at $mssg" } else { # Continue until we exit. Should not stop again. # Don't bother to check the output of the program, that may be # extremely tough for some remote systems. gdb_test "continue"\ "Continuing.\[\r\n0-9\]+Program exited normally\\..*"\ "continue until exit at $mssg" } } proc rerun_to_main {} { global gdb_prompt if [target_info exists use_gdb_stub] { gdb_run_cmd gdb_expect { -re ".*Breakpoint .*main .*$gdb_prompt $"\ {pass "rerun to main" ; return 0} -re "$gdb_prompt $"\ {fail "rerun to main" ; return 0} timeout {fail "(timeout) rerun to main" ; return 0} } } else { send_gdb "run\n" gdb_expect { -re "Starting program.*$gdb_prompt $"\ {pass "rerun to main" ; return 0} -re "$gdb_prompt $"\ {fail "rerun to main" ; return 0} timeout {fail "(timeout) rerun to main" ; return 0} } } } # Print a message and return true if a test should be skipped # due to lack of floating point suport. proc gdb_skip_float_test { msg } { if [target_info exists gdb,skip_float_tests] { verbose "Skipping test '$msg': no float tests."; return 1; } return 0; } # Print a message and return true if a test should be skipped # due to lack of stdio support. proc gdb_skip_stdio_test { msg } { if [target_info exists gdb,noinferiorio] { verbose "Skipping test '$msg': no inferior i/o."; return 1; } return 0; } proc gdb_skip_bogus_test { msg } { return 0; }