diff options
author | Stan Shebs <shebs@codesourcery.com> | 1999-04-16 01:34:07 +0000 |
---|---|---|
committer | Stan Shebs <shebs@codesourcery.com> | 1999-04-16 01:34:07 +0000 |
commit | 071ea11e85eb9d529cc5eb3d35f6247466a21b99 (patch) | |
tree | 5deda65b8d7b04d1f4cbc534c3206d328e1267ec /gdb/testsuite/lib | |
parent | 1730ec6b1848f0f32154277f788fb29f88d8475b (diff) | |
download | gdb-071ea11e85eb9d529cc5eb3d35f6247466a21b99.zip gdb-071ea11e85eb9d529cc5eb3d35f6247466a21b99.tar.gz gdb-071ea11e85eb9d529cc5eb3d35f6247466a21b99.tar.bz2 |
Initial creation of sourceware repository
Diffstat (limited to 'gdb/testsuite/lib')
-rw-r--r-- | gdb/testsuite/lib/.Sanitize | 69 | ||||
-rw-r--r-- | gdb/testsuite/lib/gdb.exp | 1373 | ||||
-rw-r--r-- | gdb/testsuite/lib/trace-support.exp | 307 |
3 files changed, 0 insertions, 1749 deletions
diff --git a/gdb/testsuite/lib/.Sanitize b/gdb/testsuite/lib/.Sanitize deleted file mode 100644 index 1374cf0..0000000 --- a/gdb/testsuite/lib/.Sanitize +++ /dev/null @@ -1,69 +0,0 @@ -# .Sanitize for deja-gnu. - -# Each directory to survive it's way into a release will need a file -# like this one called "./.Sanitize". All keyword lines must exist, -# and must exist in the order specified by this file. Each directory -# in the tree will be processed, top down, in the following order. - -# Hash started lines like this one are comments and will be deleted -# before anything else is done. Blank lines will also be squashed -# out. - -# The lines between the "Do-first:" line and the "Things-to-keep:" -# line are executed as a /bin/sh shell script before anything else is -# done in this directory. - -Do-first: - -# All files listed between the "Things-to-keep:" line and the -# "Do-last:" line will be kept. All other files will be removed. -# Directories listed in this section will have their own Sanitize -# called. Directories not listed will be removed in their entirety -# with rm -rf. - -Things-to-keep: - -emc-support.exp -gdb.exp -trace-support.exp - -Things-to-lose: - - -# The lines between the "Do-last:" line and the end of the file -# are executed as a /bin/sh shell script after everything else is -# done. - -Do-last: - -if ( echo $* | grep lose\-gdbtk > /dev/null ) ; then - echo Catering to RMS by removing traces of \"gdbtk\"... - for i in * ; do - if test ! -d $i && (grep sanitize-gdbtk $i > /dev/null) ; then - echo Removing traces of \"gdbtk\" out of $i... - cp $i new - sed '/start\-sanitize\-gdbtk/,/end-\sanitize\-gdbtk/d' < $i > new - if [ -n "${safe}" -a ! -f .Recover/$i ] ; then - echo Caching $i in .Recover... - mv $i .Recover - fi - mv new $i - fi - done -else - echo Leaving \"gdbtk\" in the sources... - for i in * ; do - if test ! -d $i && (grep sanitize-gdbtk $i > /dev/null) ; then - echo Keeping \"gdbtk\" stuff in $i, but editing out sanitize lines... - cp $i new - sed -e '/start\-sanitize\-gdbtk/d' -e '/end\-sanitize\-gdbtk/d' < $i > new - if [ -n "${safe}" -a ! -f .Recover/$i ] ; then - echo Caching $i in .Recover... - mv $i .Recover - fi - mv new $i - fi - done -fi - -# eof diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp deleted file mode 100644 index b2f3ba9..0000000 --- a/gdb/testsuite/lib/gdb.exp +++ /dev/null @@ -1,1373 +0,0 @@ -# Copyright (C) 1992, 1994, 1995, 1997 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 prompt is a regexp which matches the gdb prompt. Set it if it -# is not already set. -global gdb_prompt -if ![info exists prompt] then { - set gdb_prompt "\[(\]gdb\[)\]" -} - -# -# 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 - - send_gdb "delete breakpoints\n" - gdb_expect 30 { - -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 30 { - -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] { - # According to Stu, this will always work. - gdb_load ""; - 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" - gdb_expect 30 { - -re "Continuing at \[^\r\n\]*\[\r\n\]" { - if ![target_info exists gdb_stub] { - return; - } - } - -re "No symbol \"start\" in current.*$gdb_prompt $" { - send_gdb "jump *_start\n"; - exp_continue; - } - -re "No symbol \"_start\" in current.*$gdb_prompt $" { - perror "Can't find start symbol to run in gdb_run"; - return; - } - -re "Line.* Jump anyway.*y or n. $" { - send_gdb "y\n" - exp_continue; - } - -re "No symbol.*context.*$gdb_prompt $" {} - -re "The program is not being run.*$gdb_prompt $" { - gdb_load ""; - send_gdb "jump *$start\n"; - exp_continue; - } - 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 -} - -# -# gdb_test -- send_gdb a command to gdb and test the result. -# Takes three parameters. -# Parameters: -# First one is the command to execute. If this is the null string -# then no command is sent. -# Second one is the pattern to match for a PASS, and must NOT include -# the \r\n sequence immediately before the gdb prompt. -# Third one is an optional message to be printed. If this -# a null string "", then the pass/fail messages use the command -# string as the message. -# 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; - } - gdb_expect 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 [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 command:.*$gdb_prompt" { - perror "Undefined command \"$command\"." - set result 1 - } - -re "Ambiguous command.*$gdb_prompt $" { - perror "\"$command\" is not a unique command name." - 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 - } - "<return>" { - send_gdb "\n" - perror "Window too small." - } - -re "\\(y or n\\) " { - send_gdb "n\n" - perror "Got interactive prompt." - } - eof { - perror "Process no longer exists" - if { $message != "" } { - fail "$message" - } - return -1 - } - full_buffer { - perror "internal buffer is full." - } - 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; -} - -# * 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. -# and you compiled with gcc -proc skip_hp_tests {gcc_used} { - # if ![info exists do_hp_tests] { - # return 1; - # } - eval set skip_hp [expr ![isnative] || ![istarget "hppa*-*-hpux*"] || $gcc_used!=0 ] - 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}/${subdir}/compiler.cc" "${binfile}.ci" preprocess {}] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } else { - if { [gdb_compile "${srcdir}/${subdir}/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}/${subdir}/compiler.cc" "${binfile}.ci"] \ - $args] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } else { - if { [eval gdb_preprocess \ - [list "${srcdir}/${subdir}/compiler.c" "${binfile}.ci"] \ - $args] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } - - source ${binfile}.ci - return 0; -} - -proc gdb_preprocess {source dest args} { - global CC_FOR_TARGET - global CXX_FOR_TARGET - - if { [llength $args] == 0 } { - set which_compiler "c" - } else { - if { $args =="c++" } { - set which_compiler "c++" - } else { - perror "Unknown compiler type supplied to gdb_preprocess" - return 1; - } - } - - 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 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 == "" } { - puts "default_target_compile: No compiler to compile with"; - return "default_target_compile: No compiler to compile with"; - } - } - } - - set cmdline "$compiler -E $source > $dest" - - puts "Invoking $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 } { - 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 $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 - } -} - -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 - -# 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 {} - } -} - -# start-sanitize-gdbtk -# From dejagnu: -# srcdir = testsuite src dir (e.g., devo/gdb/testsuite) -# objdir = testsuite obj dir (e.g., gdb/testsuite) -# subdir = subdir of testsuite (e.g., gdb.gdbtk) -# -# To gdbtk: -# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs) -# env(SRCDIR)=directory containing the test code (e.g., *.test) -# env(OBJDIR)=directory which contains any executables -# (e.g., gdb/testsuite/gdb.gdbtk) -proc gdbtk_start {test} { - global verbose - global GDB - global GDBFLAGS - global env srcdir subdir objdir - - gdb_stop_suppressing_tests; - - verbose "Starting $GDB -nx -q --tclcommand=$test" - - set real_test [which $test] - if {$real_test == 0} { - perror "$test is not found" - exit 1 - } - - if {![is_remote host]} { - if { [which $GDB] == 0 } { - perror "$GDB does not exist." - exit 1 - } - } - - set wd [pwd] - cd [file join $srcdir .. gdbtcl2] - set env(GDBTK_LIBRARY) [pwd] - cd [file join $srcdir .. .. tcl library] - set env(TCL_LIBRARY) [pwd] - cd [file join $srcdir .. .. tk library] - set env(TK_LIBRARY) [pwd] - cd [file join $srcdir .. .. tix library] - set env(TIX_LIBRARY) [pwd] - cd [file join $srcdir .. .. itcl itcl library] - set env(ITCL_LIBRARY) [pwd] - cd [file join .. $srcdir .. .. libgui library] - set env(CYGNUS_GUI_LIBRARY) [pwd] - cd $wd - cd [file join $srcdir $subdir] - set env(DEFS) [file join [pwd] defs] - cd $wd - cd [file join $objdir $subdir] - set env(OBJDIR) [pwd] - cd $wd - cd $srcdir - set env(SRCDIR) [pwd] - cd $wd - set env(GDBTK_VERBOSE) 1 - set env(GDBTK_LOGFILE) [file join $objdir gdb.log] - set env(GDBTK_TEST_RUNNING) 1 - set err [catch {exec $GDB -nx -q --tclcommand=$test} res] - if { $err } { - perror "Execing $GDB failed: $res" - exit 1; - } - return $res -} - -# gdbtk tests call this function to print out the results of the -# tests. The argument is a proper list of lists of the form: -# {status name description msg}. All of these things typically -# come from the testsuite harness. -proc gdbtk_analyze_results {results} { - foreach test $results { - set status [lindex $test 0] - set name [lindex $test 1] - set description [lindex $test 2] - set msg [lindex $test 3] - - switch $status { - PASS { - pass "$description ($name)" - } - - FAIL { - fail "$description ($name)" - } - - ERROR { - perror "$name" - } - - XFAIL { - xfail "$description ($name)" - } - - XPASS { - xpass "$description ($name)" - } - } - } -} -# end-sanitize-gdbtk diff --git a/gdb/testsuite/lib/trace-support.exp b/gdb/testsuite/lib/trace-support.exp deleted file mode 100644 index 4765791..0000000 --- a/gdb/testsuite/lib/trace-support.exp +++ /dev/null @@ -1,307 +0,0 @@ -# Copyright (C) 1998 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 - - -# -# Support procedures for trace testing -# - - -# -# Procedure: gdb_target_supports_trace -# Returns true if GDB is connected to a target that supports tracing. -# Allows tests to abort early if not running on a trace-aware target. -# - -proc gdb_target_supports_trace { } { - global gdb_prompt - - send_gdb "tstatus\n" - gdb_expect { - -re "\[Tt\]race can only be run on.*$gdb_prompt $" { - return 0 - } - -re "\[Tt\]race can not be run on.*$gdb_prompt $" { - return 0 - } - -re "\[Tt\]arget does not support.*$gdb_prompt $" { - return 0 - } - -re ".*\[Ee\]rror.*$gdb_prompt $" { - return 0 - } - -re ".*\[Ww\]arning.*$gdb_prompt $" { - return 0 - } - -re ".*$gdb_prompt $" { - return 1 - } - timeout { - return 0 - } - } -} - - -# -# Procedure: gdb_delete_tracepoints -# Many of the tests depend on setting tracepoints at various places and -# running until that tracepoint is reached. At times, we want to start -# with a clean slate with respect to tracepoints, so this utility proc -# lets us do this without duplicating this code everywhere. -# - -proc gdb_delete_tracepoints {} { - global gdb_prompt - - send_gdb "delete tracepoints\n" - gdb_expect 30 { - -re "Delete all tracepoints.*y or n.*$" { - send_gdb "y\n"; - exp_continue - } - -re ".*$gdb_prompt $" { # This happens if there were no tracepoints } - timeout { - perror "Delete all tracepoints in delete_tracepoints (timeout)" - return - } - } - send_gdb "info tracepoints\n" - gdb_expect 30 { - -re "No tracepoints.*$gdb_prompt $" {} - -re "$gdb_prompt $" { perror "tracepoints not deleted" ; return } - timeout { perror "info tracepoints (timeout)" ; return } - } -} - -# -# Procedure: gdb_trace_setactions -# Define actions for a tracepoint. -# Arguments: -# testname -- identifying string for pass/fail output -# tracepoint -- to which tracepoint do these actions apply? (optional) -# args -- list of actions to be defined. -# Returns: -# zero -- success -# non-zero -- failure - -proc gdb_trace_setactions { testname tracepoint args } { - global gdb_prompt; - - set state 0; - set passfail "pass"; - send_gdb "actions $tracepoint\n"; - set expected_result ""; - gdb_expect 5 { - -re "No tracepoint number .*$gdb_prompt $" { - fail $testname - return 1; - } - -re "Enter actions for tracepoint $tracepoint.*>" { - if { [llength $args] > 0 } { - set lastcommand "[lindex $args $state]"; - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - } - exp_continue; - } - -re "\(.*\)\[\r\n\]+\[ \t]*> $" { - if { $expected_result != "" } { - regsub "^\[^\r\n\]+\[\r\n\]+" "$expect_out(1,string)" "" out; - if ![regexp $expected_result $out] { - set passfail "fail"; - } - set expected_result ""; - } - if { $state < [llength $args] } { - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - set expected_result ""; - } - exp_continue; - } - -re "\(.*\)$gdb_prompt $" { - if { $expected_result != "" } { - if ![regexp $expected_result $expect_out(1,string)] { - set passfail "fail"; - } - set expected_result ""; - } - if { [llength $args] < $state } { - set passfail "fail"; - } - } - default { - set passfail "fail"; - } - } - if { $testname != "" } { - $passfail $testname; - } - if { $passfail == "pass" } then { - return 0; - } else { - return 1; - } -} - -# -# Procedure: gdb_tfind_test -# Find a specified trace frame. -# Arguments: -# testname -- identifying string for pass/fail output -# tfind_arg -- frame (line, PC, etc.) identifier -# exp_res -- Expected result of frame test -# args -- Test expression -# Returns: -# zero -- success -# non-zero -- failure -# - -proc gdb_tfind_test { testname tfind_arg exp_res args } { - global gdb_prompt; - - if { "$args" != "" } { - set expr "$exp_res"; - set exp_res "$args"; - } else { - set expr "(int) \$trace_frame"; - } - set passfail "fail"; - - gdb_test "tfind $tfind_arg" "" "" - send_gdb "printf \"x \%d x\\n\", $expr\n"; - gdb_expect 10 { - -re "x (-*\[0-9\]+) x" { - if { $expect_out(1,string) == $exp_res } { - set passfail "pass"; - } - exp_continue; - } - -re "$gdb_prompt $" { } - } - $passfail "$testname"; - if { $passfail == "pass" } then { - return 0; - } else { - return 1; - } -} - -# -# Procedure: gdb_readexpr -# Arguments: -# gdb_expr -- the expression whose value is desired -# Returns: -# the value of gdb_expr, as evaluated by gdb. -# [FIXME: returns -1 on error, which is sometimes a legit value] -# - -proc gdb_readexpr { gdb_expr } { - global gdb_prompt; - - set result -1; - send_gdb "print $gdb_expr\n" - gdb_expect 5 { - -re "\[$\].*= (\[0-9\]+).*$gdb_prompt $" { - set result $expect_out(1,string); - } - -re "$gdb_prompt $" { } - default { } - } - return $result; -} - -# -# Procedure: gdb_gettpnum -# Arguments: -# tracepoint (optional): if supplied, set a tracepoint here. -# Returns: -# the tracepoint ID of the most recently set tracepoint. -# - -proc gdb_gettpnum { tracepoint } { - global gdb_prompt; - - if { $tracepoint != "" } { - gdb_test "trace $tracepoint" "" "" - } - return [gdb_readexpr "\$tpnum"]; -} - - -# -# Procedure: gdb_find_function_baseline -# Arguments: -# func_name -- name of source function -# Returns: -# Sourcefile line of function definition (open curly brace), -# or -1 on failure. Caller must check return value. -# Note: -# Works only for open curly brace at beginning of source line! -# - -proc gdb_find_function_baseline { func_name } { - global gdb_prompt; - - set baseline -1; - - send_gdb "list $func_name\n" -# gdb_expect { -# -re "\[\r\n\]\[\{\].*$gdb_prompt $" { -# set baseline 1 -# } -# } -} - -# -# Procedure: gdb_find_function_baseline -# Arguments: -# filename: name of source file of desired function. -# Returns: -# Sourcefile line of function definition (open curly brace), -# or -1 on failure. Caller must check return value. -# Note: -# Works only for open curly brace at beginning of source line! -# - -proc gdb_find_recursion_test_baseline { filename } { - global gdb_prompt; - - set baseline -1; - - gdb_test "list $filename:1" "" "" - send_gdb "search gdb_recursion_test line 0\n" - gdb_expect { - -re "(\[0-9\]+)\[\t \]+\{.*line 0.*$gdb_prompt $" { - set baseline $expect_out(1,string); - } - -re "$gdb_prompt $" { } - default { } - } - return $baseline; -} |