gdb.exp

gdb-6.8 Linux下的调试程序 最新版本

			gdb_internal_error_resync
		    }
		    timeout {
			fail "${test} (pattern ${index}) (timeout)"
			set ok 0
		    }
		}
	    } else {
		# unresolved "${test}, pattern ${index}"
	    }
	}
    }
    if { ${ok} } {
	pass "${test}"
	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_cmd -- load a file into the debugger.
#		  ARGS - additional args to load command.
#                 return a -1 if anything goes wrong.
#
proc gdb_load_cmd { args } {
    global gdb_prompt

    if [target_info exists gdb_load_timeout] {
	set loadtimeout [target_info gdb_load_timeout]
    } else {
	set loadtimeout 1600
    }
    send_gdb "load $args\n"
    verbose "Timeout is now $loadtimeout seconds" 2
    gdb_expect $loadtimeout {
	-re "Loading section\[^\r\]*\r\n" {
	    exp_continue
	}
	-re "Start address\[\r\]*\r\n" {
	    exp_continue
	}
	-re "Transfer rate\[\r\]*\r\n" {
	    exp_continue
	}
	-re "Memory access error\[^\r\]*\r\n" {
	    perror "Failed to load program"
	    return -1
	}
	-re "$gdb_prompt $" {
	    return 0
	}
	-re "(.*)\r\n$gdb_prompt " {
	    perror "Unexpected reponse from 'load' -- $expect_out(1,string)"
	    return -1
	}
	timeout {
	    perror "Timed out trying to load $arg."
	    return -1
	}
    }
    return -1
}

# gdb_download
#
# Copy a file to the remote target and return its target filename.
# Schedule the file to be deleted at the end of this test.

proc gdb_download { filename } {
    global cleanfiles

    set destname [remote_download target $filename]
    lappend cleanfiles $destname
    return $destname
}

# gdb_load_shlibs LIB...
#
# Copy the listed libraries to the target.

proc gdb_load_shlibs { args } {
    if {![is_remote target]} {
	return
    }

    foreach file $args {
	gdb_download $file
    }

    # Even if the target supplies full paths for shared libraries,
    # they may not be paths for this system.
    gdb_test "set solib-search-path [file dirname [lindex $args 0]]" "" ""
}

#
# gdb_load -- load a file into the debugger.
# Many files in config/*.exp override this procedure.
#
proc gdb_load { arg } {
    return [gdb_file_cmd $arg]
}

# gdb_reload -- load a file into the target.  Called before "running",
# either the first time or after already starting the program once,
# for remote targets.  Most files that override gdb_load should now
# override this instead.

proc gdb_reload { } {
    # For the benefit of existing configurations, default to gdb_load.
    # Specifying no file defaults to the executable currently being
    # debugged.
    return [gdb_load ""]
}

proc gdb_continue { function } {
    global decimal

    return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
}

proc default_gdb_init { args } {
    global gdb_wrapper_initialized
    global cleanfiles
    
    set cleanfiles {}

    gdb_clear_suppressed;

    # Make sure that the wrapper is rebuilt
    # with the appropriate multilib option.
    set gdb_wrapper_initialized 0
    
    # Unlike most tests, we have a small number of tests that generate
    # a very large amount of output.  We therefore increase the expect
    # buffer size to be able to contain the entire test output.
    match_max -d 30000

    # 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 { } {
    global cleanfiles

    # Exit first, so that the files are no longer in use.
    gdb_exit

    if { [llength $cleanfiles] > 0 } {
	eval remote_file target delete $cleanfiles
	set cleanfiles {}
    }
}

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

# Return true if FORMAT matches the debug format the current test was
# compiled with.  FORMAT is a shell-style globbing pattern; it can use
# `*', `[...]', and so on.
#
# This function depends on variables set by `get_debug_format', above.

proc test_debug_format {format} {
    global debug_format

    return [expr [string match $format $debug_format] != 0]
}

# 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 } {
    set ret [test_debug_format $format];

    if {$ret} then {
	setup_xfail "*-*-*"
    }
    return $ret;
}

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 the
# first line containing TEXT.  If no match is found, return -1.
# 
# TEXT is a string literal, not a regular expression.
#
# The default value of FILE is "$srcdir/$subdir/$srcfile".  If FILE is
# specified, and does not start with "/", then it is assumed to be in
# "$srcdir/$subdir".  This is awkward, and can be fixed in the future,
# by changing the callers and the interface at the same time.
# In particular: gdb.base/break.exp, gdb.base/condbreak.exp,
# gdb.base/ena-dis-br.exp.
#
# 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.)
#
# ===
#
# The previous implementation of this procedure used the gdb search command.
# This version is different:
#
#   . It works with MI, and it also works when gdb is not running.
#
#   . It operates on the build machine, not the host machine.
#
#   . For now, this implementation fakes a current directory of
#     $srcdir/$subdir to be compatible with the old implementation.
#     This will go away eventually and some callers will need to
#     be changed.
#
#   . The TEXT argument is literal text and matches literally,
#     not a regular expression as it was before.
#
#   . State changes in gdb, such as changing the current file
#     and setting $_, no longer happen.
#
# After a bit of time we can forget about the differences from the
# old implementation.
#
# --chastain 2004-08-05

proc gdb_get_line_number { text { file "" } } {
    global srcdir
    global subdir
    global srcfile

    if { "$file" == "" } then {
	set file "$srcfile"
    }
    if { ! [regexp "^/" "$file"] } then {
	set file "$srcdir/$subdir/$file"
    }

    if { [ catch { set fd [open "$file"] } message ] } then {
	perror "$message"
	return -1
    }

    set found -1
    for { set line 1 } { 1 } { incr line } {
	if { [ catch { set nchar [gets "$fd" body] } message ] } then {
	    perror "$message"
	    return -1
	}
	if { $nchar < 0 } then {
	    break
	}
	if { [string first "$text" "$body"] >= 0 } then {
	    set found $line
	    break
	}
    }

    if { [ catch { close "$fd" } message ] } then {
	perror "$message"
	return -1
    }

    return $found
}

# 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"\
      "C