-# Copyright (C) 1992, 1994, 1995, 1997, 1999 Free Software Foundation, Inc.
+# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 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
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_test COMMAND PATTERN MESSAGE -- send a command to gdb; test the result.
+# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# 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.
# 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.)
+# QUESTION is a question GDB may ask in response to COMMAND, like
+# "are you sure?"
+# RESPONSE is the response to send if QUESTION appears.
#
# Returns:
# 1 if the test failed,
# 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_expect 2 {
+ -notransfer -re "\[\r\n\]" { verbose "partial: match" 3 }
+ timeout { verbose "partial: timeout" 3 }
}
set string [string range "$string" [expr $foo + 1] end];
} else {
}
}
- if [info exists timeout] {
- set tmt $timeout;
+ if [target_info exists gdb,timeout] {
+ set tmt [target_info gdb,timeout];
} else {
- global timeout;
if [info exists timeout] {
set tmt $timeout;
} else {
- set tmt 60;
+ global timeout;
+ if [info exists timeout] {
+ set tmt $timeout;
+ } else {
+ set tmt 60;
+ }
}
}
gdb_expect $tmt {
}
fail "$errmsg"
return -1
+ }
+ -re "EXIT code \[0-9\r\n\]+Program exited normally.*$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 {
pass "reject $sendthis"
return 1
}
+ -re "Unmatched single quote.*$gdb_prompt $" {
+ pass "reject $sendthis"
+ return 1
+ }
+ -re "A character constant must contain at least one character.*$gdb_prompt $" {
+ pass "reject $sendthis"
+ return 1
+ }
-re "$expectthis.*$gdb_prompt $" {
pass "reject $sendthis"
return 1
return $result;
}
+set gdb_wrapper_initialized 0
+
+proc gdb_wrapper_init { args } {
+ global gdb_wrapper_initialized;
+ global gdb_wrapper_file;
+ global gdb_wrapper_flags;
+
+ if { $gdb_wrapper_initialized == 1 } { return; }
+
+ if {[target_info exists needs_status_wrapper] && \
+ [target_info needs_status_wrapper] != "0"} {
+ set result [build_wrapper "testglue.o"];
+ if { $result != "" } {
+ set gdb_wrapper_file [lindex $result 0];
+ set gdb_wrapper_flags [lindex $result 1];
+ } else {
+ warning "Status wrapper failed to build."
+ }
+ }
+ set gdb_wrapper_initialized 1
+}
+
proc gdb_compile {source dest type options} {
global GDB_TESTCASE_OPTIONS;
+ global gdb_wrapper_file;
+ global gdb_wrapper_flags;
+ global gdb_wrapper_initialized;
if [target_info exists gdb_stub] {
set options2 { "additional_flags=-Dusestubs" }
verbose "options are $options"
verbose "source is $source $dest $type $options"
+ if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init }
+
+ if {[target_info exists needs_status_wrapper] && \
+ [target_info needs_status_wrapper] != "0" && \
+ [info exists gdb_wrapper_file]} {
+ lappend options "libs=${gdb_wrapper_file}"
+ lappend options "ldflags=${gdb_wrapper_flags}"
+ }
+
set result [target_compile $source $dest $type $options];
regsub "\[\r\n\]*$" "$result" "" result;
regsub "^\[\r\n\]*" "$result" "" result;
#
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 code [catch \
- {uplevel remote_expect host "$gtimeout $notransfer" $expcode} string];
+ {uplevel remote_expect host $gtimeout $expcode} string];
if [info exists old_val] {
set remote_suppress_flag $old_val;
} else {
}
proc default_gdb_init { args } {
+ global gdb_wrapper_initialized
+
gdb_clear_suppressed;
+ # Make sure that the wrapper is rebuilt
+ # with the appropriate multilib option.
+ set gdb_wrapper_initialized 0
+
# 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
}
}
+# 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 } {
- global debug_format
+ set ret [test_debug_format $format];
- if [string match $debug_format $format] then {
+ if {$ret} then {
setup_xfail "*-*-*"
- return 1;
}
- return 0
-}
+ return $ret;
+}
proc gdb_step_for_stub { } {
global gdb_prompt;
# 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\\..*"\
+ "Continuing.\[\r\n0-9\]+(... EXIT code 0\[\r\n\]+|)Program exited normally\\..*"\
"continue until exit at $mssg"
}
}
}
}
-# 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
- }
+# Print a message and return true if a test should be skipped
+# due to lack of floating point suport.
- if {![is_remote host]} {
- if { [which $GDB] == 0 } {
- perror "$GDB does not exist."
- exit 1
+proc gdb_skip_float_test { msg } {
+ if [target_info exists gdb,skip_float_tests] {
+ verbose "Skipping test '$msg': no float tests.";
+ return 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
+ return 0;
}
-# 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 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