OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /or1k/trunk/gdb-5.0/gdb/testsuite/lib
    from Rev 107 to Rev 1765
    ↔ Reverse comparison
  •

Rev 107 → Rev 1765

/trace-support.exp
0,0 → 1,307
# 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;
}
/gdb.exp
0,0 → 1,1689
# Copyright (C) 1992, 1994, 1995, 1997, 1999 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\[)\]"
}
 
### 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 -- 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.)
#
# 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 [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
}
"<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"
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}
}
}
}
 
# 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)"
}
}
}
}
/emc-support.exp
0,0 → 1,223
proc gdb_emc_readvar { varname } {
global gdb_prompt;
 
set result -1;
send_gdb "print $varname\n"
gdb_expect 5 {
-re "\[$\].*= (\[0-9\]+).*$gdb_prompt $" {
set result $expect_out(1,string);
}
-re "$gdb_prompt $" { }
default { }
}
return $result;
}
proc gdb_emc_gettpnum { testname } {
global gdb_prompt;
 
if { $testname != "" } {
gdb_test "trace $testname" "" ""
}
return [gdb_emc_readvar "\$tpnum"];
}
 
proc gdb_emc_setactions { testname actionname args } {
global gdb_prompt;
 
set state 0;
set status "pass";
send_gdb "actions $actionname\n";
set expected_result "";
gdb_expect 5 {
-re "No tracepoint number .*$gdb_prompt $" {
fail $testname
return 1;
}
-re "Enter actions for tracepoint $actionname.*>" {
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 != "" } {
# Remove echoed command and its associated newline.
regsub "^\[^\r\n\]+\[\r\n\]+" "$expect_out(1,string)" "" out;
# Strip off any newlines at the end of the string.
regsub "\[\r\n\]+$" "$out" "" out;
verbose "expected '$expected_result', got '$out', expect_out is '$expect_out(1,string)'";
if ![regexp $expected_result $out] {
set status "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 status "fail";
}
set expected_result "";
}
if { [llength $args] < $state } {
set status "fail";
}
}
default {
set status "fail";
}
}
if { $testname != "" } {
$status $testname;
}
if { $status == "pass" } then {
return 0;
} else {
return 1;
}
}
 
#
# test collect command
#
 
proc gdb_emc_tracetest_collect { arg1 msgstring } {
global decimal
global gdb_prompt;
 
set teststate 0
gdb_expect 30 {
-re "Enter actions for tracepoint $decimal.*> $" {
send_gdb "collect $arg1\n"
incr teststate;
exp_continue
}
-re "> $" {
if { $teststate == 1 } {
send_gdb "end\n"
incr teststate;
exp_continue
} else {
fail "$msgstring"
}
}
-re ".*$gdb_prompt $" {
if { $teststate == 2 } {
pass "$msgstring";
} else {
fail "$msgstring";
}
}
default {
fail "$msgstring (default)";
}
}
regsub -all "(\[($@*+)\])" "collect $arg1" "\[\\1\]" arg1_regexp;
gdb_test "info tracepoints" ".*$arg1_regexp.*" "$msgstring info tracepoint"
}
 
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 $" { }
timeout { fail "delete all tracepoints (timeout)" }
}
}
 
 
# Send each command in the list CMDLIST to gdb. If we see the string
# "error" or "warning" from gdb, we assume an error has occured and
# return a non-zero result. All of the commands in CMDLIST are always
# sent, even if an error occurs.
# If TESTNAME is non-null, we call pass or fail with the string in TESTNAME
# depending on whether or not an error/warning has occurred.
#
proc gdb_do_cmdlist { cmdlist testname } {
global gdb_prompt;
 
set status 0;
 
foreach x $cmdlist {
send_gdb "$x\n";
gdb_expect 60 {
-re "\[Ee\]rror|\[Ww\]arning" {
set status 1;
exp_continue;
}
-re "$gdb_prompt $" { }
-re "\[\r\n\]\[ \t\]*> *$" { }
}
}
if { $testname != "" } {
if { $status == 0 } {
pass "$testname";
} else {
fail "$testname";
}
}
return $status;
}
 
