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.
36 if ![info exists CC] {
37 set CC [findfile $base_dir/../../gcc/xgcc "$base_dir/../../gcc/xgcc -B$base_dir/../../gcc/" [transform gcc]]
39 verbose "using CC = $CC" 2
40 if ![info exists CXX] {
41 set CXX [findfile $base_dir/../../gcc/xgcc "$base_dir/../../gcc/xgcc -B$base_dir/../../gcc/" [transform g++]]
43 verbose "using CXX = $CXX" 2
44 if ![info exists CHILL_LIB] {
45 set CHILL_LIB [findfile $base_dir/../../gcc/ch/runtime/libchill.a "$base_dir/../../gcc/ch/runtime/libchill.a" [transform -lchill]]
47 verbose "using CHILL_LIB = $CHILL_LIB" 2
48 if ![info exists CHILL_RT0] {
49 set CHILL_RT0 [findfile $base_dir/../../gcc/ch/runtime/chillrt0.o "$base_dir/../../gcc/ch/runtime/chillrt0.o" ""]
51 verbose "using CHILL_RT0 = $CHILL_RT0" 2
53 if ![info exists LDFLAGS] {
55 append LDFLAGS " [libgloss_flags] [newlib_flags]"
59 verbose "using LDFLAGS = $LDFLAGS" 2
61 if ![info exists GDB] then {
62 set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
64 verbose "using GDB = $GDB" 2
67 if ![info exists GDBFLAGS] then {
70 verbose "using GDBFLAGS = $GDBFLAGS" 2
72 # The variable prompt is a regexp which matches the gdb prompt. Set it if it
75 if ![info exists prompt] then {
76 set prompt "\\(gdb\\)"
80 if [istarget "sparclite-*-*"] then {
86 if ![info exists noargs] then {
90 if ![info exists nosignals] then {
94 if ![info exists noinferiorio] then {
98 if ![info exists noresults] then {
103 # gdb_version -- extract and print the version number of GDB
105 proc default_gdb_version {} {
108 if {[which $GDB] != 0} then {
109 set tmp [exec echo "q" | $GDB -nw $GDBFLAGS]
110 regexp " \[0-9\]\[^ \t\n\]+" $tmp version
111 clone_output "[which $GDB] version$version -nw $GDBFLAGS \n"
113 warning "$GDB does not exist"
118 # gdb_unload -- unload a file if one is loaded
127 -re "No exec file now.*\r" { exp_continue }
128 -re "No symbol file now.*\r" { exp_continue }
129 -re "A program is being debugged already..*Kill it.*y or n. $"\
131 verbose "\t\tKilling previous program being debugged"
134 -re "Discard symbol table from .*y or n. $" {
140 perror "couldn't unload file in $GDB (timed out)."
146 # Many of the tests depend on setting breakpoints at various places and
147 # running until that breakpoint is reached. At times, we want to start
148 # with a clean-slate with respect to breakpoints, so this utility proc
149 # lets us do this without duplicating this code everywhere.
152 proc delete_breakpoints {} {
155 send "delete breakpoints\n"
157 -re "Delete all breakpoints.*y or n. $" {
161 -re "y\r\n$prompt $" {}
162 -re ".*$prompt $" { # This happens if there were no breakpoints
164 timeout { perror "Delete all breakpoints (timeout)" ; return }
166 send "info breakpoints\n"
168 -re "No breakpoints or watchpoints..*$prompt $" {}
169 -re ".*$prompt $" { perror "breakpoints not deleted" ; return }
170 timeout { perror "info breakpoints (timeout)" ; return }
176 # Generic run command.
178 # The second pattern below matches up to the first newline *only*.
179 # Using ``.*$'' could swallow up output that we attempt to match
182 proc gdb_run_cmd {} {
189 -re "Line.* Jump anyway.*y or n. $" {
192 -re "Continuing.*$prompt $" {}
193 timeout { perror "Jump to start() failed (timeout)"; return }
196 timeout { perror "Jump to start() failed (timeout)"; return }
203 -re "The program .* has been started already.*y or n. $" {
207 -re "Starting program: \[^\n\]*" {}
212 # Set breakpoint at function and run gdb until it breaks there.
213 # Since this is the only breakpoint that will be set, if it stops
214 # at a breakpoint, we will assume it is the one we want. We can't
215 # just compare to "function" because it might be a fully qualified,
216 # single quoted C++ function specifier.
218 proc runto { function } {
224 -re "delete.*Delete all breakpoints.*y or n. $" {
228 timeout { fail "deleting breakpoints (timeout)" ; return 0 }
232 timeout { fail "deleting breakpoints (timeout)" ; return 0 }
235 send "break $function\n"
236 # The first two regexps are what we get with -g, the third is without -g.
238 -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$prompt $" {}
239 -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$prompt $" {}
240 -re "Breakpoint \[0-9\]* at .*$prompt $" {}
241 -re "$prompt $" { fail "setting breakpoint at $function" ; return 0 }
242 timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
247 # the "at foo.c:36" output we get with -g.
248 # the "in func" output we get without -g.
250 -re "Break.* at .*:$decimal.*$prompt $" {
253 -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in $function.*$prompt $" {
257 fail "running to $function"
261 fail "running to $function (timeout)"
268 # runto_main -- ask gdb to run and untill hit break point at main.
269 # if it uses stubs, assuming we hit breakpoint() and just
270 # step out of the function.
283 -re "delete.*Delete all breakpoints.*y or n. $" {
287 timeout { fail "deleting breakpoints (timeout)" ; return 0 }
291 timeout { fail "deleting breakpoints (timeout)" ; return 0 }
295 # if use stubs step out of the breakpoint() function.
297 -re "main.* at .*$prompt $" {}
298 timeout { fail "single step at breakpoint() (timeout)" ; return 0 }
304 # gdb_test -- send a command to gdb and test the result.
305 # Takes three parameters.
307 # First one is the command to execute,
308 # Second one is the pattern to match for a PASS, and must NOT include
309 # the \r\n sequence immediately before the gdb prompt.
310 # Third one is an optional message to be printed. If this
311 # a null string "", then the pass/fail messages are not printed.
313 # 1 if the test failed,
314 # 0 if the test passes,
315 # -1 if there was an internal error.
317 proc gdb_test { args } {
323 upvar timeout timeout
325 if [llength $args]==3 then {
326 set message [lindex $args 2]
328 set message [lindex $args 0]
330 set command [lindex $args 0]
331 set pattern [lindex $args 1]
334 send_user "Sending \"$command\" to gdb\n"
335 send_user "Looking to match \"$pattern\"\n"
336 send_user "Message is \"$message\"\n"
340 if ![string match $command ""] {
345 -re ".*Ending remote debugging.*$prompt$" {
346 if ![isnative] then {
347 warning "Can`t communicate to remote target."
353 -re "$pattern\r\n$prompt $" {
354 if ![string match "" $message] then {
359 -re "Undefined command:.*$prompt" {
360 perror "Undefined command \"$command\"."
363 -re "Ambiguous command.*$prompt $" {
364 perror "\"$command\" is not a unique command name."
367 -re "(.*)(Program exited with code \[0-9\]+)(.*$prompt $)" {
368 if ![string match "" $message] then {
369 set errmsg "$message: $expect_out(2,string)"
371 set errmsg "$command: $expect_out(2,string)"
376 -re "The program is not being run.*$prompt $" {
377 if ![string match "" $message] then {
378 set errmsg "$message: the program is no longer running"
380 set errmsg "$command: the program is no longer running"
386 if ![string match "" $message] then {
393 perror "Window too small."
395 -re "\\(y or n\\) " {
397 perror "Got interactive prompt."
400 perror "Process no longer exists"
404 perror "internal buffer is full."
407 if ![string match "" $message] then {
408 fail "(timeout) $message"
416 # Test that a command gives an error. For pass or fail, return
417 # a 1 to indicate that more tests can proceed. However a timeout
418 # is a serious error, generates a special fail message, and causes
419 # a 0 to be returned to indicate that more tests are likely to fail
422 proc test_print_reject { args } {
426 if [llength $args]==2 then {
427 set expectthis [lindex $args 1]
429 set expectthis "should never match this bogus string"
431 set sendthis [lindex $args 0]
433 send_user "Sending \"$sendthis\" to gdb\n"
434 send_user "Looking to match \"$expectthis\"\n"
438 -re ".*A .* in expression.*\\.*$prompt $" {
439 pass "reject $sendthis"
442 -re ".*Invalid syntax in expression.*$prompt $" {
443 pass "reject $sendthis"
446 -re ".*Junk after end of expression.*$prompt $" {
447 pass "reject $sendthis"
450 -re ".*Invalid number.*$prompt $" {
451 pass "reject $sendthis"
454 -re ".*Invalid character constant.*$prompt $" {
455 pass "reject $sendthis"
458 -re ".*No symbol table is loaded.*$prompt $" {
459 pass "reject $sendthis"
462 -re ".*No symbol .* in current context.*$prompt $" {
463 pass "reject $sendthis"
466 -re ".*$expectthis.*$prompt $" {
467 pass "reject $sendthis"
471 fail "reject $sendthis"
475 fail "reject $sendthis (eof or timeout)"
481 # Given an input string, adds backslashes as needed to create a
482 # regexp that will match the string.
484 proc string_to_regexp {str} {
486 regsub -all {[]*+.|()^$\[]} $str {\\&} result
490 # Same as gdb_test, but the second parameter is not a regexp,
491 # but a string that must match exactly.
493 proc gdb_test_exact { args } {
494 upvar timeout timeout
496 set command [lindex $args 0]
497 set pattern [string_to_regexp [lindex $args 1]]
498 # It is most natural to write the pattern argument with only
499 # embedded \n's, especially if you are trying to avoid Tcl quoting
500 # problems. But expect really wants to see \r\n in patterns. So
501 # transform the pattern here. First transform \r\n back to \n, in
502 # case some users of gdb_test_exact already do the right thing.
503 regsub -all "\r\n" $pattern "\n" pattern
504 regsub -all "\n" $pattern "\r\n" pattern
505 if [llength $args]==3 then {
506 set message [lindex $args 2]
510 return [gdb_test $command $pattern $message]
513 proc gdb_reinitialize_dir { subdir } {
518 -re "Reinitialize source path to empty.*y or n. " {
521 -re "Source directories searched.*$prompt $" {
524 -re "Source directories searched.*$prompt $" {
525 verbose "Dir set to $subdir"
528 perror "Dir \"$subdir\" failed."
533 perror "Dir \"$subdir\" failed."
538 perror "Dir \"$subdir\" failed."
544 # gdb_exit -- exit the GDB, killing the target program if necessary
546 proc default_gdb_exit {} {
551 verbose "Quitting $GDB $GDBFLAGS"
553 # This used to be 1 for unix-gdb.exp
555 verbose "Timeout is now $timeout seconds" 2
557 # We used to try to send "quit" to GDB, and wait for it to die.
558 # Dealing with all the cases and errors got pretty hairy. Just close it,
562 # Omitting this probably would cause strange timing-dependent failures.
567 # load a file into the debugger.
568 # return a -1 if anything goes wrong.
570 proc gdb_file_cmd { arg } {
577 upvar timeout timeout
581 -re "Reading symbols from.*done.*$prompt $" {
582 verbose "\t\tLoaded $arg into the $GDB"
585 -re "has no symbol-table.*$prompt $" {
586 perror "$arg wasn't compiled with \"-g\""
589 -re "A program is being debugged already.*Kill it.*y or n. $" {
591 verbose "\t\tKilling previous program being debugged"
594 -re "Load new symbol table from \".*\".*y or n. $" {
597 -re "Reading symbols from.*done.*$prompt $" {
598 verbose "\t\tLoaded $arg with new symbol table into $GDB"
602 perror "(timeout) Couldn't load $arg, other program already l
608 -re ".*No such file or directory.*$prompt $" {
609 perror "($arg) No such file or directory\n"
613 perror "couldn't load $arg into $GDB."
617 perror "couldn't load $arg into $GDB (timed out)."
621 # This is an attempt to detect a core dump, but seems not to
622 # work. Perhaps we need to match .* followed by eof, in which
623 # expect does not seem to have a way to do that.
624 perror "couldn't load $arg into $GDB (end of file)."
631 # start gdb -- start gdb running, default procedure
633 # When running over NFS, particularly if running many simultaneous
634 # tests on different hosts all using the same server, things can
635 # get really slow. Give gdb at least 3 minutes to start up.
637 proc default_gdb_start { } {
644 verbose "Spawning $GDB -nw $GDBFLAGS"
646 if { [which $GDB] == 0 } then {
647 perror "$GDB does not exist."
651 set oldtimeout $timeout
652 set timeout [expr "$timeout + 180"]
653 verbose "Timeout increased to $timeout seconds" 2
654 eval "spawn $GDB -nw $GDBFLAGS"
656 -re ".*\r\n$prompt $" {
657 verbose "GDB initialized."
660 perror "GDB never initialized."
661 set timeout $oldtimeout
662 verbose "Timeout restored to $timeout seconds" 2
666 perror "(timeout) GDB never initialized after $timeout seconds."
667 set timeout $oldtimeout
668 verbose "Timeout restored to $timeout seconds" 2
672 set timeout $oldtimeout
673 verbose "Timeout restored to $timeout seconds" 2
674 # force the height to "unlimited", so no pagers get used
675 send "set height 0\n"
678 verbose "Setting height to 0." 2
681 warning "Couldn't set the height to 0."
684 # force the width to "unlimited", so no wraparound occurs
688 verbose "Setting width to 0." 2
691 warning "Couldn't set the width to 0."
697 # FIXME: this is a copy of the new library procedure, but it's here too
698 # till the new dejagnu gets installed everywhere. I'd hate to break the
702 if ![info exists argv0] then {
703 proc exp_continue { } {
708 # * For crosses, the CHILL runtime doesn't build because it can't find
709 # setjmp.h, stdio.h, etc.
710 # * For AIX (as of 16 Mar 95), (a) there is no language code for
711 # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
712 # does not get along with AIX's too-clever linker.
713 # * On Irix5, there is a bug whereby set of bool, etc., don't get
714 # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
715 # work with stub types.
716 # Lots of things seem to fail on the PA, and since it's not a supported
717 # chill target at the moment, don't run the chill tests.
719 proc skip_chill_tests {} {
720 eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
721 verbose "Skip chill tests is $skip_chill"