+
+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}
+ }
+ }
+}
+
+# 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;
+}
+