}
verbose "using GDBFLAGS = $GDBFLAGS" 2
-# The variable prompt is a regexp which matches the gdb prompt. Set it if it
-# is not already set.
+# 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 prompt] then {
+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 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 30 {
+ gdb_expect 100 {
-re "Delete all breakpoints.*y or n.*$" {
send_gdb "y\n";
exp_continue
timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
}
send_gdb "info breakpoints\n"
- gdb_expect 30 {
+ gdb_expect 100 {
-re "No breakpoints or watchpoints..*$gdb_prompt $" {}
-re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
-re "Delete all breakpoints.*or n.*$" {
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 "";
+ # 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\]" {}
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";
+ 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;
}
- -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;
+ 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
+ }
}
- timeout { perror "Jump to start() failed (timeout)"; return }
}
if [target_info exists gdb_stub] {
gdb_expect 60 {
}
+### 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 -- send a command to gdb; test the result.
#
# COMMAND is the command to execute, send to GDB with send_gdb. If
fail "$message";
return $result;
}
- gdb_expect 2 {
+ # 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 { }
}
gdb_suppress_entire_file "GDB died";
return -1;
}
- -re "Ending remote debugging.*$gdb_prompt$" {
+ -re "Ending remote debugging.*$gdb_prompt $" {
if ![isnative] then {
warning "Can`t communicate to remote target."
}
send_gdb "$response_string\n";
exp_continue;
}
- -re "Undefined command:.*$gdb_prompt" {
+ -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 $" {
"<return>" {
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"
}
full_buffer {
perror "internal buffer is full."
+ fail "$message"
}
timeout {
if ![string match "" $message] then {
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
if {![istarget "hppa*-*-hpux*"]} {
if { [llength $args] > 0 } {
if {$args == "c++"} {
- if { [gdb_compile "${srcdir}/${subdir}/compiler.cc" "${binfile}.ci" preprocess {}] != "" } {
+ if { [gdb_compile "${srcdir}/lib/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 {}] != "" } {
+ if { [gdb_compile "${srcdir}/lib/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
perror "Couldn't make ${binfile}.ci file"
return 1;
}
if { [llength $args] > 0 } {
if {$args == "c++"} {
if { [eval gdb_preprocess \
- [list "${srcdir}/${subdir}/compiler.cc" "${binfile}.ci"] \
+ [list "${srcdir}/lib/compiler.cc" "${binfile}.ci"] \
$args] != "" } {
perror "Couldn't make ${binfile}.ci file"
return 1;
}
}
- } else {
+ } elseif { $args != "f77" } {
if { [eval gdb_preprocess \
- [list "${srcdir}/${subdir}/compiler.c" "${binfile}.ci"] \
+ [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \
$args] != "" } {
perror "Couldn't make ${binfile}.ci file"
return 1;
}
}
- source ${binfile}.ci
+ 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 gdb_preprocess {source dest args} {
- global CC_FOR_TARGET
- global CXX_FOR_TARGET
+proc get_compiler {args} {
+ global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET
- if { [llength $args] == 0 } {
+ 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 1;
+ return ""
}
}
if [info exists CC_FOR_TARGET] {
- if { $which_compiler == "c"} {
- set compiler $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 {$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;
+ set compiler $CC
}
}
if { $which_compiler == "c++" } {
if {[info exists CXX]} {
- set compiler $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";
+ 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"
#
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]];
set remote_suppress_flag 1;
}
}
- set code [catch {uplevel remote_expect host $gtimeout $expcode} string];
+ set code [catch \
+ {uplevel remote_expect host "$gtimeout $notransfer" $expcode} string];
if [info exists old_val] {
set remote_suppress_flag $old_val;
} else {
}
}
+# 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;
}
}
+# 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 $srcdir
+ set abs_srcdir [pwd]
+ cd [file join $abs_srcdir .. gdbtk library]
+ set env(GDBTK_LIBRARY) [pwd]
+ cd [file join $abs_srcdir .. .. tcl library]
+ set env(TCL_LIBRARY) [pwd]
+ cd [file join $abs_srcdir .. .. tk library]
+ set env(TK_LIBRARY) [pwd]
+ cd [file join $abs_srcdir .. .. tix library]
+ set env(TIX_LIBRARY) [pwd]
+ cd [file join $abs_srcdir .. .. itcl itcl library]
+ set env(ITCL_LIBRARY) [pwd]
+ cd [file join .. $abs_srcdir .. .. libgui library]
+ set env(CYGNUS_GUI_LIBRARY) [pwd]
+ cd $wd
+ cd [file join $abs_srcdir $subdir]
+ set env(DEFS) [file join [pwd] defs]
+ cd $wd
+ cd [file join $objdir $subdir]
+ set env(OBJDIR) [pwd]
+ cd $wd
+
+ set env(SRCDIR) $abs_srcdir
+ 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)"
+ }
+ }
+ }
+}
+
+# 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;
+}
+
projects / deliverable / binutils-gdb.git / blobdiff