1 # Copyright (C) 1992, 1994, 1995 Free Software Foundation, Inc.
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program; if not, write to the Free Software
15 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
17 # Please email any bugs, comments, and/or additions to this file to:
18 # bug-gdb@prep.ai.mit.edu
20 # This file was written by Fred Fish. (fnf@cygnus.com)
22 # Generic gdb subroutines that should work for any target. If these
23 # need to be modified for any target, it can be done with a variable
24 # or by passing arguments.
32 if ![info exists CHILL_LIB] {
33 set CHILL_LIB [findfile $base_dir/../../gcc/ch/runtime/libchill.a "$base_dir/../../gcc/ch/runtime/libchill.a" [transform -lchill]]
35 verbose "using CHILL_LIB = $CHILL_LIB" 2
36 if ![info exists CHILL_RT0] {
37 set CHILL_RT0 [findfile $base_dir/../../gcc/ch/runtime/chillrt0.o "$base_dir/../../gcc/ch/runtime/chillrt0.o" ""]
39 verbose "using CHILL_RT0 = $CHILL_RT0" 2
41 if ![info exists GDB] {
42 if ![is_remote host] {
43 set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
48 verbose "using GDB = $GDB" 2
51 if ![info exists GDBFLAGS] {
54 verbose "using GDBFLAGS = $GDBFLAGS" 2
56 # The variable prompt is a regexp which matches the gdb prompt. Set it if it
59 if ![info exists prompt] then {
60 set prompt "\[(\]gdb\[)\]"
63 if ![info exists noargs] then {
67 if ![info exists nosignals] then {
71 if ![info exists noinferiorio] then {
75 if ![info exists noresults] then {
80 # gdb_version -- extract and print the version number of GDB
82 proc default_gdb_version {} {
86 set fileid [open "gdb_cmd" w];
89 set cmdfile [remote_download host "gdb_cmd"];
90 set output [remote_exec host "$GDB -nw --command $cmdfile"]
91 remote_file build delete "gdb_cmd";
92 remote_file host delete "$cmdfile";
93 set tmp [lindex $output 1];
95 regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
96 if ![is_remote host] {
97 clone_output "[which $GDB] version $version $GDBFLAGS\n"
99 clone_output "$GDB on remote host version $version $GDBFLAGS\n"
103 proc gdb_version { } {
104 return [default_gdb_version];
108 # gdb_unload -- unload a file if one is loaded
117 -re "No exec file now.*\r" { exp_continue }
118 -re "No symbol file now.*\r" { exp_continue }
119 -re "A program is being debugged already..*Kill it.*y or n. $"\
121 verbose "\t\tKilling previous program being debugged"
124 -re "Discard symbol table from .*y or n. $" {
130 perror "couldn't unload file in $GDB (timed out)."
136 # Many of the tests depend on setting breakpoints at various places and
137 # running until that breakpoint is reached. At times, we want to start
138 # with a clean-slate with respect to breakpoints, so this utility proc
139 # lets us do this without duplicating this code everywhere.
142 proc delete_breakpoints {} {
146 send_gdb "delete breakpoints\n"
148 -i $gdb_spawn_id -re ".*Delete all breakpoints.*y or n.*$" {
152 -i $gdb_spawn_id -re ".*$prompt $" { # This happens if there were no breakpoints
154 -i $gdb_spawn_id timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
156 send_gdb "info breakpoints\n"
158 -i $gdb_spawn_id -re "No breakpoints or watchpoints..*$prompt $" {}
159 -i $gdb_spawn_id -re ".*$prompt $" { perror "breakpoints not deleted" ; return }
160 -i $gdb_spawn_id -re "Delete all breakpoints.*or n.*$" {
164 -i $gdb_spawn_id timeout { perror "info breakpoints (timeout)" ; return }
170 # Generic run command.
172 # The second pattern below matches up to the first newline *only*.
173 # Using ``.*$'' could swallow up output that we attempt to match
176 proc gdb_run_cmd {args} {
180 set spawn_id $gdb_spawn_id
182 if [target_info exists use_gdb_stub] {
183 send_gdb "jump *start\n"
185 -re "Line.* Jump anyway.*y or n. $" {
188 -re "Continuing.*$prompt $" {}
189 timeout { perror "Jump to start() failed (timeout)"; return }
192 -re "No symbol.*context.*$prompt $" {}
193 -re "The program is not being run.*$prompt $" {
196 timeout { perror "Jump to start() failed (timeout)"; return }
198 send_gdb "continue\n"
201 send_gdb "run $args\n"
202 # This doesn't work quite right yet.
204 -re "The program .* has been started already.*y or n. $" {
208 -re "Starting program: \[^\n\]*" {}
212 proc gdb_breakpoint { function } {
217 set spawn_id $gdb_spawn_id
219 send_gdb "break $function\n"
220 # The first two regexps are what we get with -g, the third is without -g.
222 -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$prompt $" {}
223 -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$prompt $" {}
224 -re "Breakpoint \[0-9\]* at .*$prompt $" {}
225 -re "$prompt $" { fail "setting breakpoint at $function" ; return 0 }
226 timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
231 # Set breakpoint at function and run gdb until it breaks there.
232 # Since this is the only breakpoint that will be set, if it stops
233 # at a breakpoint, we will assume it is the one we want. We can't
234 # just compare to "function" because it might be a fully qualified,
235 # single quoted C++ function specifier.
237 proc runto { function } {
242 set spawn_id $gdb_spawn_id
246 if ![gdb_breakpoint $function] {
252 # the "at foo.c:36" output we get with -g.
253 # the "in func" output we get without -g.
255 -re "Break.* at .*:$decimal.*$prompt $" {
258 -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in $function.*$prompt $" {
262 fail "running to $function in runto"
266 fail "running to $function in runto (timeout)"
273 # runto_main -- ask gdb to run until we hit a breakpoint at main.
274 # The case where the target uses stubs has to be handled
275 # specially--if it uses stubs, assuming we hit
276 # breakpoint() and just step out of the function.
282 if ![target_info exists gdb_stub] {
289 # if use stubs step out of the breakpoint() function.
291 -re "main.* at .*$prompt $" {}
292 -re "_start.*$prompt $" {}
293 timeout { fail "single step at breakpoint() (timeout)" ; return 0 }
299 # gdb_test -- send_gdb a command to gdb and test the result.
300 # Takes three parameters.
302 # First one is the command to execute. If this is the null string
303 # then no command is sent.
304 # Second one is the pattern to match for a PASS, and must NOT include
305 # the \r\n sequence immediately before the gdb prompt.
306 # Third one is an optional message to be printed. If this
307 # a null string "", then the pass/fail messages use the command
308 # string as the message.
310 # 1 if the test failed,
311 # 0 if the test passes,
312 # -1 if there was an internal error.
314 proc gdb_test { args } {
319 upvar timeout timeout
321 if [llength $args]>2 then {
322 set message [lindex $args 2]
324 set message [lindex $args 0]
326 set command [lindex $args 0]
327 set pattern [lindex $args 1]
329 if [llength $args]==5 {
330 set question_string [lindex $args 3];
331 set response_string [lindex $args 4];
333 set question_string "^FOOBAR$"
337 send_user "Sending \"$command\" to gdb\n"
338 send_user "Looking to match \"$pattern\"\n"
339 send_user "Message is \"$message\"\n"
343 if ![string match $command ""] {
344 send_gdb "$command\n"
348 -re ".*Ending remote debugging.*$prompt$" {
349 if ![isnative] then {
350 warning "Can`t communicate to remote target."
356 -re "\[\r\n\]*$pattern\[\r\n\]+$prompt $" {
357 if ![string match "" $message] then {
362 -re "${question_string}$" {
363 send_gdb "$response_string\n";
366 -re "Undefined command:.*$prompt" {
367 perror "Undefined command \"$command\"."
370 -re "Ambiguous command.*$prompt $" {
371 perror "\"$command\" is not a unique command name."
374 -re ".*Program exited with code \[0-9\]+.*$prompt $" {
375 if ![string match "" $message] then {
376 set errmsg "$message: the program exited"
378 set errmsg "$command: the program exited"
383 -re "The program is not being run.*$prompt $" {
384 if ![string match "" $message] then {
385 set errmsg "$message: the program is no longer running"
387 set errmsg "$command: the program is no longer running"
393 if ![string match "" $message] then {
400 perror "Window too small."
402 -re "\\(y or n\\) " {
404 perror "Got interactive prompt."
407 perror "Process no longer exists"
411 perror "internal buffer is full."
414 if ![string match "" $message] then {
415 fail "(timeout) $message"
423 # Test that a command gives an error. For pass or fail, return
424 # a 1 to indicate that more tests can proceed. However a timeout
425 # is a serious error, generates a special fail message, and causes
426 # a 0 to be returned to indicate that more tests are likely to fail
429 proc test_print_reject { args } {
433 if [llength $args]==2 then {
434 set expectthis [lindex $args 1]
436 set expectthis "should never match this bogus string"
438 set sendthis [lindex $args 0]
440 send_user "Sending \"$sendthis\" to gdb\n"
441 send_user "Looking to match \"$expectthis\"\n"
443 send_gdb "$sendthis\n"
445 -re ".*A .* in expression.*\\.*$prompt $" {
446 pass "reject $sendthis"
449 -re ".*Invalid syntax in expression.*$prompt $" {
450 pass "reject $sendthis"
453 -re ".*Junk after end of expression.*$prompt $" {
454 pass "reject $sendthis"
457 -re ".*Invalid number.*$prompt $" {
458 pass "reject $sendthis"
461 -re ".*Invalid character constant.*$prompt $" {
462 pass "reject $sendthis"
465 -re ".*No symbol table is loaded.*$prompt $" {
466 pass "reject $sendthis"
469 -re ".*No symbol .* in current context.*$prompt $" {
470 pass "reject $sendthis"
473 -re ".*$expectthis.*$prompt $" {
474 pass "reject $sendthis"
478 fail "reject $sendthis"
482 fail "reject $sendthis (eof or timeout)"
488 # Given an input string, adds backslashes as needed to create a
489 # regexp that will match the string.
491 proc string_to_regexp {str} {
493 regsub -all {[]*+.|()^$\[]} $str {\\&} result
497 # Same as gdb_test, but the second parameter is not a regexp,
498 # but a string that must match exactly.
500 proc gdb_test_exact { args } {
501 upvar timeout timeout
503 set command [lindex $args 0]
505 # This applies a special meaning to a null string pattern. Without
506 # this, "$pattern\r\n$prompt $" will match anything, including error
507 # messages from commands that should have no output except a new
508 # prompt. With this, only results of a null string will match a null
511 set pattern [lindex $args 1]
512 if [string match $pattern ""] {
513 set pattern [string_to_regexp [lindex $args 0]]
515 set pattern [string_to_regexp [lindex $args 1]]
518 # It is most natural to write the pattern argument with only
519 # embedded \n's, especially if you are trying to avoid Tcl quoting
520 # problems. But expect really wants to see \r\n in patterns. So
521 # transform the pattern here. First transform \r\n back to \n, in
522 # case some users of gdb_test_exact already do the right thing.
523 regsub -all "\r\n" $pattern "\n" pattern
524 regsub -all "\n" $pattern "\r\n" pattern
525 if [llength $args]==3 then {
526 set message [lindex $args 2]
531 return [gdb_test $command $pattern $message]
534 proc gdb_reinitialize_dir { subdir } {
537 set spawn_id $gdb_spawn_id
539 if [is_remote host] {
544 -re "Reinitialize source path to empty.*y or n. " {
547 -re "Source directories searched.*$prompt $" {
548 send_gdb "dir $subdir\n"
550 -re "Source directories searched.*$prompt $" {
551 verbose "Dir set to $subdir"
554 perror "Dir \"$subdir\" failed."
559 perror "Dir \"$subdir\" failed."
564 perror "Dir \"$subdir\" failed."
570 # gdb_exit -- exit the GDB, killing the target program if necessary
572 proc default_gdb_exit {} {
578 if ![info exists gdb_spawn_id] {
582 verbose "Quitting $GDB $GDBFLAGS"
584 # This used to be 1 for unix-gdb.exp
586 verbose "Timeout is now $timeout seconds" 2
588 if [is_remote host] {
591 -i $gdb_spawn_id -re ".*and kill it.*y or n. " {
595 -i $gdb_spawn_id timeout { }
598 # We used to try to send_gdb "quit" to GDB, and wait for it to die.
599 # Dealing with all the cases and errors got pretty hairy. Just close it,
601 catch "close -i $gdb_spawn_id"
603 # Omitting this probably would cause strange timing-dependent failures.
604 catch "wait -i $gdb_spawn_id"
612 # load a file into the debugger.
613 # return a -1 if anything goes wrong.
615 proc gdb_file_cmd { arg } {
621 upvar timeout timeout
623 set spawn_id $gdb_spawn_id
625 if [is_remote host] {
626 set arg [remote_download host $arg];
628 error "download failed"
633 send_gdb "file $arg\n"
635 -re "Reading symbols from.*done.*$prompt $" {
636 verbose "\t\tLoaded $arg into the $GDB"
639 -re "has no symbol-table.*$prompt $" {
640 perror "$arg wasn't compiled with \"-g\""
643 -re "A program is being debugged already.*Kill it.*y or n. $" {
645 verbose "\t\tKilling previous program being debugged"
648 -re "Load new symbol table from \".*\".*y or n. $" {
651 -re "Reading symbols from.*done.*$prompt $" {
652 verbose "\t\tLoaded $arg with new symbol table into $GDB"
656 perror "(timeout) Couldn't load $arg, other program already l
662 -re ".*No such file or directory.*$prompt $" {
663 perror "($arg) No such file or directory\n"
667 perror "couldn't load $arg into $GDB."
671 perror "couldn't load $arg into $GDB (timed out)."
675 # This is an attempt to detect a core dump, but seems not to
676 # work. Perhaps we need to match .* followed by eof, in which
677 # expect does not seem to have a way to do that.
678 perror "couldn't load $arg into $GDB (end of file)."
685 # start gdb -- start gdb running, default procedure
687 # When running over NFS, particularly if running many simultaneous
688 # tests on different hosts all using the same server, things can
689 # get really slow. Give gdb at least 3 minutes to start up.
691 proc default_gdb_start { } {
699 verbose "Spawning $GDB -nw $GDBFLAGS"
701 if [info exists gdb_spawn_id] {
705 set oldtimeout $timeout
706 set timeout [expr "$timeout + 180"]
707 if [is_remote host] {
708 set shell_id [remote_spawn host "$GDB -nw $GDBFLAGS --command gdbinit"]
710 if { [which $GDB] == 0 } then {
711 perror "$GDB does not exist."
715 set shell_id [remote_spawn host "$GDB -nw $GDBFLAGS"]
720 -i $shell_id -re ".*\[\r\n\]$prompt $" {
721 verbose "GDB initialized."
723 -i $shell_id -re "$prompt $" {
724 perror "GDB never initialized."
725 set timeout $oldtimeout
726 verbose "Timeout restored to $timeout seconds" 2
729 -i $shell_id timeout {
730 perror "(timeout) GDB never initialized after $timeout seconds."
731 set timeout $oldtimeout
732 verbose "Timeout restored to $timeout seconds" 2
736 set timeout $oldtimeout
737 verbose "Timeout restored to $timeout seconds" 2
738 set gdb_spawn_id $shell_id
739 set spawn_id $gdb_spawn_id
740 # force the height to "unlimited", so no pagers get used
741 send_gdb "set height 0\n"
743 -i $shell_id -re ".*$prompt $" {
744 verbose "Setting height to 0." 2
746 -i $shell_id timeout {
747 warning "Couldn't set the height to 0"
750 # force the width to "unlimited", so no wraparound occurs
751 send_gdb "set width 0\n"
753 -i $shell_id -re ".*$prompt $" {
754 verbose "Setting width to 0." 2
756 -i $shell_id timeout {
757 warning "Couldn't set the width to 0."
764 # FIXME: this is a copy of the new library procedure, but it's here too
765 # till the new dejagnu gets installed everywhere. I'd hate to break the
769 if ![info exists argv0] then {
770 proc exp_continue { } {
775 # * For crosses, the CHILL runtime doesn't build because it can't find
776 # setjmp.h, stdio.h, etc.
777 # * For AIX (as of 16 Mar 95), (a) there is no language code for
778 # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
779 # does not get along with AIX's too-clever linker.
780 # * On Irix5, there is a bug whereby set of bool, etc., don't get
781 # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
782 # work with stub types.
783 # Lots of things seem to fail on the PA, and since it's not a supported
784 # chill target at the moment, don't run the chill tests.
786 proc skip_chill_tests {} {
787 if ![info exists do_chill_tests] {
790 eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
791 verbose "Skip chill tests is $skip_chill"
795 proc get_compiler_info {binfile} {
796 # Create and source the file that provides information about the compiler
797 # used to compile the test case.
800 # These two come from compiler.c.
801 global signed_keyword_not_used
804 if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
805 perror "Couldn't make ${binfile}.ci file"
812 proc gdb_compile {source dest type options} {
813 if [target_info exists gdb_stub] {
814 set options2 { "additional_flags=-Dusestubs" }
815 lappend options "libs=[target_info gdb_stub]";
816 set options [concat $options2 $options]
818 verbose "options are $options"
819 verbose "source is $source $dest $type $options"
820 set result [target_compile $source $dest $type $options];
821 regsub "\[\r\n\]*$" "$result" "" result;
822 regsub "^\[\r\n\]*" "$result" "" result;
823 if { $result != "" } {
824 clone_output "gdb compile failed, $result"
829 proc send_gdb { string } {
830 return [remote_send host "$string"];
838 catch default_gdb_exit
842 # gdb_load -- load a file into the debugger.
843 # return a -1 if anything goes wrong.
845 proc gdb_load { arg } {
846 return [gdb_file_cmd $arg]
849 proc gdb_continue { function } {
852 return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
855 proc gdb_finish { } {