#
# Given the file FILENAME, we read it as a list of commands and generate
# a list suitable for use by gdb_do_cmdlist. Lines beginning with # are
# ignored; blank lines are interpreted as empty lines to be sent to gdb.
#
proc gdb_process_cmdfile { filename } {
set id [open $filename "r"];
if { $id < 0 } {
return "";
}
set result {};
while { [gets $id line] >= 0 } {
if [regexp "^#" $line] {
continue;
}
set result [concat $result [list "$line"]];
}
close $id;
return $result;
}
 
# gdb_find_c_test_baseline
# returns -1 on failure (CALLER MUST CHECK RETURN!)
proc gdb_find_c_test_baseline { } {
global gdb_prompt;
 
set gdb_c_test_baseline -1;
 
send_gdb "list gdb_c_test\n"
gdb_expect {
-re "void.*p5,.*void.*p6.*\[\r\n\](\[0-9\]+)\[\t \]+\{.*$gdb_prompt $" {
set gdb_c_test_baseline $expect_out(1,string)
}
-re "$gdb_prompt $" { }
default { }
}
return $gdb_c_test_baseline;
}
 
 
/mi-support.exp
0,0 → 1,688
# Copyright (C) 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 based on a file written by Fred Fish. (fnf@cygnus.com)
 
# Test setup routines that work with the MI interpreter.
 
# The variable mi_gdb_prompt is a regexp which matches the gdb mi prompt.
# Set it if it is not already set.
global mi_gdb_prompt
if ![info exists mi_gdb_prompt] then {
set mi_gdb_prompt "\[(\]gdb\[)\] \r\n"
}
 
set MIFLAGS "-i=mi"
 
#
# mi_gdb_exit -- exit the GDB, killing the target program if necessary
#
proc mi_gdb_exit {} {
catch mi_uncatched_gdb_exit
}
 
proc mi_uncatched_gdb_exit {} {
global GDB
global GDBFLAGS
global verbose
global gdb_spawn_id;
global gdb_prompt
global mi_gdb_prompt
global MIFLAGS
 
gdb_stop_suppressing_tests;
 
if { [info procs sid_exit] != "" } {
sid_exit
}
 
if ![info exists gdb_spawn_id] {
return;
}
 
verbose "Quitting $GDB $GDBFLAGS $MIFLAGS"
 
if { [is_remote host] && [board_info host exists fileid] } {
send_gdb "999-gdb-exit\n";
gdb_expect 10 {
-re "y or n" {
send_gdb "y\n";
exp_continue;
}
-re "Undefined command.*$gdb_prompt $" {
send_gdb "quit\n"
exp_continue;
}
-re "DOSEXIT code" { }
default { }
}
}
 
if ![is_remote host] {
remote_close host;
}
unset gdb_spawn_id
}
 
#
# 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 mi_gdb_start { } {
global verbose
global GDB
global GDBFLAGS
global gdb_prompt
global mi_gdb_prompt
global timeout
global gdb_spawn_id;
global MIFLAGS
 
gdb_stop_suppressing_tests;
 
verbose "Spawning $GDB -nw $GDBFLAGS $MIFLAGS"
 
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 $MIFLAGS [host_info gdb_opts]"];
if { $res < 0 || $res == "" } {
perror "Spawning $GDB failed."
return 1;
}
gdb_expect {
-re ".*UI_OUT.*$mi_gdb_prompt$" {
verbose "GDB initialized."
}
-re ".*$mi_gdb_prompt$" {
untested "Skip mi tests (output not in headless format)."
remote_close host;
return -1;
}
-re ".*$gdb_prompt $" {
untested "Skip mi tests (got non-mi prompt)."
remote_close host;
return -1;
}
-re ".*unrecognized option.*for a complete list of options." {
untested "Skip mi tests (not compiled with mi support)."
remote_close host;
return -1;
}
timeout {
perror "(timeout) GDB never initialized after 10 seconds."
remote_close host;
return -1
}
}
set gdb_spawn_id -1;
 
