gdb/testsuite/lib/gdb.exp

   1 # Copyright (C) 1992, 1994, 1995 Free Software Foundation, Inc.
   2
   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.
   7 #
   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.
  12 #
  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.  */
  16
  17 # Please email any bugs, comments, and/or additions to this file to:
  18 # bug-gdb@prep.ai.mit.edu
  19
  20 # This file was written by Fred Fish. (fnf@cygnus.com)
  21
  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.
  25
  26 load_lib libgloss.exp
  27
  28 global GDB
  29 global CHILL_LIB
  30 global CHILL_RT0
  31
  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]]
  34 }
  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" ""]
  38 }
  39 verbose "using CHILL_RT0 = $CHILL_RT0" 2
  40
  41 if ![info exists GDB] {
  42     if ![is_remote host] {
  43         set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
  44     } else {
  45         set GDB gdb
  46     }
  47 }
  48 verbose "using GDB = $GDB" 2
  49
  50 global GDBFLAGS
  51 if ![info exists GDBFLAGS] {
  52     set GDBFLAGS "-nx"
  53 }
  54 verbose "using GDBFLAGS = $GDBFLAGS" 2
  55
  56 # The variable prompt is a regexp which matches the gdb prompt.  Set it if it
  57 # is not already set.
  58 global gdb_prompt
  59 if ![info exists prompt] then {
  60     set gdb_prompt "\[(\]gdb\[)\]"
  61 }
  62
  63 #
  64 # gdb_version -- extract and print the version number of GDB
  65 #
  66 proc default_gdb_version {} {
  67     global GDB
  68     global GDBFLAGS
  69     global gdb_prompt
  70     set fileid [open "gdb_cmd" w];
  71     puts $fileid "q";
  72     close $fileid;
  73     set cmdfile [remote_download host "gdb_cmd"];
  74     set output [remote_exec host "$GDB -nw --command $cmdfile"]
  75     remote_file build delete "gdb_cmd";
  76     remote_file host delete "$cmdfile";
  77     set tmp [lindex $output 1];
  78     set version ""
  79     regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
  80     if ![is_remote host] {
  81         clone_output "[which $GDB] version $version $GDBFLAGS\n"
  82     } else {
  83         clone_output "$GDB on remote host version $version $GDBFLAGS\n"
  84     }
  85 }
  86
  87 proc gdb_version { } {
  88     return [default_gdb_version];
  89 }
  90
  91 #
  92 # gdb_unload -- unload a file if one is loaded
  93 #
  94
  95 proc gdb_unload {} {
  96     global verbose
  97     global GDB
  98     global gdb_prompt
  99     send_gdb "file\n"
 100     expect {
 101         -re "No exec file now.*\r" { exp_continue }
 102         -re "No symbol file now.*\r" { exp_continue }
 103         -re "A program is being debugged already..*Kill it.*y or n. $"\
 104             { send_gdb "y\n"
 105                 verbose "\t\tKilling previous program being debugged"
 106             exp_continue
 107         }
 108         -re "Discard symbol table from .*y or n. $" {
 109             send_gdb "y\n"
 110             exp_continue
 111         }
 112         -re "$gdb_prompt $" {}
 113         timeout {
 114             perror "couldn't unload file in $GDB (timed out)."
 115             return -1
 116         }
 117     }
 118 }
 119
 120 # Many of the tests depend on setting breakpoints at various places and
 121 # running until that breakpoint is reached.  At times, we want to start
 122 # with a clean-slate with respect to breakpoints, so this utility proc
 123 # lets us do this without duplicating this code everywhere.
 124 #
 125
 126 proc delete_breakpoints {} {
 127     global gdb_prompt
 128     global gdb_spawn_id
 129
 130     send_gdb "delete breakpoints\n"
 131     expect {
 132         -i $gdb_spawn_id -re ".*Delete all breakpoints.*y or n.*$" {
 133             send_gdb "y\n";
 134             exp_continue
 135         }
 136         -i $gdb_spawn_id -re ".*$gdb_prompt $" { # This happens if there were no breakpoints
 137             }
 138         -i $gdb_spawn_id timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
 139     }
 140     send_gdb "info breakpoints\n"
 141     expect {
 142         -i $gdb_spawn_id -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
 143         -i $gdb_spawn_id -re ".*$gdb_prompt $" { perror "breakpoints not deleted" ; return }
 144         -i $gdb_spawn_id -re "Delete all breakpoints.*or n.*$" {
 145             send_gdb "y\n";
 146             exp_continue
 147         }
 148         -i $gdb_spawn_id timeout { perror "info breakpoints (timeout)" ; return }
 149     }
 150 }
 151
 152
 153 #
 154 # Generic run command.
 155 #
 156 # The second pattern below matches up to the first newline *only*.
 157 # Using ``.*$'' could swallow up output that we attempt to match
 158 # elsewhere.
 159 #
 160 proc gdb_run_cmd {args} {
 161     global gdb_prompt
 162     global gdb_spawn_id
 163
 164     set spawn_id $gdb_spawn_id
 165
 166     if [target_info exists use_gdb_stub] {
 167         send_gdb  "jump *start\n"
 168         expect {
 169             -re "Continuing at \[^\r\n\]*\[\r\n\]" {
 170                 if ![target_info exists gdb_stub] {
 171                     return;
 172                 }
 173             }
 174             -re "Line.* Jump anyway.*y or n. $" {
 175                 send_gdb "y\n"
 176                 exp_continue;
 177             }
 178             -re "No symbol.*context.*$gdb_prompt $" {}
 179             -re "The program is not being run.*$gdb_prompt $" {
 180                 gdb_load "";
 181             }
 182             timeout { perror "Jump to start() failed (timeout)"; return }
 183         }
 184         if [target_info exists gdb_stub] {
 185             expect {
 186                 -re ".*$gdb_prompt $" {
 187                     send_gdb "continue\n"
 188                 }
 189             }
 190         }
 191         return
 192     }
 193     send_gdb "run $args\n"
 194 # This doesn't work quite right yet.
 195     expect {
 196         -re "The program .* has been started already.*y or n. $" {
 197             send_gdb "y\n"
 198             exp_continue
 199         }
 200         -re "Starting program: \[^\n\]*" {}
 201     }
 202 }
 203
 204 proc gdb_breakpoint { function } {
 205     global gdb_prompt
 206     global decimal
 207     global gdb_spawn_id
 208
 209     set spawn_id $gdb_spawn_id
 210
 211     send_gdb "break $function\n"
 212     # The first two regexps are what we get with -g, the third is without -g.
 213     expect {
 214         -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 215         -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 216         -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {}
 217         -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 }
 218         timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
 219     }
 220     return 1;
 221 }
 222
 223 # Set breakpoint at function and run gdb until it breaks there.
 224 # Since this is the only breakpoint that will be set, if it stops
 225 # at a breakpoint, we will assume it is the one we want.  We can't
 226 # just compare to "function" because it might be a fully qualified,
 227 # single quoted C++ function specifier.
 228
 229 proc runto { function } {
 230     global gdb_prompt
 231     global decimal
 232     global gdb_spawn_id
 233
 234     set spawn_id $gdb_spawn_id
 235
 236     delete_breakpoints
 237
 238     if ![gdb_breakpoint $function] {
 239         return 0;
 240     }
 241
 242     gdb_run_cmd
 243
 244     # the "at foo.c:36" output we get with -g.
 245     # the "in func" output we get without -g.
 246     expect {
 247         -re "Break.* at .*:$decimal.*$gdb_prompt $" {
 248             return 1
 249         }
 250         -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" {
 251             return 1
 252         }
 253         -re "$gdb_prompt $" {
 254             fail "running to $function in runto"
 255             return 0
 256         }
 257         timeout {
 258             fail "running to $function in runto (timeout)"
 259             return 0
 260         }
 261     }
 262     return 1
 263 }
 264
 265 #
 266 # runto_main -- ask gdb to run until we hit a breakpoint at main.
 267 #               The case where the target uses stubs has to be handled
 268 #               specially--if it uses stubs, assuming we hit
 269 #               breakpoint() and just step out of the function.
 270 #
 271 proc runto_main {} {
 272     global gdb_prompt
 273     global decimal
 274
 275     if ![target_info exists gdb_stub] {
 276         return [runto main]
 277     }
 278
 279     delete_breakpoints
 280
 281     send_gdb "step\n"
 282     # if use stubs step out of the breakpoint() function.
 283     expect {
 284         -re "main.* at .*$gdb_prompt $" {}
 285         -re "_start.*$gdb_prompt $" {}
 286         timeout { fail "single step at breakpoint() (timeout)" ; return 0 }
 287     }
 288     return 1
 289 }
 290
 291 #
 292 # gdb_test -- send_gdb a command to gdb and test the result.
 293 #             Takes three parameters.
 294 #             Parameters:
 295 #                First one is the command to execute.  If this is the null string
 296 #                  then no command is sent.
 297 #                Second one is the pattern to match for a PASS, and must NOT include
 298 #                  the \r\n sequence immediately before the gdb prompt.
 299 #                Third one is an optional message to be printed. If this
 300 #                  a null string "", then the pass/fail messages use the command
 301 #                  string as the message.
 302 #             Returns:
 303 #                1 if the test failed,
 304 #                0 if the test passes,
 305 #               -1 if there was an internal error.
 306 #
 307 proc gdb_test { args } {
 308     global verbose
 309     global gdb_prompt
 310     global GDB
 311     global expect_out
 312     upvar timeout timeout
 313     global gdb_spawn_id;
 314
 315     if [llength $args]>2 then {
 316         set message [lindex $args 2]
 317     } else {
 318         set message [lindex $args 0]
 319     }
 320     set command [lindex $args 0]
 321     set pattern [lindex $args 1]
 322
 323     if [llength $args]==5 {
 324         set question_string [lindex $args 3];
 325         set response_string [lindex $args 4];
 326     } else {
 327         set question_string "^FOOBAR$"
 328     }
 329
 330     if $verbose>2 then {
 331         send_user "Sending \"$command\" to gdb\n"
 332         send_user "Looking to match \"$pattern\"\n"
 333         send_user "Message is \"$message\"\n"
 334     }
 335
 336     set result -1
 337     if ![string match $command ""] {
 338         if { [send_gdb "$command\n"] != "" } {
 339             perror "Couldn't send $command to GDB.";
 340             return $result;
 341         }
 342     }
 343
 344     expect {
 345         -i $gdb_spawn_id -re ".*Ending remote debugging.*$gdb_prompt$" {
 346             if ![isnative] then {
 347                 warning "Can`t communicate to remote target."
 348             }
 349             gdb_exit
 350             gdb_start
 351             set result -1
 352         }
 353         -i $gdb_spawn_id -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
 354             if ![string match "" $message] then {
 355                 pass "$message"
 356             }
 357             set result 0
 358         }
 359         -i $gdb_spawn_id -re "(${question_string})$" {
 360             send_gdb "$response_string\n";
 361             exp_continue;
 362         }
 363         -i $gdb_spawn_id -re "Undefined command:.*$gdb_prompt" {
 364             perror "Undefined command \"$command\"."
 365             set result 1
 366         }
 367         -i $gdb_spawn_id -re "Ambiguous command.*$gdb_prompt $" {
 368             perror "\"$command\" is not a unique command name."
 369             set result 1
 370         }
 371         -i $gdb_spawn_id -re ".*Program exited with code \[0-9\]+.*$gdb_prompt $" {
 372             if ![string match "" $message] then {
 373                 set errmsg "$message: the program exited"
 374             } else {
 375                 set errmsg "$command: the program exited"
 376             }
 377             fail "$errmsg"
 378             return -1
 379         }
 380         -i $gdb_spawn_id -re "The program is not being run.*$gdb_prompt $" {
 381             if ![string match "" $message] then {
 382                 set errmsg "$message: the program is no longer running"
 383             } else {
 384                 set errmsg "$command: the program is no longer running"
 385             }
 386             fail "$errmsg"
 387             return -1
 388         }
 389         -i $gdb_spawn_id -re ".*$gdb_prompt $" {
 390             if ![string match "" $message] then {
 391                 fail "$message"
 392             }
 393             set result 1
 394         }
 395         -i $gdb_spawn_id "<return>" {
 396             send_gdb "\n"
 397             perror "Window too small."
 398         }
 399         -i $gdb_spawn_id -re "\\(y or n\\) " {
 400             send_gdb "n\n"
 401             perror "Got interactive prompt."
 402         }
 403         -i $gdb_spawn_id eof {
 404             perror "Process no longer exists"
 405             return -1
 406         }
 407         -i $gdb_spawn_id full_buffer {
 408             perror "internal buffer is full."
 409         }
 410         timeout {
 411             if ![string match "" $message] then {
 412                 fail "(timeout) $message"
 413             }
 414             set result 1
 415         }
 416     }
 417     return $result
 418 }
 419 \f
 420 # Test that a command gives an error.  For pass or fail, return
 421 # a 1 to indicate that more tests can proceed.  However a timeout
 422 # is a serious error, generates a special fail message, and causes
 423 # a 0 to be returned to indicate that more tests are likely to fail
 424 # as well.
 425
 426 proc test_print_reject { args } {
 427     global gdb_prompt
 428     global verbose
 429
 430     if [llength $args]==2 then {
 431         set expectthis [lindex $args 1]
 432     } else {
 433         set expectthis "should never match this bogus string"
 434     }
 435     set sendthis [lindex $args 0]
 436     if $verbose>2 then {
 437         send_user "Sending \"$sendthis\" to gdb\n"
 438         send_user "Looking to match \"$expectthis\"\n"
 439     }
 440     send_gdb "$sendthis\n"
 441     expect {
 442         -re ".*A .* in expression.*\\.*$gdb_prompt $" {
 443             pass "reject $sendthis"
 444             return 1
 445         }
 446         -re ".*Invalid syntax in expression.*$gdb_prompt $" {
 447             pass "reject $sendthis"
 448             return 1
 449         }
 450         -re ".*Junk after end of expression.*$gdb_prompt $" {
 451             pass "reject $sendthis"
 452             return 1
 453         }
 454         -re ".*Invalid number.*$gdb_prompt $" {
 455             pass "reject $sendthis"
 456             return 1
 457         }
 458         -re ".*Invalid character constant.*$gdb_prompt $" {
 459             pass "reject $sendthis"
 460             return 1
 461         }
 462         -re ".*No symbol table is loaded.*$gdb_prompt $" {
 463             pass "reject $sendthis"
 464             return 1
 465         }
 466         -re ".*No symbol .* in current context.*$gdb_prompt $" {
 467             pass "reject $sendthis"
 468             return 1
 469         }
 470         -re ".*$expectthis.*$gdb_prompt $" {
 471             pass "reject $sendthis"
 472             return 1
 473         }
 474         -re ".*$gdb_prompt $" {
 475             fail "reject $sendthis"
 476             return 1
 477         }
 478         default {
 479             fail "reject $sendthis (eof or timeout)"
 480             return 0
 481         }
 482     }
 483 }
 484 \f
 485 # Given an input string, adds backslashes as needed to create a
 486 # regexp that will match the string.
 487
 488 proc string_to_regexp {str} {
 489     set result $str
 490     regsub -all {[]*+.|()^$\[]} $str {\\&} result
 491     return $result
 492 }
 493
 494 # Same as gdb_test, but the second parameter is not a regexp,
 495 # but a string that must match exactly.
 496
 497 proc gdb_test_exact { args } {
 498     upvar timeout timeout
 499
 500     set command [lindex $args 0]
 501
 502     # This applies a special meaning to a null string pattern.  Without
 503     # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
 504     # messages from commands that should have no output except a new
 505     # prompt.  With this, only results of a null string will match a null
 506     # string pattern.
 507
 508     set pattern [lindex $args 1]
 509     if [string match $pattern ""] {
 510         set pattern [string_to_regexp [lindex $args 0]]
 511     } else {
 512         set pattern [string_to_regexp [lindex $args 1]]
 513     }
 514
 515     # It is most natural to write the pattern argument with only
 516     # embedded \n's, especially if you are trying to avoid Tcl quoting
 517     # problems.  But expect really wants to see \r\n in patterns.  So
 518     # transform the pattern here.  First transform \r\n back to \n, in
 519     # case some users of gdb_test_exact already do the right thing.
 520     regsub -all "\r\n" $pattern "\n" pattern
 521     regsub -all "\n" $pattern "\r\n" pattern
 522     if [llength $args]==3 then {
 523         set message [lindex $args 2]
 524     } else {
 525         set message $command
 526     }
 527
 528     return [gdb_test $command $pattern $message]
 529 }
 530 \f
 531 proc gdb_reinitialize_dir { subdir } {
 532     global gdb_prompt
 533     global gdb_spawn_id
 534     set spawn_id $gdb_spawn_id
 535
 536     if [is_remote host] {
 537         return "";
 538     }
 539     send_gdb "dir\n"
 540     expect {
 541         -re "Reinitialize source path to empty.*y or n. " {
 542             send_gdb "y\n"
 543             expect {
 544                 -re "Source directories searched.*$gdb_prompt $" {
 545                     send_gdb "dir $subdir\n"
 546                     expect {
 547                         -re "Source directories searched.*$gdb_prompt $" {
 548                             verbose "Dir set to $subdir"
 549                         }
 550                         -re ".*$gdb_prompt $" {
 551                             perror "Dir \"$subdir\" failed."
 552                         }
 553                     }
 554                 }
 555                 -re ".*$gdb_prompt $" {
 556                     perror "Dir \"$subdir\" failed."
 557                 }
 558             }
 559         }
 560         -re ".*$gdb_prompt $" {
 561             perror "Dir \"$subdir\" failed."
 562         }
 563     }
 564 }
 565
 566 #
 567 # gdb_exit -- exit the GDB, killing the target program if necessary
 568 #
 569 proc default_gdb_exit {} {
 570     global GDB
 571     global GDBFLAGS
 572     global verbose
 573     global gdb_spawn_id
 574
 575     if ![info exists gdb_spawn_id] {
 576         return;
 577     }
 578
 579     verbose "Quitting $GDB $GDBFLAGS"
 580
 581     # This used to be 1 for unix-gdb.exp
 582     set timeout 5
 583     verbose "Timeout is now $timeout seconds" 2
 584
 585     if [is_remote host] {
 586         send_gdb "quit\n";
 587         expect {
 588             -i $gdb_spawn_id -re ".*and kill it.*y or n. " {
 589                 send_gdb "y\n";
 590                 exp_continue;
 591             }
 592             -i $gdb_spawn_id timeout { }
 593         }
 594     } else {
 595         # We used to try to send_gdb "quit" to GDB, and wait for it to die.
 596         # Dealing with all the cases and errors got pretty hairy.  Just close it,
 597         # that is simpler.
 598         catch "close -i $gdb_spawn_id"
 599
 600         # Omitting this probably would cause strange timing-dependent failures.
 601         catch "wait -i $gdb_spawn_id"
 602     }
 603
 604     remote_close host;
 605     unset gdb_spawn_id
 606 }
 607
 608 #
 609 # load a file into the debugger.
 610 # return a -1 if anything goes wrong.
 611 #
 612 proc gdb_file_cmd { arg } {
 613     global verbose
 614     global loadpath
 615     global loadfile
 616     global GDB
 617     global gdb_prompt
 618     upvar timeout timeout
 619     global gdb_spawn_id
 620     set spawn_id $gdb_spawn_id
 621
 622     if [is_remote host] {
 623         set arg [remote_download host $arg];
 624         if { $arg == "" } {
 625             error "download failed"
 626             return -1;
 627         }
 628     }
 629
 630     send_gdb "file $arg\n"
 631     expect {
 632         -re "Reading symbols from.*done.*$gdb_prompt $" {
 633             verbose "\t\tLoaded $arg into the $GDB"
 634             return 0
 635         }
 636         -re "has no symbol-table.*$gdb_prompt $" {
 637             perror "$arg wasn't compiled with \"-g\""
 638             return -1
 639         }
 640         -re "A program is being debugged already.*Kill it.*y or n. $" {
 641             send_gdb "y\n"
 642                 verbose "\t\tKilling previous program being debugged"
 643             exp_continue
 644         }
 645         -re "Load new symbol table from \".*\".*y or n. $" {
 646             send_gdb "y\n"
 647             expect {
 648                 -re "Reading symbols from.*done.*$gdb_prompt $" {
 649                     verbose "\t\tLoaded $arg with new symbol table into $GDB"
 650                     return 0
 651                 }
 652                 timeout {
 653                     perror "(timeout) Couldn't load $arg, other program already loaded."
 654                     return -1
 655                 }
 656             }
 657         }
 658         -re ".*No such file or directory.*$gdb_prompt $" {
 659             perror "($arg) No such file or directory\n"
 660             return -1
 661         }
 662         -re "$gdb_prompt $" {
 663             perror "couldn't load $arg into $GDB."
 664             return -1
 665             }
 666         timeout {
 667             perror "couldn't load $arg into $GDB (timed out)."
 668             return -1
 669         }
 670         eof {
 671             # This is an attempt to detect a core dump, but seems not to
 672             # work.  Perhaps we need to match .* followed by eof, in which
 673             # expect does not seem to have a way to do that.
 674             perror "couldn't load $arg into $GDB (end of file)."
 675             return -1
 676         }
 677     }
 678 }
 679
 680 #
 681 # start gdb -- start gdb running, default procedure
 682 #
 683 # When running over NFS, particularly if running many simultaneous
 684 # tests on different hosts all using the same server, things can
 685 # get really slow.  Give gdb at least 3 minutes to start up.
 686 #
 687 proc default_gdb_start { } {
 688     global verbose
 689     global GDB
 690     global GDBFLAGS
 691     global gdb_prompt
 692     global timeout
 693     global gdb_spawn_id
 694     global spawn_id
 695     verbose "Spawning $GDB -nw $GDBFLAGS"
 696
 697     if [info exists gdb_spawn_id] {
 698         return 0;
 699     }
 700
 701     set oldtimeout $timeout
 702     set timeout [expr "$timeout + 180"]
 703     if [is_remote host] {
 704         set shell_id [remote_spawn host "$GDB -nw $GDBFLAGS --command gdbinit"]
 705     } else {
 706         if { [which $GDB] == 0 } then {
 707             perror "$GDB does not exist."
 708             exit 1
 709         }
 710
 711         set shell_id [remote_spawn host "$GDB -nw $GDBFLAGS"]
 712     }
 713     verbose $shell_id
 714     set timeout 10
 715     expect {
 716         -i $shell_id -re ".*\[\r\n\]$gdb_prompt $" {
 717             verbose "GDB initialized."
 718         }
 719         -i $shell_id -re "$gdb_prompt $"        {
 720             perror "GDB never initialized."
 721             set timeout $oldtimeout
 722             verbose "Timeout restored to $timeout seconds" 2
 723             return -1
 724         }
 725         -i $shell_id timeout            {
 726             perror "(timeout) GDB never initialized after $timeout seconds."
 727             set timeout $oldtimeout
 728             verbose "Timeout restored to $timeout seconds" 2
 729             return -1
 730         }
 731     }
 732     set timeout $oldtimeout
 733     verbose "Timeout restored to $timeout seconds" 2
 734     set gdb_spawn_id $shell_id
 735     set spawn_id $gdb_spawn_id
 736     # force the height to "unlimited", so no pagers get used
 737     send_gdb "set height 0\n"
 738     expect {
 739         -i $shell_id -re ".*$gdb_prompt $" {
 740             verbose "Setting height to 0." 2
 741         }
 742         -i $shell_id timeout {
 743             warning "Couldn't set the height to 0"
 744         }
 745     }
 746     # force the width to "unlimited", so no wraparound occurs
 747     send_gdb "set width 0\n"
 748     expect {
 749         -i $shell_id -re ".*$gdb_prompt $" {
 750             verbose "Setting width to 0." 2
 751         }
 752         -i $shell_id timeout {
 753             warning "Couldn't set the width to 0."
 754         }
 755     }
 756     return 0;
 757 }
 758
 759 #
 760 # FIXME: this is a copy of the new library procedure, but it's here too
 761 # till the new dejagnu gets installed everywhere. I'd hate to break the
 762 # gdb testsuite.
 763 #
 764 global argv0
 765 if ![info exists argv0] then {
 766     proc exp_continue { } {
 767         continue -expect
 768     }
 769 }
 770
 771 # * For crosses, the CHILL runtime doesn't build because it can't find
 772 # setjmp.h, stdio.h, etc.
 773 # * For AIX (as of 16 Mar 95), (a) there is no language code for
 774 # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
 775 # does not get along with AIX's too-clever linker.
 776 # * On Irix5, there is a bug whereby set of bool, etc., don't get
 777 # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
 778 # work with stub types.
 779 # Lots of things seem to fail on the PA, and since it's not a supported
 780 # chill target at the moment, don't run the chill tests.
 781
 782 proc skip_chill_tests {} {
 783     if ![info exists do_chill_tests] {
 784         return 1;
 785     }
 786     eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
 787     verbose "Skip chill tests is $skip_chill"
 788     return $skip_chill
 789 }
 790
 791 proc get_compiler_info {binfile} {
 792     # Create and source the file that provides information about the compiler
 793     # used to compile the test case.
 794     global srcdir
 795     global subdir
 796     # These two come from compiler.c.
 797     global signed_keyword_not_used
 798     global gcc_compiled
 799
 800     if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
 801         perror "Couldn't make ${binfile}.ci file"
 802         return 1;
 803     }
 804     source ${binfile}.ci
 805     return 0;
 806 }
 807
 808 proc gdb_compile {source dest type options} {
 809     if [target_info exists gdb_stub] {
 810         set options2 { "additional_flags=-Dusestubs" }
 811         lappend options "libs=[target_info gdb_stub]";
 812         set options [concat $options2 $options]
 813     }
 814     verbose "options are $options"
 815     verbose "source is $source $dest $type $options"
 816     set result [target_compile $source $dest $type $options];
 817     regsub "\[\r\n\]*$" "$result" "" result;
 818     regsub "^\[\r\n\]*" "$result" "" result;
 819     if { $result != "" } {
 820         clone_output "gdb compile failed, $result"
 821     }
 822     return $result;
 823 }
 824
 825 proc send_gdb { string } {
 826     return [remote_send host "$string"];
 827 }
 828
 829 proc gdb_start { } {
 830     default_gdb_start
 831 }
 832
 833 proc gdb_exit { } {
 834     catch default_gdb_exit
 835 }
 836
 837 #
 838 # gdb_load -- load a file into the debugger.
 839 #             return a -1 if anything goes wrong.
 840 #
 841 proc gdb_load { arg } {
 842     return [gdb_file_cmd $arg]
 843 }
 844
 845 proc gdb_continue { function } {
 846     global decimal
 847
 848     return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
 849 }
 850
 851 proc gdb_finish { } {
 852     gdb_exit;
 853 }