gdb/testsuite/lib/gdb.exp

   1 # Copyright (C) 1992, 1994, 1995, 1997 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 [transform 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     gdb_expect {
 101         -re "No exec file now\[^\r\n\]*\[\r\n\]" { exp_continue }
 102         -re "No symbol file now\[^\r\n\]*\[\r\n\]" { 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
 129     send_gdb "delete breakpoints\n"
 130     gdb_expect {
 131          -re "Delete all breakpoints.*y or n.*$" {
 132             send_gdb "y\n";
 133             exp_continue
 134         }
 135          -re "$gdb_prompt $" { # This happens if there were no breakpoints
 136             }
 137          timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
 138     }
 139     send_gdb "info breakpoints\n"
 140     gdb_expect {
 141          -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
 142          -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
 143          -re "Delete all breakpoints.*or n.*$" {
 144             send_gdb "y\n";
 145             exp_continue
 146         }
 147          timeout { perror "info breakpoints (timeout)" ; return }
 148     }
 149 }
 150
 151
 152 #
 153 # Generic run command.
 154 #
 155 # The second pattern below matches up to the first newline *only*.
 156 # Using ``.*$'' could swallow up output that we attempt to match
 157 # elsewhere.
 158 #
 159 proc gdb_run_cmd {args} {
 160     global gdb_prompt
 161
 162     if [target_info exists gdb_init_command] {
 163         send_gdb "[target_info gdb_init_command]\n";
 164         gdb_expect {
 165             -re "$gdb_prompt $" { }
 166             default {
 167                 perror "gdb_init_command for target failed";
 168                 return;
 169             }
 170         }
 171     }
 172
 173     if [target_info exists use_gdb_stub] {
 174         if [target_info exists gdb,start_symbol] {
 175             set start [target_info gdb,start_symbol];
 176         } else {
 177             set start "start";
 178         }
 179         send_gdb  "jump *$start\n"
 180         gdb_expect {
 181             -re "Continuing at \[^\r\n\]*\[\r\n\]" {
 182                 if ![target_info exists gdb_stub] {
 183                     return;
 184                 }
 185             }
 186             -re "No symbol \"start\" in current.*$gdb_prompt $" {
 187                 send_gdb "jump *_start\n";
 188                 exp_continue;
 189             }
 190             -re "No symbol \"_start\" in current.*$gdb_prompt $" {
 191                 perror "Can't find start symbol to run in gdb_run";
 192                 return;
 193             }
 194             -re "Line.* Jump anyway.*y or n. $" {
 195                 send_gdb "y\n"
 196                 exp_continue;
 197             }
 198             -re "No symbol.*context.*$gdb_prompt $" {}
 199             -re "The program is not being run.*$gdb_prompt $" {
 200                 gdb_load "";
 201             }
 202             timeout { perror "Jump to start() failed (timeout)"; return }
 203         }
 204         if [target_info exists gdb_stub] {
 205             gdb_expect {
 206                 -re "$gdb_prompt $" {
 207                     send_gdb "continue\n"
 208                 }
 209             }
 210         }
 211         return
 212     }
 213     send_gdb "run $args\n"
 214 # This doesn't work quite right yet.
 215     gdb_expect {
 216         -re "The program .* has been started already.*y or n. $" {
 217             send_gdb "y\n"
 218             exp_continue
 219         }
 220         -re "Starting program: \[^\r\n\]*" {}
 221     }
 222 }
 223
 224 proc gdb_breakpoint { function } {
 225     global gdb_prompt
 226     global decimal
 227
 228     send_gdb "break $function\n"
 229     # The first two regexps are what we get with -g, the third is without -g.
 230     gdb_expect {
 231         -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 232         -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 233         -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {}
 234         -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 }
 235         timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
 236     }
 237     return 1;
 238 }
 239
 240 # Set breakpoint at function and run gdb until it breaks there.
 241 # Since this is the only breakpoint that will be set, if it stops
 242 # at a breakpoint, we will assume it is the one we want.  We can't
 243 # just compare to "function" because it might be a fully qualified,
 244 # single quoted C++ function specifier.
 245
 246 proc runto { function } {
 247     global gdb_prompt
 248     global decimal
 249
 250     delete_breakpoints
 251
 252     if ![gdb_breakpoint $function] {
 253         return 0;
 254     }
 255
 256     gdb_run_cmd
 257
 258     # the "at foo.c:36" output we get with -g.
 259     # the "in func" output we get without -g.
 260     gdb_expect {
 261         -re "Break.* at .*:$decimal.*$gdb_prompt $" {
 262             return 1
 263         }
 264         -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" {
 265             return 1
 266         }
 267         -re "$gdb_prompt $" {
 268             fail "running to $function in runto"
 269             return 0
 270         }
 271         timeout {
 272             fail "running to $function in runto (timeout)"
 273             return 0
 274         }
 275     }
 276     return 1
 277 }
 278
 279 #
 280 # runto_main -- ask gdb to run until we hit a breakpoint at main.
 281 #               The case where the target uses stubs has to be handled
 282 #               specially--if it uses stubs, assuming we hit
 283 #               breakpoint() and just step out of the function.
 284 #
 285 proc runto_main {} {
 286     global gdb_prompt
 287     global decimal
 288
 289     if ![target_info exists gdb_stub] {
 290         return [runto main]
 291     }
 292
 293     delete_breakpoints
 294
 295     send_gdb "step\n"
 296     # if use stubs step out of the breakpoint() function.
 297     gdb_expect {
 298         -re "main.* at .*$gdb_prompt $" {}
 299         -re "_start.*$gdb_prompt $" {}
 300         timeout { fail "single step at breakpoint() (timeout)" ; return 0 }
 301     }
 302     return 1
 303 }
 304
 305 #
 306 # gdb_test -- send_gdb a command to gdb and test the result.
 307 #             Takes three parameters.
 308 #             Parameters:
 309 #                First one is the command to execute.  If this is the null string
 310 #                  then no command is sent.
 311 #                Second one is the pattern to match for a PASS, and must NOT include
 312 #                  the \r\n sequence immediately before the gdb prompt.
 313 #                Third one is an optional message to be printed. If this
 314 #                  a null string "", then the pass/fail messages use the command
 315 #                  string as the message.
 316 #             Returns:
 317 #                1 if the test failed,
 318 #                0 if the test passes,
 319 #               -1 if there was an internal error.
 320 #
 321 proc gdb_test { args } {
 322     global verbose
 323     global gdb_prompt
 324     global GDB
 325     global expect_out
 326     upvar timeout timeout
 327
 328     if [llength $args]>2 then {
 329         set message [lindex $args 2]
 330     } else {
 331         set message [lindex $args 0]
 332     }
 333     set command [lindex $args 0]
 334     set pattern [lindex $args 1]
 335
 336     if [llength $args]==5 {
 337         set question_string [lindex $args 3];
 338         set response_string [lindex $args 4];
 339     } else {
 340         set question_string "^FOOBAR$"
 341     }
 342
 343     if $verbose>2 then {
 344         send_user "Sending \"$command\" to gdb\n"
 345         send_user "Looking to match \"$pattern\"\n"
 346         send_user "Message is \"$message\"\n"
 347     }
 348
 349     set result -1
 350     if ![string match $command ""] {
 351         if { [send_gdb "$command\n"] != "" } {
 352             global suppress_flag;
 353
 354             if { ! $suppress_flag } {
 355                 perror "Couldn't send $command to GDB.";
 356             }
 357             fail "$message";
 358             return $result;
 359         }
 360     }
 361
 362     gdb_expect {
 363          -re "Ending remote debugging.*$gdb_prompt$" {
 364             if ![isnative] then {
 365                 warning "Can`t communicate to remote target."
 366             }
 367             gdb_exit
 368             gdb_start
 369             set result -1
 370         }
 371          -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
 372             if ![string match "" $message] then {
 373                 pass "$message"
 374             }
 375             set result 0
 376         }
 377          -re "(${question_string})$" {
 378             send_gdb "$response_string\n";
 379             exp_continue;
 380         }
 381          -re "Undefined command:.*$gdb_prompt" {
 382             perror "Undefined command \"$command\"."
 383             set result 1
 384         }
 385          -re "Ambiguous command.*$gdb_prompt $" {
 386             perror "\"$command\" is not a unique command name."
 387             set result 1
 388         }
 389          -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
 390             if ![string match "" $message] then {
 391                 set errmsg "$message: the program exited"
 392             } else {
 393                 set errmsg "$command: the program exited"
 394             }
 395             fail "$errmsg"
 396             return -1
 397         }
 398          -re "The program is not being run.*$gdb_prompt $" {
 399             if ![string match "" $message] then {
 400                 set errmsg "$message: the program is no longer running"
 401             } else {
 402                 set errmsg "$command: the program is no longer running"
 403             }
 404             fail "$errmsg"
 405             return -1
 406         }
 407          -re ".*$gdb_prompt $" {
 408             if ![string match "" $message] then {
 409                 fail "$message"
 410             }
 411             set result 1
 412         }
 413          "<return>" {
 414             send_gdb "\n"
 415             perror "Window too small."
 416         }
 417          -re "\\(y or n\\) " {
 418             send_gdb "n\n"
 419             perror "Got interactive prompt."
 420         }
 421          eof {
 422              perror "Process no longer exists"
 423              if { $message != "" } {
 424                  fail "$message"
 425              }
 426              return -1
 427         }
 428          full_buffer {
 429             perror "internal buffer is full."
 430         }
 431         timeout {
 432             if ![string match "" $message] then {
 433                 fail "$message (timeout)"
 434             }
 435             set result 1
 436         }
 437     }
 438     return $result
 439 }
 440 \f
 441 # Test that a command gives an error.  For pass or fail, return
 442 # a 1 to indicate that more tests can proceed.  However a timeout
 443 # is a serious error, generates a special fail message, and causes
 444 # a 0 to be returned to indicate that more tests are likely to fail
 445 # as well.
 446
 447 proc test_print_reject { args } {
 448     global gdb_prompt
 449     global verbose
 450
 451     if [llength $args]==2 then {
 452         set expectthis [lindex $args 1]
 453     } else {
 454         set expectthis "should never match this bogus string"
 455     }
 456     set sendthis [lindex $args 0]
 457     if $verbose>2 then {
 458         send_user "Sending \"$sendthis\" to gdb\n"
 459         send_user "Looking to match \"$expectthis\"\n"
 460     }
 461     send_gdb "$sendthis\n"
 462     gdb_expect {
 463         -re "A .* in expression.*\\.*$gdb_prompt $" {
 464             pass "reject $sendthis"
 465             return 1
 466         }
 467         -re "Invalid syntax in expression.*$gdb_prompt $" {
 468             pass "reject $sendthis"
 469             return 1
 470         }
 471         -re "Junk after end of expression.*$gdb_prompt $" {
 472             pass "reject $sendthis"
 473             return 1
 474         }
 475         -re "Invalid number.*$gdb_prompt $" {
 476             pass "reject $sendthis"
 477             return 1
 478         }
 479         -re "Invalid character constant.*$gdb_prompt $" {
 480             pass "reject $sendthis"
 481             return 1
 482         }
 483         -re "No symbol table is loaded.*$gdb_prompt $" {
 484             pass "reject $sendthis"
 485             return 1
 486         }
 487         -re "No symbol .* in current context.*$gdb_prompt $" {
 488             pass "reject $sendthis"
 489             return 1
 490         }
 491         -re "$expectthis.*$gdb_prompt $" {
 492             pass "reject $sendthis"
 493             return 1
 494         }
 495         -re ".*$gdb_prompt $" {
 496             fail "reject $sendthis"
 497             return 1
 498         }
 499         default {
 500             fail "reject $sendthis (eof or timeout)"
 501             return 0
 502         }
 503     }
 504 }
 505 \f
 506 # Given an input string, adds backslashes as needed to create a
 507 # regexp that will match the string.
 508
 509 proc string_to_regexp {str} {
 510     set result $str
 511     regsub -all {[]*+.|()^$\[]} $str {\\&} result
 512     return $result
 513 }
 514
 515 # Same as gdb_test, but the second parameter is not a regexp,
 516 # but a string that must match exactly.
 517
 518 proc gdb_test_exact { args } {
 519     upvar timeout timeout
 520
 521     set command [lindex $args 0]
 522
 523     # This applies a special meaning to a null string pattern.  Without
 524     # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
 525     # messages from commands that should have no output except a new
 526     # prompt.  With this, only results of a null string will match a null
 527     # string pattern.
 528
 529     set pattern [lindex $args 1]
 530     if [string match $pattern ""] {
 531         set pattern [string_to_regexp [lindex $args 0]]
 532     } else {
 533         set pattern [string_to_regexp [lindex $args 1]]
 534     }
 535
 536     # It is most natural to write the pattern argument with only
 537     # embedded \n's, especially if you are trying to avoid Tcl quoting
 538     # problems.  But gdb_expect really wants to see \r\n in patterns.  So
 539     # transform the pattern here.  First transform \r\n back to \n, in
 540     # case some users of gdb_test_exact already do the right thing.
 541     regsub -all "\r\n" $pattern "\n" pattern
 542     regsub -all "\n" $pattern "\r\n" pattern
 543     if [llength $args]==3 then {
 544         set message [lindex $args 2]
 545     } else {
 546         set message $command
 547     }
 548
 549     return [gdb_test $command $pattern $message]
 550 }
 551 \f
 552 proc gdb_reinitialize_dir { subdir } {
 553     global gdb_prompt
 554
 555     if [is_remote host] {
 556         return "";
 557     }
 558     send_gdb "dir\n"
 559     gdb_expect {
 560         -re "Reinitialize source path to empty.*y or n. " {
 561             send_gdb "y\n"
 562             gdb_expect {
 563                 -re "Source directories searched.*$gdb_prompt $" {
 564                     send_gdb "dir $subdir\n"
 565                     gdb_expect {
 566                         -re "Source directories searched.*$gdb_prompt $" {
 567                             verbose "Dir set to $subdir"
 568                         }
 569                         -re "$gdb_prompt $" {
 570                             perror "Dir \"$subdir\" failed."
 571                         }
 572                     }
 573                 }
 574                 -re "$gdb_prompt $" {
 575                     perror "Dir \"$subdir\" failed."
 576                 }
 577             }
 578         }
 579         -re "$gdb_prompt $" {
 580             perror "Dir \"$subdir\" failed."
 581         }
 582     }
 583 }
 584
 585 #
 586 # gdb_exit -- exit the GDB, killing the target program if necessary
 587 #
 588 proc default_gdb_exit {} {
 589     global GDB
 590     global GDBFLAGS
 591     global verbose
 592     global gdb_spawn_id;
 593
 594     gdb_stop_suppressing_tests;
 595
 596     if ![info exists gdb_spawn_id] {
 597         return;
 598     }
 599
 600     verbose "Quitting $GDB $GDBFLAGS"
 601
 602     # This used to be 1 for unix-gdb.exp
 603     set timeout 5
 604     verbose "Timeout is now $timeout seconds" 2
 605
 606     if [is_remote host] {
 607         send_gdb "quit\n";
 608         gdb_expect {
 609              -re "and kill it.*y or n. " {
 610                 send_gdb "y\n";
 611                 exp_continue;
 612             }
 613             timeout { }
 614         }
 615     }
 616
 617     remote_close host;
 618     unset gdb_spawn_id
 619 }
 620
 621 #
 622 # load a file into the debugger.
 623 # return a -1 if anything goes wrong.
 624 #
 625 proc gdb_file_cmd { arg } {
 626     global verbose
 627     global loadpath
 628     global loadfile
 629     global GDB
 630     global gdb_prompt
 631     upvar timeout timeout
 632
 633     if [is_remote host] {
 634         set arg [remote_download host $arg];
 635         if { $arg == "" } {
 636             error "download failed"
 637             return -1;
 638         }
 639     }
 640
 641     send_gdb "file $arg\n"
 642     gdb_expect {
 643         -re "Reading symbols from.*done.*$gdb_prompt $" {
 644             verbose "\t\tLoaded $arg into the $GDB"
 645             return 0
 646         }
 647         -re "has no symbol-table.*$gdb_prompt $" {
 648             perror "$arg wasn't compiled with \"-g\""
 649             return -1
 650         }
 651         -re "A program is being debugged already.*Kill it.*y or n. $" {
 652             send_gdb "y\n"
 653                 verbose "\t\tKilling previous program being debugged"
 654             exp_continue
 655         }
 656         -re "Load new symbol table from \".*\".*y or n. $" {
 657             send_gdb "y\n"
 658             gdb_expect {
 659                 -re "Reading symbols from.*done.*$gdb_prompt $" {
 660                     verbose "\t\tLoaded $arg with new symbol table into $GDB"
 661                     return 0
 662                 }
 663                 timeout {
 664                     perror "(timeout) Couldn't load $arg, other program already loaded."
 665                     return -1
 666                 }
 667             }
 668         }
 669         -re "No such file or directory.*$gdb_prompt $" {
 670             perror "($arg) No such file or directory\n"
 671             return -1
 672         }
 673         -re "$gdb_prompt $" {
 674             perror "couldn't load $arg into $GDB."
 675             return -1
 676             }
 677         timeout {
 678             perror "couldn't load $arg into $GDB (timed out)."
 679             return -1
 680         }
 681         eof {
 682             # This is an attempt to detect a core dump, but seems not to
 683             # work.  Perhaps we need to match .* followed by eof, in which
 684             # gdb_expect does not seem to have a way to do that.
 685             perror "couldn't load $arg into $GDB (end of file)."
 686             return -1
 687         }
 688     }
 689 }
 690
 691 #
 692 # start gdb -- start gdb running, default procedure
 693 #
 694 # When running over NFS, particularly if running many simultaneous
 695 # tests on different hosts all using the same server, things can
 696 # get really slow.  Give gdb at least 3 minutes to start up.
 697 #
 698 proc default_gdb_start { } {
 699     global verbose
 700     global GDB
 701     global GDBFLAGS
 702     global gdb_prompt
 703     global timeout
 704     global gdb_spawn_id;
 705
 706     gdb_stop_suppressing_tests;
 707
 708     verbose "Spawning $GDB -nw $GDBFLAGS"
 709
 710     if [info exists gdb_spawn_id] {
 711         return 0;
 712     }
 713
 714     set oldtimeout $timeout
 715     set timeout [expr "$timeout + 180"]
 716     if [is_remote host] {
 717         set res [remote_spawn host "$GDB -nw $GDBFLAGS --command gdbinit"];
 718     } else {
 719         if { [which $GDB] == 0 } then {
 720             perror "$GDB does not exist."
 721             exit 1
 722         }
 723
 724         set res [remote_spawn host "$GDB -nw $GDBFLAGS"];
 725     }
 726     if { $res < 0 || $res == "" } {
 727         perror "Spawning $GDB failed."
 728         return 1;
 729     }
 730     set timeout 10
 731     gdb_expect {
 732         -re "\[\r\n\]$gdb_prompt $" {
 733             verbose "GDB initialized."
 734         }
 735         -re "$gdb_prompt $"     {
 736             perror "GDB never initialized."
 737             set timeout $oldtimeout
 738             verbose "Timeout restored to $timeout seconds" 2
 739             return -1
 740         }
 741         timeout {
 742
 743             perror "(timeout) GDB never initialized after $timeout seconds."
 744             return -1
 745         }
 746     }
 747     set timeout $oldtimeout
 748     verbose "Timeout restored to $timeout seconds" 2
 749     set gdb_spawn_id -1;
 750     # force the height to "unlimited", so no pagers get used
 751
 752     send_gdb "set height 0\n"
 753     gdb_expect {
 754         -re "$gdb_prompt $" {
 755             verbose "Setting height to 0." 2
 756         }
 757         timeout {
 758             warning "Couldn't set the height to 0"
 759         }
 760     }
 761     # force the width to "unlimited", so no wraparound occurs
 762     send_gdb "set width 0\n"
 763     gdb_expect {
 764         -re "$gdb_prompt $" {
 765             verbose "Setting width to 0." 2
 766         }
 767         timeout {
 768             warning "Couldn't set the width to 0."
 769         }
 770     }
 771     return 0;
 772 }
 773
 774 #
 775 # FIXME: this is a copy of the new library procedure, but it's here too
 776 # till the new dejagnu gets installed everywhere. I'd hate to break the
 777 # gdb testsuite.
 778 #
 779 global argv0
 780 if ![info exists argv0] then {
 781     proc exp_continue { } {
 782         continue -expect
 783     }
 784 }
 785
 786 # * For crosses, the CHILL runtime doesn't build because it can't find
 787 # setjmp.h, stdio.h, etc.
 788 # * For AIX (as of 16 Mar 95), (a) there is no language code for
 789 # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
 790 # does not get along with AIX's too-clever linker.
 791 # * On Irix5, there is a bug whereby set of bool, etc., don't get
 792 # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
 793 # work with stub types.
 794 # Lots of things seem to fail on the PA, and since it's not a supported
 795 # chill target at the moment, don't run the chill tests.
 796
 797 proc skip_chill_tests {} {
 798     if ![info exists do_chill_tests] {
 799         return 1;
 800     }
 801     eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
 802     verbose "Skip chill tests is $skip_chill"
 803     return $skip_chill
 804 }
 805
 806 proc get_compiler_info {binfile} {
 807     # Create and source the file that provides information about the compiler
 808     # used to compile the test case.
 809     global srcdir
 810     global subdir
 811     # These two come from compiler.c.
 812     global signed_keyword_not_used
 813     global gcc_compiled
 814
 815     if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
 816         perror "Couldn't make ${binfile}.ci file"
 817         return 1;
 818     }
 819     source ${binfile}.ci
 820     return 0;
 821 }
 822
 823 proc gdb_compile {source dest type options} {
 824     global GDB_TESTCASE_OPTIONS;
 825
 826     if [target_info exists gdb_stub] {
 827         set options2 { "additional_flags=-Dusestubs" }
 828         lappend options "libs=[target_info gdb_stub]";
 829         set options [concat $options2 $options]
 830     }
 831     if [info exists GDB_TESTCASE_OPTIONS] {
 832         lappend options "additional_flags=$GDB_TESTCASE_OPTIONS";
 833     }
 834     verbose "options are $options"
 835     verbose "source is $source $dest $type $options"
 836     set result [target_compile $source $dest $type $options];
 837     regsub "\[\r\n\]*$" "$result" "" result;
 838     regsub "^\[\r\n\]*" "$result" "" result;
 839     if { $result != "" } {
 840         clone_output "gdb compile failed, $result"
 841     }
 842     return $result;
 843 }
 844
 845 proc send_gdb { string } {
 846     global suppress_flag;
 847     if { $suppress_flag } {
 848         return "suppressed";
 849     }
 850     return [remote_send host "$string"];
 851 }
 852
 853 #
 854 #
 855
 856 proc gdb_expect { args } {
 857     upvar timeout timeout
 858     if [target_info exists gdb,timeout] {
 859         set oldt $timeout
 860         set timeout [target_info gdb,timeout];
 861     }
 862     set code [catch {uplevel remote_expect host $args} string];
 863     if [info exists oldt] {
 864         set timeout oldt
 865     }
 866
 867     if {$code == 1} {
 868         return -code error -errorinfo $errorInfo -errorcode $errorCode $string
 869     } elseif {$code == 2} {
 870         return -code return $string
 871     } elseif {$code == 3} {
 872         return
 873     } elseif {$code > 4} {
 874         return -code $code $string
 875     }
 876 }
 877
 878 #
 879 # Set suppress_flag, which will cause all subsequent calls to send_gdb and
 880 # gdb_expect to fail immediately (until the next call to
 881 # gdb_stop_suppressing_tests).
 882 #
 883 proc gdb_suppress_tests { args } {
 884     global suppress_flag;
 885
 886     incr suppress_flag;
 887
 888     if { [llength $args] > 0 } {
 889         warning "[lindex $args 0]\n";
 890     } else {
 891         warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n";
 892     }
 893 }
 894
 895 #
 896 # Clear suppress_flag.
 897 #
 898 proc gdb_stop_suppressing_tests { } {
 899     global suppress_flag;
 900
 901     if [info exists suppress_flag] {
 902         if { $suppress_flag != 0 } {
 903             set suppress_flag 0;
 904             clone_output "Tests restarted.\n";
 905         }
 906     } else {
 907         set suppress_flag 0;
 908     }
 909 }
 910
 911 proc gdb_start { } {
 912     default_gdb_start
 913 }
 914
 915 proc gdb_exit { } {
 916     catch default_gdb_exit
 917 }
 918
 919 #
 920 # gdb_load -- load a file into the debugger.
 921 #             return a -1 if anything goes wrong.
 922 #
 923 proc gdb_load { arg } {
 924     return [gdb_file_cmd $arg]
 925 }
 926
 927 proc gdb_continue { function } {
 928     global decimal
 929
 930     return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
 931 }
 932
 933 proc gdb_init { args } {
 934     gdb_stop_suppressing_tests;
 935
 936     # Uh, this is lame. Really, really, really lame. But there's this *one*
 937     # testcase that will fail in random places if we don't increase this.
 938     match_max -d 20000
 939
 940     # We want to add the name of the TCL testcase to the PASS/FAIL messages.
 941     if { [llength $args] > 0 } {
 942         global pf_prefix
 943
 944         set file [lindex $args 0];
 945
 946         set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:";
 947     }
 948 }
 949
 950 proc gdb_finish { } {
 951     gdb_exit;
 952 }