# FIXME: mi output does not go through pagers, so these can be removed.
# force the height to "unlimited", so no pagers get used
send_gdb "100-gdb-set height 0\n"
gdb_expect 10 {
-re ".*100-gdb-set height 0\r\n100\\\^done\r\n$mi_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 "101-gdb-set width 0\n"
gdb_expect 10 {
-re ".*101-gdb-set width 0\r\n101\\\^done\r\n$mi_gdb_prompt$" {
verbose "Setting width to 0." 2
}
timeout {
warning "Couldn't set the width to 0."
}
}
 
# Finally start SID.
if { [info procs sid_start] != "" } {
verbose "Spawning SID"
sid_start
}
 
return 0;
}
 
# 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 mi_delete_breakpoints {} {
global mi_gdb_prompt
 
# FIXME: The mi operation won't accept a prompt back and will use the 'all' arg
send_gdb "102-break-delete\n"
gdb_expect 30 {
-re "Delete all breakpoints.*y or n.*$" {
send_gdb "y\n";
exp_continue
}
-re ".*102-break-delete\r\n102\\\^done\r\n$mi_gdb_prompt$" {
# This happens if there were no breakpoints
}
timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
}
 
# The correct output is not "No breakpoints or watchpoints." but an
# empty BreakpointTable. Also, a query is not acceptable with mi.
send_gdb "103-break-list\n"
gdb_expect 30 {
-re "103-break-list\r\n103\\\^done,BreakpointTable=\{\}\r\n$mi_gdb_prompt$" {}
-re "103-break-list\r\n103\\\^doneNo breakpoints or watchpoints.\r\n\r\n$mi_gdb_prompt$" {warning "Unexpected console text received"}
-re "$mi_gdb_prompt$" { perror "Breakpoints not deleted" ; return }
-re "Delete all breakpoints.*or n.*$" {
warning "Unexpected prompt for breakpoints deletion";
send_gdb "y\n";
exp_continue
}
timeout { perror "-break-list (timeout)" ; return }
}
}
 
proc mi_gdb_reinitialize_dir { subdir } {
global mi_gdb_prompt
 
global suppress_flag
if { $suppress_flag } {
return
}
 
if [is_remote host] {
return "";
}
 
send_gdb "104-environment-directory\n"
gdb_expect 60 {
-re ".*Reinitialize source path to empty.*y or n. " {
warning "Got confirmation prompt for dir reinitialization."
send_gdb "y\n"
gdb_expect 60 {
-re "$mi_gdb_prompt$" {}
timeout {error "Dir reinitialization failed (timeout)"}
}
}
-re "$mi_gdb_prompt$" {}
timeout {error "Dir reinitialization failed (timeout)"}
}
 
send_gdb "105-environment-directory $subdir\n"
gdb_expect 60 {
-re "Source directories searched.*$mi_gdb_prompt$" {
verbose "Dir set to $subdir"
}
-re "105\\\^done\r\n$mi_gdb_prompt$" {
# FIXME: We return just the prompt for now.
verbose "Dir set to $subdir"
# perror "Dir \"$subdir\" failed."
}
}
}
 
#
# load a file into the debugger.
# return a -1 if anything goes wrong.
#
proc mi_gdb_load { arg } {
global verbose
global loadpath
global loadfile
global GDB
global mi_gdb_prompt
upvar timeout timeout
 
# ``gdb_unload''
 
# ``gdb_file_cmd''
# FIXME: Several of these patterns are only acceptable for console
# output. Queries are an error for mi.
send_gdb "105-file-exec-and-symbols $arg\n"
gdb_expect 120 {
-re "Reading symbols from.*done.*$mi_gdb_prompt$" {
verbose "\t\tLoaded $arg into the $GDB"
# All OK
}
-re "has no symbol-table.*$mi_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.*$mi_gdb_prompt$" {
verbose "\t\tLoaded $arg with new symbol table into $GDB"
# All OK
}
timeout {
perror "(timeout) Couldn't load $arg, other program already loaded."
return -1
}
}
}
-re "No such file or directory.*$mi_gdb_prompt$" {
perror "($arg) No such file or directory\n"
return -1
}
-re "105-file-exec-and-symbols .*\r\n105\\\^done\r\n$mi_gdb_prompt$" {
# We are just giving the prompt back for now
# All OK
}
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
}
}
# ``load''
if { [info procs send_target_sid] != "" } {
# For SID, things get complex
send_target_sid
gdb_expect 60 {
-re "\\^done,.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to connect to SID target"
return -1
}
}
send_gdb "48-target-download\n"
gdb_expect 10 {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to download to SID target"
return -1
}
}
} elseif { [target_info protocol] == "sim" } {
# For the simulator, just connect to it directly.
send_gdb "47-target-select sim\n"
gdb_expect 10 {
-re "47\\^connected.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to select sim target"
return -1
}
}
send_gdb "48-target-download\n"
gdb_expect 10 {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to download to sim target"
return -1
}
}
}
return 0
}
 
# mi_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
# 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.)
#
# Returns:
# 1 if the test failed,
# 0 if the test passes,
# -1 if there was an internal error.
#
proc mi_gdb_test { args } {
global verbose
global mi_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.*$mi_gdb_prompt\[ \]*$" {
if ![isnative] then {
warning "Can`t communicate to remote target."
}
gdb_exit
gdb_start
set result -1
}
-re "(${question_string})$" {
send_gdb "$response_string\n";
exp_continue;
}
-re "Undefined.* command:.*$mi_gdb_prompt\[ \]*$" {
perror "Undefined command \"$command\"."
fail "$message"
set result 1
}
-re "Ambiguous command.*$mi_gdb_prompt\[ \]*$" {
perror "\"$command\" is not a unique command name."
fail "$message"
set result 1
}
-re "\[\r\n\]*($pattern)\[\r\n\]+$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
pass "$message"
}
set result 0
}
-re "Program exited with code \[0-9\]+.*$mi_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.*$mi_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 ".*$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
fail "$message"
}
set result 1
}
"<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"
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
}
 
#
# MI run command. (A modified version of gdb_run_cmd)
#
 
# In patterns, the newline sequence ``\r\n'' is matched explicitly as
# ``.*$'' could swallow up output that we attempt to match elsewhere.
 
proc mi_run_cmd {args} {
global suppress_flag
if { $suppress_flag } {
return -1
}
global mi_gdb_prompt
 
if [target_info exists gdb_init_command] {
send_gdb "[target_info gdb_init_command]\n";
gdb_expect 30 {
-re "$mi_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 { [mi_gdb_load ""] < 0 } {
return;
}
send_gdb "000-exec-continue\n";
gdb_expect 60 {
-re "Continu\[^\r\n\]*\[\r\n\]" {}
default {}
}
return;
}
}
 
send_gdb "000-exec-run $args\n"
gdb_expect {
-re "000\\^running\r\n${mi_gdb_prompt}" {
}
timeout {
perror "Unable to start target"
return
}
}
# NOTE: Shortly after this there will be a ``000*stopping,...(gdb)''
}
 
#
# Just like run-to-main but works with the MI interface
#
 
proc mi_run_to_main { } {
global suppress_flag
if { $suppress_flag } {
return -1
}
 
global mi_gdb_prompt
global hex
global decimal
global srcdir
global subdir
global binfile
global srcfile
 
set test "mi run-to-main"
mi_delete_breakpoints
mi_gdb_reinitialize_dir $srcdir/$subdir
mi_gdb_load ${binfile}
 
mi_gdb_test "200-break-insert main" \
"200\\^done,bkpt=\{number=\"1\",type=\"breakpoint\",disp=\"keep\",enabled=\"y\",addr=\"$hex\",func=\"main\",file=\".*\",line=\"\[0-9\]*\",times=\"0\"\}" \
"breakpoint at main"
 
mi_run_cmd
gdb_expect {
-re "000\\*stopped,reason=\"breakpoint-hit\",bkptno=\"1\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"main\",args=\{\},file=\".*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" {
pass "$test"
return 0
}
timeout {
fail "$test (timeout)"
return -1
}
}
}
 
 
# Next to the next statement
 
proc mi_next { test } {
global suppress_flag
if { $suppress_flag } {
return -1
}
global mi_gdb_prompt
send_gdb "220-exec-next\n"
gdb_expect {
-re "220\\^running\r\n${mi_gdb_prompt}220\\*stopped,reason=\"end-stepping-range\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\{.*\},,file=\".*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" {
pass "$test"
return 0
}
timeout {
fail "$test"
return -1
}
}
}
 
 
# Step to the next statement
 
proc mi_step { test } {
global suppress_flag
if { $suppress_flag } {
return -1
}
global mi_gdb_prompt
send_gdb "220-exec-step\n"
gdb_expect {
-re "220\\^running\r\n${mi_gdb_prompt}220\\*stopped,reason=\"end-stepping-range\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\{.*\},,file=\".*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" {
pass "$test"
return 0
}
timeout {
fail "$test"
return -1
}
}
}
 
 
# Local variables:
# change-log-default-name: "../gdb.mi/ChangeLog-mi"
# End:
/compiler.c
0,0 → 1,31
/* Often the behavior of any particular test depends upon what compiler was
used to compile the test. As each test is compiled, this file is
preprocessed by the same compiler used to compile that specific test
(different tests might be compiled by different compilers, particularly
if compiled at different times), and used to generate a *.ci (compiler
info) file for that test.
 
I.E., when callfuncs is compiled, a callfuncs.ci file will be generated,
which can then be sourced by callfuncs.exp to give callfuncs.exp access
to information about the compilation environment.
 
TODO: It might be a good idea to add expect code that tests each
definition made with 'set" to see if one already exists, and if so
warn about conflicts if it is being set to something else. */
 
/* This needs to be kept in sync with whatis.c and gdb.exp(get_compiler_info).
If this ends up being hairy, we could use a common header file. */
 
#if defined (__STDC__) || defined (_AIX)
set signed_keyword_not_used 0
#else
set signed_keyword_not_used 1
#endif
 
#if defined (__GNUC__)
set gcc_compiled __GNUC__
#else
set gcc_compiled 0
#endif
 
return 0
/compiler.cc
0,0 → 1,34
/* Often the behavior of any particular test depends upon what compiler was
used to compile the test. As each test is compiled, this file is
preprocessed by the same compiler used to compile that specific test
(different tests might be compiled by different compilers, particularly
if compiled at different times), and used to generate a *.ci (compiler
info) file for that test.
 
I.E., when callfuncs is compiled, a callfuncs.ci file will be generated,
which can then be sourced by callfuncs.exp to give callfuncs.exp access
to information about the compilation environment.
 
TODO: It might be a good idea to add expect code that tests each
definition made with 'set" to see if one already exists, and if so
warn about conflicts if it is being set to something else. */
 
#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 6))
set supports_template_debugging 1
#else
set supports_template_debugging 0
#endif
 
#if defined(__cplusplus)
set supports_template_debugging 1
#else
set supports_template_debugging 0
#endif
 
#if defined (__GNUC__)
set gcc_compiled __GNUC__
#else
set gcc_compiled 0
#endif
 
return 0

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.