gdb/testsuite/lib/gdb.exp

   1 # Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000
   2 # Free Software Foundation, Inc.
   3
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  17
  18 # Please email any bugs, comments, and/or additions to this file to:
  19 # bug-gdb@prep.ai.mit.edu
  20
  21 # This file was written by Fred Fish. (fnf@cygnus.com)
  22
  23 # Generic gdb subroutines that should work for any target.  If these
  24 # need to be modified for any target, it can be done with a variable
  25 # or by passing arguments.
  26
  27 load_lib libgloss.exp
  28
  29 global GDB
  30
  31 if [info exists TOOL_EXECUTABLE] {
  32     set GDB $TOOL_EXECUTABLE;
  33 }
  34 if ![info exists GDB] {
  35     if ![is_remote host] {
  36         set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
  37     } else {
  38         set GDB [transform gdb];
  39     }
  40 }
  41 verbose "using GDB = $GDB" 2
  42
  43 global GDBFLAGS
  44 if ![info exists GDBFLAGS] {
  45     set GDBFLAGS "-nx"
  46 }
  47 verbose "using GDBFLAGS = $GDBFLAGS" 2
  48
  49 # The variable gdb_prompt is a regexp which matches the gdb prompt.
  50 # Set it if it is not already set.
  51 global gdb_prompt
  52 if ![info exists gdb_prompt] then {
  53     set gdb_prompt "\[(\]gdb\[)\]"
  54 }
  55
  56 # Needed for some tests under Cygwin.
  57 global EXEEXT
  58 global env
  59
  60 if ![info exists env(EXEEXT)] {
  61     set EXEEXT ""
  62 } else {
  63     set EXEEXT $env(EXEEXT)
  64 }
  65
  66 ### Only procedures should come after this point.
  67
  68 #
  69 # gdb_version -- extract and print the version number of GDB
  70 #
  71 proc default_gdb_version {} {
  72     global GDB
  73     global GDBFLAGS
  74     global gdb_prompt
  75     set fileid [open "gdb_cmd" w];
  76     puts $fileid "q";
  77     close $fileid;
  78     set cmdfile [remote_download host "gdb_cmd"];
  79     set output [remote_exec host "$GDB -nw --command $cmdfile"]
  80     remote_file build delete "gdb_cmd";
  81     remote_file host delete "$cmdfile";
  82     set tmp [lindex $output 1];
  83     set version ""
  84     regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
  85     if ![is_remote host] {
  86         clone_output "[which $GDB] version $version $GDBFLAGS\n"
  87     } else {
  88         clone_output "$GDB on remote host version $version $GDBFLAGS\n"
  89     }
  90 }
  91
  92 proc gdb_version { } {
  93     return [default_gdb_version];
  94 }
  95
  96 #
  97 # gdb_unload -- unload a file if one is loaded
  98 #
  99
 100 proc gdb_unload {} {
 101     global verbose
 102     global GDB
 103     global gdb_prompt
 104     send_gdb "file\n"
 105     gdb_expect 60 {
 106         -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
 107         -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
 108         -re "A program is being debugged already..*Kill it.*y or n. $"\
 109             { send_gdb "y\n"
 110                 verbose "\t\tKilling previous program being debugged"
 111             exp_continue
 112         }
 113         -re "Discard symbol table from .*y or n.*$" {
 114             send_gdb "y\n"
 115             exp_continue
 116         }
 117         -re "$gdb_prompt $" {}
 118         timeout {
 119             perror "couldn't unload file in $GDB (timed out)."
 120             return -1
 121         }
 122     }
 123 }
 124
 125 # Many of the tests depend on setting breakpoints at various places and
 126 # running until that breakpoint is reached.  At times, we want to start
 127 # with a clean-slate with respect to breakpoints, so this utility proc
 128 # lets us do this without duplicating this code everywhere.
 129 #
 130
 131 proc delete_breakpoints {} {
 132     global gdb_prompt
 133
 134     # we need a larger timeout value here or this thing just confuses
 135     # itself.  May need a better implementation if possible. - guo
 136     #
 137     send_gdb "delete breakpoints\n"
 138     gdb_expect 100 {
 139          -re "Delete all breakpoints.*y or n.*$" {
 140             send_gdb "y\n";
 141             exp_continue
 142         }
 143          -re "$gdb_prompt $" { # This happens if there were no breakpoints
 144             }
 145          timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
 146     }
 147     send_gdb "info breakpoints\n"
 148     gdb_expect 100 {
 149          -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
 150          -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
 151          -re "Delete all breakpoints.*or n.*$" {
 152             send_gdb "y\n";
 153             exp_continue
 154         }
 155          timeout { perror "info breakpoints (timeout)" ; return }
 156     }
 157 }
 158
 159
 160 #
 161 # Generic run command.
 162 #
 163 # The second pattern below matches up to the first newline *only*.
 164 # Using ``.*$'' could swallow up output that we attempt to match
 165 # elsewhere.
 166 #
 167 proc gdb_run_cmd {args} {
 168     global gdb_prompt
 169
 170     if [target_info exists gdb_init_command] {
 171         send_gdb "[target_info gdb_init_command]\n";
 172         gdb_expect 30 {
 173             -re "$gdb_prompt $" { }
 174             default {
 175                 perror "gdb_init_command for target failed";
 176                 return;
 177             }
 178         }
 179     }
 180
 181     if [target_info exists use_gdb_stub] {
 182         if [target_info exists gdb,do_reload_on_run] {
 183             # Specifying no file, defaults to the executable
 184             # currently being debugged.
 185             if { [gdb_load ""] < 0 } {
 186                 return;
 187             }
 188             send_gdb "continue\n";
 189             gdb_expect 60 {
 190                 -re "Continu\[^\r\n\]*\[\r\n\]" {}
 191                 default {}
 192             }
 193             return;
 194         }
 195
 196         if [target_info exists gdb,start_symbol] {
 197             set start [target_info gdb,start_symbol];
 198         } else {
 199             set start "start";
 200         }
 201         send_gdb  "jump *$start\n"
 202         set start_attempt 1;
 203         while { $start_attempt } {
 204             # Cap (re)start attempts at three to ensure that this loop
 205             # always eventually fails.  Don't worry about trying to be
 206             # clever and not send a command when it has failed.
 207             if [expr $start_attempt > 3] {
 208                 perror "Jump to start() failed (retry count exceeded)";
 209                 return;
 210             }
 211             set start_attempt [expr $start_attempt + 1];
 212             gdb_expect 30 {
 213                 -re "Continuing at \[^\r\n\]*\[\r\n\]" {
 214                     set start_attempt 0;
 215                 }
 216                 -re "No symbol \"_start\" in current.*$gdb_prompt $" {
 217                     perror "Can't find start symbol to run in gdb_run";
 218                     return;
 219                 }
 220                 -re "No symbol \"start\" in current.*$gdb_prompt $" {
 221                     send_gdb "jump *_start\n";
 222                 }
 223                 -re "No symbol.*context.*$gdb_prompt $" {
 224                     set start_attempt 0;
 225                 }
 226                 -re "Line.* Jump anyway.*y or n. $" {
 227                     send_gdb "y\n"
 228                 }
 229                 -re "The program is not being run.*$gdb_prompt $" {
 230                     if { [gdb_load ""] < 0 } {
 231                         return;
 232                     }
 233                     send_gdb "jump *$start\n";
 234                 }
 235                 timeout {
 236                     perror "Jump to start() failed (timeout)";
 237                     return
 238                 }
 239             }
 240         }
 241         if [target_info exists gdb_stub] {
 242             gdb_expect 60 {
 243                 -re "$gdb_prompt $" {
 244                     send_gdb "continue\n"
 245                 }
 246             }
 247         }
 248         return
 249     }
 250     send_gdb "run $args\n"
 251 # This doesn't work quite right yet.
 252     gdb_expect 60 {
 253         -re "The program .* has been started already.*y or n. $" {
 254             send_gdb "y\n"
 255             exp_continue
 256         }
 257         -re "Starting program: \[^\r\n\]*" {}
 258     }
 259 }
 260
 261 proc gdb_breakpoint { function } {
 262     global gdb_prompt
 263     global decimal
 264
 265     send_gdb "break $function\n"
 266     # The first two regexps are what we get with -g, the third is without -g.
 267     gdb_expect 30 {
 268         -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 269         -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
 270         -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {}
 271         -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 }
 272         timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
 273     }
 274     return 1;
 275 }
 276
 277 # Set breakpoint at function and run gdb until it breaks there.
 278 # Since this is the only breakpoint that will be set, if it stops
 279 # at a breakpoint, we will assume it is the one we want.  We can't
 280 # just compare to "function" because it might be a fully qualified,
 281 # single quoted C++ function specifier.
 282
 283 proc runto { function } {
 284     global gdb_prompt
 285     global decimal
 286
 287     delete_breakpoints
 288
 289     if ![gdb_breakpoint $function] {
 290         return 0;
 291     }
 292
 293     gdb_run_cmd
 294
 295     # the "at foo.c:36" output we get with -g.
 296     # the "in func" output we get without -g.
 297     gdb_expect 30 {
 298         -re "Break.* at .*:$decimal.*$gdb_prompt $" {
 299             return 1
 300         }
 301         -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" {
 302             return 1
 303         }
 304         -re "$gdb_prompt $" {
 305             fail "running to $function in runto"
 306             return 0
 307         }
 308         timeout {
 309             fail "running to $function in runto (timeout)"
 310             return 0
 311         }
 312     }
 313     return 1
 314 }
 315
 316 #
 317 # runto_main -- ask gdb to run until we hit a breakpoint at main.
 318 #               The case where the target uses stubs has to be handled
 319 #               specially--if it uses stubs, assuming we hit
 320 #               breakpoint() and just step out of the function.
 321 #
 322 proc runto_main { } {
 323     global gdb_prompt
 324     global decimal
 325
 326     if ![target_info exists gdb_stub] {
 327         return [runto main]
 328     }
 329
 330     delete_breakpoints
 331
 332     gdb_step_for_stub;
 333
 334     return 1
 335 }
 336
 337
 338 ### Continue, and expect to hit a breakpoint.
 339 ### Report a pass or fail, depending on whether it seems to have
 340 ### worked.  Use NAME as part of the test name; each call to
 341 ### continue_to_breakpoint should use a NAME which is unique within
 342 ### that test file.
 343 proc gdb_continue_to_breakpoint {name} {
 344     global gdb_prompt
 345     set full_name "continue to breakpoint: $name"
 346
 347     send_gdb "continue\n"
 348     gdb_expect {
 349         -re "Breakpoint .* at .*\r\n$gdb_prompt $" {
 350             pass $full_name
 351         }
 352         -re ".*$gdb_prompt $" {
 353             fail $full_name
 354         }
 355         timeout {
 356             fail "$full_name (timeout)"
 357         }
 358     }
 359 }
 360
 361
 362
 363 # gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
 364 # Send a command to gdb; test the result.
 365 #
 366 # COMMAND is the command to execute, send to GDB with send_gdb.  If
 367 #   this is the null string no command is sent.
 368 # PATTERN is the pattern to match for a PASS, and must NOT include
 369 #   the \r\n sequence immediately before the gdb prompt.
 370 # MESSAGE is an optional message to be printed.  If this is
 371 #   omitted, then the pass/fail messages use the command string as the
 372 #   message.  (If this is the empty string, then sometimes we don't
 373 #   call pass or fail at all; I don't understand this at all.)
 374 # QUESTION is a question GDB may ask in response to COMMAND, like
 375 #   "are you sure?"
 376 # RESPONSE is the response to send if QUESTION appears.
 377 #
 378 # Returns:
 379 #    1 if the test failed,
 380 #    0 if the test passes,
 381 #   -1 if there was an internal error.
 382 #
 383 proc gdb_test { args } {
 384     global verbose
 385     global gdb_prompt
 386     global GDB
 387     upvar timeout timeout
 388
 389     if [llength $args]>2 then {
 390         set message [lindex $args 2]
 391     } else {
 392         set message [lindex $args 0]
 393     }
 394     set command [lindex $args 0]
 395     set pattern [lindex $args 1]
 396
 397     if [llength $args]==5 {
 398         set question_string [lindex $args 3];
 399         set response_string [lindex $args 4];
 400     } else {
 401         set question_string "^FOOBAR$"
 402     }
 403
 404     if $verbose>2 then {
 405         send_user "Sending \"$command\" to gdb\n"
 406         send_user "Looking to match \"$pattern\"\n"
 407         send_user "Message is \"$message\"\n"
 408     }
 409
 410     set result -1
 411     set string "${command}\n";
 412     if { $command != "" } {
 413         while { "$string" != "" } {
 414             set foo [string first "\n" "$string"];
 415             set len [string length "$string"];
 416             if { $foo < [expr $len - 1] } {
 417                 set str [string range "$string" 0 $foo];
 418                 if { [send_gdb "$str"] != "" } {
 419                     global suppress_flag;
 420
 421                     if { ! $suppress_flag } {
 422                         perror "Couldn't send $command to GDB.";
 423                     }
 424                     fail "$message";
 425                     return $result;
 426                 }
 427                 # since we're checking if each line of the multi-line
 428                 # command are 'accepted' by GDB here,
 429                 # we need to set -notransfer expect option so that
 430                 # command output is not lost for pattern matching
 431                 # - guo
 432                 gdb_expect 2 {
 433                     -notransfer -re "\[\r\n\]" { verbose "partial: match" 3 }
 434                     timeout { verbose "partial: timeout" 3 }
 435                 }
 436                 set string [string range "$string" [expr $foo + 1] end];
 437             } else {
 438                 break;
 439             }
 440         }
 441         if { "$string" != "" } {
 442             if { [send_gdb "$string"] != "" } {
 443                 global suppress_flag;
 444
 445                 if { ! $suppress_flag } {
 446                     perror "Couldn't send $command to GDB.";
 447                 }
 448                 fail "$message";
 449                 return $result;
 450             }
 451         }
 452     }
 453
 454     if [target_info exists gdb,timeout] {
 455         set tmt [target_info gdb,timeout];
 456     } else {
 457         if [info exists timeout] {
 458             set tmt $timeout;
 459         } else {
 460             global timeout;
 461             if [info exists timeout] {
 462                 set tmt $timeout;
 463             } else {
 464                 set tmt 60;
 465             }
 466         }
 467     }
 468     gdb_expect $tmt {
 469          -re "\\*\\*\\* DOSEXIT code.*" {
 470              if { $message != "" } {
 471                  fail "$message";
 472              }
 473              gdb_suppress_entire_file "GDB died";
 474              return -1;
 475          }
 476          -re "Ending remote debugging.*$gdb_prompt $" {
 477             if ![isnative] then {
 478                 warning "Can`t communicate to remote target."
 479             }
 480             gdb_exit
 481             gdb_start
 482             set result -1
 483         }
 484          -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
 485             if ![string match "" $message] then {
 486                 pass "$message"
 487             }
 488             set result 0
 489         }
 490          -re "(${question_string})$" {
 491             send_gdb "$response_string\n";
 492             exp_continue;
 493         }
 494          -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
 495             perror "Undefined command \"$command\"."
 496             fail "$message"
 497             set result 1
 498         }
 499          -re "Ambiguous command.*$gdb_prompt $" {
 500             perror "\"$command\" is not a unique command name."
 501             fail "$message"
 502             set result 1
 503         }
 504          -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
 505             if ![string match "" $message] then {
 506                 set errmsg "$message: the program exited"
 507             } else {
 508                 set errmsg "$command: the program exited"
 509             }
 510             fail "$errmsg"
 511             return -1
 512         }
 513          -re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
 514             if ![string match "" $message] then {
 515                 set errmsg "$message: the program exited"
 516             } else {
 517                 set errmsg "$command: the program exited"
 518             }
 519             fail "$errmsg"
 520             return -1
 521         }
 522          -re "The program is not being run.*$gdb_prompt $" {
 523             if ![string match "" $message] then {
 524                 set errmsg "$message: the program is no longer running"
 525             } else {
 526                 set errmsg "$command: the program is no longer running"
 527             }
 528             fail "$errmsg"
 529             return -1
 530         }
 531          -re ".*$gdb_prompt $" {
 532             if ![string match "" $message] then {
 533                 fail "$message"
 534             }
 535             set result 1
 536         }
 537          "<return>" {
 538             send_gdb "\n"
 539             perror "Window too small."
 540             fail "$message"
 541         }
 542          -re "\\(y or n\\) " {
 543             send_gdb "n\n"
 544             perror "Got interactive prompt."
 545             fail "$message"
 546         }
 547          eof {
 548              perror "Process no longer exists"
 549              if { $message != "" } {
 550                  fail "$message"
 551              }
 552              return -1
 553         }
 554          full_buffer {
 555             perror "internal buffer is full."
 556             fail "$message"
 557         }
 558         timeout {
 559             if ![string match "" $message] then {
 560                 fail "$message (timeout)"
 561             }
 562             set result 1
 563         }
 564     }
 565     return $result
 566 }
 567 \f
 568 # Test that a command gives an error.  For pass or fail, return
 569 # a 1 to indicate that more tests can proceed.  However a timeout
 570 # is a serious error, generates a special fail message, and causes
 571 # a 0 to be returned to indicate that more tests are likely to fail
 572 # as well.
 573
 574 proc test_print_reject { args } {
 575     global gdb_prompt
 576     global verbose
 577
 578     if [llength $args]==2 then {
 579         set expectthis [lindex $args 1]
 580     } else {
 581         set expectthis "should never match this bogus string"
 582     }
 583     set sendthis [lindex $args 0]
 584     if $verbose>2 then {
 585         send_user "Sending \"$sendthis\" to gdb\n"
 586         send_user "Looking to match \"$expectthis\"\n"
 587     }
 588     send_gdb "$sendthis\n"
 589     #FIXME: Should add timeout as parameter.
 590     gdb_expect {
 591         -re "A .* in expression.*\\.*$gdb_prompt $" {
 592             pass "reject $sendthis"
 593             return 1
 594         }
 595         -re "Invalid syntax in expression.*$gdb_prompt $" {
 596             pass "reject $sendthis"
 597             return 1
 598         }
 599         -re "Junk after end of expression.*$gdb_prompt $" {
 600             pass "reject $sendthis"
 601             return 1
 602         }
 603         -re "Invalid number.*$gdb_prompt $" {
 604             pass "reject $sendthis"
 605             return 1
 606         }
 607         -re "Invalid character constant.*$gdb_prompt $" {
 608             pass "reject $sendthis"
 609             return 1
 610         }
 611         -re "No symbol table is loaded.*$gdb_prompt $" {
 612             pass "reject $sendthis"
 613             return 1
 614         }
 615         -re "No symbol .* in current context.*$gdb_prompt $" {
 616             pass "reject $sendthis"
 617             return 1
 618         }
 619         -re "Unmatched single quote.*$gdb_prompt $" {
 620             pass "reject $sendthis"
 621             return 1
 622         }
 623         -re "A character constant must contain at least one character.*$gdb_prompt $" {
 624             pass "reject $sendthis"
 625             return 1
 626         }
 627         -re "$expectthis.*$gdb_prompt $" {
 628             pass "reject $sendthis"
 629             return 1
 630         }
 631         -re ".*$gdb_prompt $" {
 632             fail "reject $sendthis"
 633             return 1
 634         }
 635         default {
 636             fail "reject $sendthis (eof or timeout)"
 637             return 0
 638         }
 639     }
 640 }
 641 \f
 642 # Given an input string, adds backslashes as needed to create a
 643 # regexp that will match the string.
 644
 645 proc string_to_regexp {str} {
 646     set result $str
 647     regsub -all {[]*+.|()^$\[]} $str {\\&} result
 648     return $result
 649 }
 650
 651 # Same as gdb_test, but the second parameter is not a regexp,
 652 # but a string that must match exactly.
 653
 654 proc gdb_test_exact { args } {
 655     upvar timeout timeout
 656
 657     set command [lindex $args 0]
 658
 659     # This applies a special meaning to a null string pattern.  Without
 660     # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
 661     # messages from commands that should have no output except a new
 662     # prompt.  With this, only results of a null string will match a null
 663     # string pattern.
 664
 665     set pattern [lindex $args 1]
 666     if [string match $pattern ""] {
 667         set pattern [string_to_regexp [lindex $args 0]]
 668     } else {
 669         set pattern [string_to_regexp [lindex $args 1]]
 670     }
 671
 672     # It is most natural to write the pattern argument with only
 673     # embedded \n's, especially if you are trying to avoid Tcl quoting
 674     # problems.  But gdb_expect really wants to see \r\n in patterns.  So
 675     # transform the pattern here.  First transform \r\n back to \n, in
 676     # case some users of gdb_test_exact already do the right thing.
 677     regsub -all "\r\n" $pattern "\n" pattern
 678     regsub -all "\n" $pattern "\r\n" pattern
 679     if [llength $args]==3 then {
 680         set message [lindex $args 2]
 681     } else {
 682         set message $command
 683     }
 684
 685     return [gdb_test $command $pattern $message]
 686 }
 687 \f
 688 proc gdb_reinitialize_dir { subdir } {
 689     global gdb_prompt
 690
 691     if [is_remote host] {
 692         return "";
 693     }
 694     send_gdb "dir\n"
 695     gdb_expect 60 {
 696         -re "Reinitialize source path to empty.*y or n. " {
 697             send_gdb "y\n"
 698             gdb_expect 60 {
 699                 -re "Source directories searched.*$gdb_prompt $" {
 700                     send_gdb "dir $subdir\n"
 701                     gdb_expect 60 {
 702                         -re "Source directories searched.*$gdb_prompt $" {
 703                             verbose "Dir set to $subdir"
 704                         }
 705                         -re "$gdb_prompt $" {
 706                             perror "Dir \"$subdir\" failed."
 707                         }
 708                     }
 709                 }
 710                 -re "$gdb_prompt $" {
 711                     perror "Dir \"$subdir\" failed."
 712                 }
 713             }
 714         }
 715         -re "$gdb_prompt $" {
 716             perror "Dir \"$subdir\" failed."
 717         }
 718     }
 719 }
 720
 721 #
 722 # gdb_exit -- exit the GDB, killing the target program if necessary
 723 #
 724 proc default_gdb_exit {} {
 725     global GDB
 726     global GDBFLAGS
 727     global verbose
 728     global gdb_spawn_id;
 729
 730     gdb_stop_suppressing_tests;
 731
 732     if ![info exists gdb_spawn_id] {
 733         return;
 734     }
 735
 736     verbose "Quitting $GDB $GDBFLAGS"
 737
 738     if { [is_remote host] && [board_info host exists fileid] } {
 739         send_gdb "quit\n";
 740         gdb_expect 10 {
 741             -re "y or n" {
 742                 send_gdb "y\n";
 743                 exp_continue;
 744             }
 745             -re "DOSEXIT code" { }
 746             default { }
 747         }
 748     }
 749
 750     if ![is_remote host] {
 751         remote_close host;
 752     }
 753     unset gdb_spawn_id
 754 }
 755
 756 #
 757 # load a file into the debugger.
 758 # return a -1 if anything goes wrong.
 759 #
 760 proc gdb_file_cmd { arg } {
 761     global verbose
 762     global loadpath
 763     global loadfile
 764     global GDB
 765     global gdb_prompt
 766     upvar timeout timeout
 767
 768     if [is_remote host] {
 769         set arg [remote_download host $arg];
 770         if { $arg == "" } {
 771             error "download failed"
 772             return -1;
 773         }
 774     }
 775
 776     send_gdb "file $arg\n"
 777     gdb_expect 120 {
 778         -re "Reading symbols from.*done.*$gdb_prompt $" {
 779             verbose "\t\tLoaded $arg into the $GDB"
 780             return 0
 781         }
 782         -re "has no symbol-table.*$gdb_prompt $" {
 783             perror "$arg wasn't compiled with \"-g\""
 784             return -1
 785         }
 786         -re "A program is being debugged already.*Kill it.*y or n. $" {
 787             send_gdb "y\n"
 788                 verbose "\t\tKilling previous program being debugged"
 789             exp_continue
 790         }
 791         -re "Load new symbol table from \".*\".*y or n. $" {
 792             send_gdb "y\n"
 793             gdb_expect 120 {
 794                 -re "Reading symbols from.*done.*$gdb_prompt $" {
 795                     verbose "\t\tLoaded $arg with new symbol table into $GDB"
 796                     return 0
 797                 }
 798                 timeout {
 799                     perror "(timeout) Couldn't load $arg, other program already loaded."
 800                     return -1
 801                 }
 802             }
 803         }
 804         -re "No such file or directory.*$gdb_prompt $" {
 805             perror "($arg) No such file or directory\n"
 806             return -1
 807         }
 808         -re "$gdb_prompt $" {
 809             perror "couldn't load $arg into $GDB."
 810             return -1
 811             }
 812         timeout {
 813             perror "couldn't load $arg into $GDB (timed out)."
 814             return -1
 815         }
 816         eof {
 817             # This is an attempt to detect a core dump, but seems not to
 818             # work.  Perhaps we need to match .* followed by eof, in which
 819             # gdb_expect does not seem to have a way to do that.
 820             perror "couldn't load $arg into $GDB (end of file)."
 821             return -1
 822         }
 823     }
 824 }
 825
 826 #
 827 # start gdb -- start gdb running, default procedure
 828 #
 829 # When running over NFS, particularly if running many simultaneous
 830 # tests on different hosts all using the same server, things can
 831 # get really slow.  Give gdb at least 3 minutes to start up.
 832 #
 833 proc default_gdb_start { } {
 834     global verbose
 835     global GDB
 836     global GDBFLAGS
 837     global gdb_prompt
 838     global timeout
 839     global gdb_spawn_id;
 840
 841     gdb_stop_suppressing_tests;
 842
 843     verbose "Spawning $GDB -nw $GDBFLAGS"
 844
 845     if [info exists gdb_spawn_id] {
 846         return 0;
 847     }
 848
 849     if ![is_remote host] {
 850         if { [which $GDB] == 0 } then {
 851             perror "$GDB does not exist."
 852             exit 1
 853         }
 854     }
 855     set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"];
 856     if { $res < 0 || $res == "" } {
 857         perror "Spawning $GDB failed."
 858         return 1;
 859     }
 860     gdb_expect 360 {
 861         -re "\[\r\n\]$gdb_prompt $" {
 862             verbose "GDB initialized."
 863         }
 864         -re "$gdb_prompt $"     {
 865             perror "GDB never initialized."
 866             return -1
 867         }
 868         timeout {
 869             perror "(timeout) GDB never initialized after 10 seconds."
 870             remote_close host;
 871             return -1
 872         }
 873     }
 874     set gdb_spawn_id -1;
 875     # force the height to "unlimited", so no pagers get used
 876
 877     send_gdb "set height 0\n"
 878     gdb_expect 10 {
 879         -re "$gdb_prompt $" {
 880             verbose "Setting height to 0." 2
 881         }
 882         timeout {
 883             warning "Couldn't set the height to 0"
 884         }
 885     }
 886     # force the width to "unlimited", so no wraparound occurs
 887     send_gdb "set width 0\n"
 888     gdb_expect 10 {
 889         -re "$gdb_prompt $" {
 890             verbose "Setting width to 0." 2
 891         }
 892         timeout {
 893             warning "Couldn't set the width to 0."
 894         }
 895     }
 896     return 0;
 897 }
 898
 899 # Return a 1 for configurations for which we don't even want to try to
 900 # test C++.
 901
 902 proc skip_cplus_tests {} {
 903     if { [istarget "d10v-*-*"] } {
 904         return 1
 905     }
 906     if { [istarget "h8300-*-*"] } {
 907         return 1
 908     }
 909     return 0
 910 }
 911
 912 # Skip all the tests in the file if you are not on an hppa running
 913 # hpux target.
 914
 915 proc skip_hp_tests {} {
 916     eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ]
 917     verbose "Skip hp tests is $skip_hp"
 918     return $skip_hp
 919 }
 920
 921 proc get_compiler_info {binfile args} {
 922     # Create and source the file that provides information about the compiler
 923     # used to compile the test case.
 924     # Compiler_type can be null or c++. If null we assume c.
 925     global srcdir
 926     global subdir
 927     # These two come from compiler.c.
 928     global signed_keyword_not_used
 929     global gcc_compiled
 930
 931     if {![istarget "hppa*-*-hpux*"] && ![istarget "mips*-*-irix*"]} {
 932         if { [llength $args] > 0 } {
 933             if {$args == "c++"} {
 934                 if { [gdb_compile "${srcdir}/lib/compiler.cc" "${binfile}.ci" preprocess {}] != "" } {
 935                     perror "Couldn't make ${binfile}.ci file"
 936                     return 1;
 937                 }
 938             }
 939         } else {
 940             if { [gdb_compile "${srcdir}/lib/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
 941                 perror "Couldn't make ${binfile}.ci file"
 942                 return 1;
 943             }
 944         }
 945     } else {
 946         if { [llength $args] > 0 } {
 947             if {$args == "c++"} {
 948                 if { [eval gdb_preprocess \
 949                         [list "${srcdir}/lib/compiler.cc" "${binfile}.ci"] \
 950                         $args] != "" } {
 951                     perror "Couldn't make ${binfile}.ci file"
 952                     return 1;
 953                 }
 954             }
 955         } elseif { $args != "f77" } {
 956             if { [eval gdb_preprocess \
 957                     [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \
 958                     $args] != "" } {
 959                 perror "Couldn't make ${binfile}.ci file"
 960                 return 1;
 961             }
 962         }
 963     }
 964
 965     uplevel \#0 { set gcc_compiled 0 }
 966
 967     if { [llength $args] == 0 || $args != "f77" } {
 968         source ${binfile}.ci
 969     }
 970
 971     # Most compilers will evaluate comparisons and other boolean
 972     # operations to 0 or 1.
 973     uplevel \#0 { set true 1 }
 974     uplevel \#0 { set false 0 }
 975
 976     uplevel \#0 { set hp_cc_compiler 0 }
 977     uplevel \#0 { set hp_aCC_compiler 0 }
 978     uplevel \#0 { set hp_f77_compiler 0 }
 979     uplevel \#0 { set hp_f90_compiler 0 }
 980     if { !$gcc_compiled && [istarget "hppa*-*-hpux*"] } {
 981         # Check for the HP compilers
 982         set compiler [lindex [split [get_compiler $args] " "] 0]
 983         catch "exec what $compiler" output
 984         if [regexp ".*HP aC\\+\\+.*" $output] {
 985             uplevel \#0 { set hp_aCC_compiler 1 }
 986             # Use of aCC results in boolean results being displayed as
 987             # "true" or "false"
 988             uplevel \#0 { set true true }
 989             uplevel \#0 { set false false }
 990         } elseif [regexp ".*HP C Compiler.*" $output] {
 991             uplevel \#0 { set hp_cc_compiler 1 }
 992         } elseif [regexp ".*HP-UX f77.*" $output] {
 993             uplevel \#0 { set hp_f77_compiler 1 }
 994         } elseif [regexp ".*HP-UX f90.*" $output] {
 995             uplevel \#0 { set hp_f90_compiler 1 }
 996         }
 997     }
 998
 999     return 0;
1000 }
1001
1002 proc get_compiler {args} {
1003     global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET
1004
1005     if { [llength $args] == 0
1006          || ([llength $args] == 1 && [lindex $args 0] == "") } {
1007         set which_compiler "c"
1008     } else {
1009         if { $args =="c++" } {
1010             set which_compiler "c++"
1011         } elseif { $args =="f77" } {
1012             set which_compiler "f77"
1013         } else {
1014             perror "Unknown compiler type supplied to gdb_preprocess"
1015             return ""
1016         }
1017     }
1018
1019     if [info exists CC_FOR_TARGET] {
1020         if {$which_compiler == "c"} {
1021             set compiler $CC_FOR_TARGET
1022         }
1023     }
1024
1025     if [info exists CXX_FOR_TARGET] {
1026         if {$which_compiler == "c++"} {
1027             set compiler $CXX_FOR_TARGET
1028         }
1029     }
1030
1031     if [info exists F77_FOR_TARGET] {
1032         if {$which_compiler == "f77"} {
1033             set compiler $F77_FOR_TARGET
1034         }
1035     }
1036
1037     if { ![info exists compiler] } {
1038         if { $which_compiler == "c" } {
1039             if {[info exists CC]} {
1040                 set compiler $CC
1041             }
1042         }
1043         if { $which_compiler == "c++" } {
1044             if {[info exists CXX]} {
1045                 set compiler $CXX
1046             }
1047         }
1048         if {![info exists compiler]} {
1049             set compiler [board_info [target_info name] compiler];
1050             if { $compiler == "" } {
1051                 perror "get_compiler: No compiler found"
1052                 return ""
1053             }
1054         }
1055     }
1056
1057     return $compiler
1058 }
1059
1060 proc gdb_preprocess {source dest args} {
1061     set compiler [get_compiler "$args"]
1062     if { $compiler == "" } {
1063         return 1
1064     }
1065
1066     set cmdline "$compiler -E $source > $dest"
1067
1068     verbose "Invoking $compiler -E $source > $dest"
1069     verbose -log "Executing on local host: $cmdline" 2
1070     set status [catch "exec ${cmdline}" exec_output]
1071
1072     set result [prune_warnings $exec_output]
1073     regsub "\[\r\n\]*$" "$result" "" result;
1074     regsub "^\[\r\n\]*" "$result" "" result;
1075     if { $result != "" } {
1076         clone_output "gdb compile failed, $result"
1077     }
1078     return $result;
1079 }
1080
1081 set gdb_wrapper_initialized 0
1082
1083 proc gdb_wrapper_init { args } {
1084     global gdb_wrapper_initialized;
1085     global gdb_wrapper_file;
1086     global gdb_wrapper_flags;
1087
1088     if { $gdb_wrapper_initialized == 1 } { return; }
1089
1090     if {[target_info exists needs_status_wrapper] && \
1091             [target_info needs_status_wrapper] != "0"} {
1092         set result [build_wrapper "testglue.o"];
1093         if { $result != "" } {
1094             set gdb_wrapper_file [lindex $result 0];
1095             set gdb_wrapper_flags [lindex $result 1];
1096         } else {
1097             warning "Status wrapper failed to build."
1098         }
1099     }
1100     set gdb_wrapper_initialized 1
1101 }
1102
1103 proc gdb_compile {source dest type options} {
1104     global GDB_TESTCASE_OPTIONS;
1105     global gdb_wrapper_file;
1106     global gdb_wrapper_flags;
1107     global gdb_wrapper_initialized;
1108
1109     if [target_info exists gdb_stub] {
1110         set options2 { "additional_flags=-Dusestubs" }
1111         lappend options "libs=[target_info gdb_stub]";
1112         set options [concat $options2 $options]
1113     }
1114     if [target_info exists is_vxworks] {
1115         set options2 { "additional_flags=-Dvxworks" }
1116         lappend options "libs=[target_info gdb_stub]";
1117         set options [concat $options2 $options]
1118     }
1119     if [info exists GDB_TESTCASE_OPTIONS] {
1120         lappend options "additional_flags=$GDB_TESTCASE_OPTIONS";
1121     }
1122     verbose "options are $options"
1123     verbose "source is $source $dest $type $options"
1124
1125     if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init }
1126
1127     if {[target_info exists needs_status_wrapper] && \
1128             [target_info needs_status_wrapper] != "0" && \
1129             [info exists gdb_wrapper_file]} {
1130         lappend options "libs=${gdb_wrapper_file}"
1131         lappend options "ldflags=${gdb_wrapper_flags}"
1132     }
1133
1134     set result [target_compile $source $dest $type $options];
1135     regsub "\[\r\n\]*$" "$result" "" result;
1136     regsub "^\[\r\n\]*" "$result" "" result;
1137     if { $result != "" } {
1138         clone_output "gdb compile failed, $result"
1139     }
1140     return $result;
1141 }
1142
1143
1144 # This is just like gdb_compile, above, except that it tries compiling
1145 # against several different thread libraries, to see which one this
1146 # system has.
1147 proc gdb_compile_pthreads {source dest type options} {
1148     set built_binfile 0
1149     set why_msg "unrecognized error"
1150     foreach lib {-lpthreads -lpthread -lthread} {
1151         # This kind of wipes out whatever libs the caller may have
1152         # set.  Or maybe theirs will override ours.  How infelicitous.
1153         set options_with_lib [concat $options [list libs=$lib]]
1154         set ccout [gdb_compile $source $dest $type $options_with_lib]
1155         switch -regexp -- $ccout {
1156             ".*no posix threads support.*" {
1157                 set why_msg "missing threads include file"
1158                 break
1159             }
1160             ".*cannot open -lpthread.*" {
1161                 set why_msg "missing runtime threads library"
1162             }
1163             ".*Can't find library for -lpthread.*" {
1164                 set why_msg "missing runtime threads library"
1165             }
1166             {^$} {
1167                 pass "successfully compiled posix threads test case"
1168                 set built_binfile 1
1169                 break
1170             }
1171         }
1172     }
1173     if {!$built_binfile} {
1174         unsupported "Couldn't compile $source: ${why_msg}"
1175         return -1
1176     }
1177 }
1178
1179 proc send_gdb { string } {
1180     global suppress_flag;
1181     if { $suppress_flag } {
1182         return "suppressed";
1183     }
1184     return [remote_send host "$string"];
1185 }
1186
1187 #
1188 #
1189
1190 proc gdb_expect { args } {
1191     if { [llength $args] == 2  && [lindex $args 0] != "-re" } {
1192         set gtimeout [lindex $args 0];
1193         set expcode [list [lindex $args 1]];
1194     } else {
1195         upvar timeout timeout;
1196
1197         set expcode $args;
1198         if [target_info exists gdb,timeout] {
1199             if [info exists timeout] {
1200                 if { $timeout < [target_info gdb,timeout] } {
1201                     set gtimeout [target_info gdb,timeout];
1202                 } else {
1203                     set gtimeout $timeout;
1204                 }
1205             } else {
1206                 set gtimeout [target_info gdb,timeout];
1207             }
1208         }
1209
1210         if ![info exists gtimeout] {
1211             global timeout;
1212             if [info exists timeout] {
1213                 set gtimeout $timeout;
1214             } else {
1215                 # Eeeeew.
1216                 set gtimeout 60;
1217             }
1218         }
1219     }
1220     global suppress_flag;
1221     global remote_suppress_flag;
1222     if [info exists remote_suppress_flag] {
1223         set old_val $remote_suppress_flag;
1224     }
1225     if [info exists suppress_flag] {
1226         if { $suppress_flag } {
1227             set remote_suppress_flag 1;
1228         }
1229     }
1230     set code [catch \
1231         {uplevel remote_expect host $gtimeout $expcode} string];
1232     if [info exists old_val] {
1233         set remote_suppress_flag $old_val;
1234     } else {
1235         if [info exists remote_suppress_flag] {
1236             unset remote_suppress_flag;
1237         }
1238     }
1239
1240     if {$code == 1} {
1241         global errorInfo errorCode;
1242
1243         return -code error -errorinfo $errorInfo -errorcode $errorCode $string
1244     } elseif {$code == 2} {
1245         return -code return $string
1246     } elseif {$code == 3} {
1247         return
1248     } elseif {$code > 4} {
1249         return -code $code $string
1250     }
1251 }
1252
1253 # gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs
1254 #
1255 # Check for long sequence of output by parts.
1256 # MESSAGE: is the test message to be printed with the test success/fail.
1257 # SENTINEL: Is the terminal pattern indicating that output has finished.
1258 # LIST: is the sequence of outputs to match.
1259 # If the sentinel is recognized early, it is considered an error.
1260 #
1261 # Returns:
1262 #    1 if the test failed,
1263 #    0 if the test passes,
1264 #   -1 if there was an internal error.
1265 #
1266 proc gdb_expect_list {test sentinel list} {
1267     global gdb_prompt
1268     global suppress_flag
1269     set index 0
1270     set ok 1
1271     if { $suppress_flag } {
1272         set ok 0
1273         unresolved "${test}"
1274     }
1275     while { ${index} < [llength ${list}] } {
1276         set pattern [lindex ${list} ${index}]
1277         set index [expr ${index} + 1]
1278         if { ${index} == [llength ${list}] } {
1279             if { ${ok} } {
1280                 gdb_expect {
1281                     -re "${pattern}${sentinel}" {
1282                         # pass "${test}, pattern ${index} + sentinel"
1283                     }
1284                     -re "${sentinel}" {
1285                         fail "${test} (pattern ${index} + sentinel)"
1286                         set ok 0
1287                     }
1288                     timeout {
1289                         fail "${test} (pattern ${index} + sentinel) (timeout)"
1290                         set ok 0
1291                     }
1292                 }
1293             } else {
1294                 # unresolved "${test}, pattern ${index} + sentinel"
1295             }
1296         } else {
1297             if { ${ok} } {
1298                 gdb_expect {
1299                     -re "${pattern}" {
1300                         # pass "${test}, pattern ${index}"
1301                     }
1302                     -re "${sentinel}" {
1303                         fail "${test} (pattern ${index})"
1304                         set ok 0
1305                     }
1306                     timeout {
1307                         fail "${test} (pattern ${index}) (timeout)"
1308                         set ok 0
1309                     }
1310                 }
1311             } else {
1312                 # unresolved "${test}, pattern ${index}"
1313             }
1314         }
1315     }
1316     if { ${ok} } {
1317         pass "${test}"
1318         return 0
1319     } else {
1320         return 1
1321     }
1322 }
1323
1324 #
1325 #
1326 proc gdb_suppress_entire_file { reason } {
1327     global suppress_flag;
1328
1329     warning "$reason\n";
1330     set suppress_flag -1;
1331 }
1332
1333 #
1334 # Set suppress_flag, which will cause all subsequent calls to send_gdb and
1335 # gdb_expect to fail immediately (until the next call to
1336 # gdb_stop_suppressing_tests).
1337 #
1338 proc gdb_suppress_tests { args } {
1339     global suppress_flag;
1340
1341     return;  # fnf - disable pending review of results where
1342              # testsuite ran better without this
1343     incr suppress_flag;
1344
1345     if { $suppress_flag == 1 } {
1346         if { [llength $args] > 0 } {
1347             warning "[lindex $args 0]\n";
1348         } else {
1349             warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n";
1350         }
1351     }
1352 }
1353
1354 #
1355 # Clear suppress_flag.
1356 #
1357 proc gdb_stop_suppressing_tests { } {
1358     global suppress_flag;
1359
1360     if [info exists suppress_flag] {
1361         if { $suppress_flag > 0 } {
1362             set suppress_flag 0;
1363             clone_output "Tests restarted.\n";
1364         }
1365     } else {
1366         set suppress_flag 0;
1367     }
1368 }
1369
1370 proc gdb_clear_suppressed { } {
1371     global suppress_flag;
1372
1373     set suppress_flag 0;
1374 }
1375
1376 proc gdb_start { } {
1377     default_gdb_start
1378 }
1379
1380 proc gdb_exit { } {
1381     catch default_gdb_exit
1382 }
1383
1384 #
1385 # gdb_load -- load a file into the debugger.
1386 #             return a -1 if anything goes wrong.
1387 #
1388 proc gdb_load { arg } {
1389     return [gdb_file_cmd $arg]
1390 }
1391
1392 proc gdb_continue { function } {
1393     global decimal
1394
1395     return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
1396 }
1397
1398 proc default_gdb_init { args } {
1399     global gdb_wrapper_initialized
1400
1401     gdb_clear_suppressed;
1402
1403     # Make sure that the wrapper is rebuilt
1404     # with the appropriate multilib option.
1405     set gdb_wrapper_initialized 0
1406
1407     # Uh, this is lame. Really, really, really lame. But there's this *one*
1408     # testcase that will fail in random places if we don't increase this.
1409     match_max -d 20000
1410
1411     # We want to add the name of the TCL testcase to the PASS/FAIL messages.
1412     if { [llength $args] > 0 } {
1413         global pf_prefix
1414
1415         set file [lindex $args 0];
1416
1417         set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:";
1418     }
1419     global gdb_prompt;
1420     if [target_info exists gdb_prompt] {
1421         set gdb_prompt [target_info gdb_prompt];
1422     } else {
1423         set gdb_prompt "\\(gdb\\)"
1424     }
1425 }
1426
1427 proc gdb_init { args } {
1428     return [eval default_gdb_init $args];
1429 }
1430
1431 proc gdb_finish { } {
1432     gdb_exit;
1433 }
1434
1435 global debug_format
1436 set debug_format "unknown"
1437
1438 # Run the gdb command "info source" and extract the debugging format
1439 # information from the output and save it in debug_format.
1440
1441 proc get_debug_format { } {
1442     global gdb_prompt
1443     global verbose
1444     global expect_out
1445     global debug_format
1446
1447     set debug_format "unknown"
1448     send_gdb "info source\n"
1449     gdb_expect 10 {
1450         -re "Compiled with (.*) debugging format.\r\n.*$gdb_prompt $" {
1451             set debug_format $expect_out(1,string)
1452             verbose "debug format is $debug_format"
1453             return 1;
1454         }
1455         -re "No current source file.\r\n$gdb_prompt $" {
1456             perror "get_debug_format used when no current source file"
1457             return 0;
1458         }
1459         -re "$gdb_prompt $" {
1460             warning "couldn't check debug format (no valid response)."
1461             return 1;
1462         }
1463         timeout {
1464             warning "couldn't check debug format (timed out)."
1465             return 1;
1466         }
1467     }
1468 }
1469
1470 # Return true if FORMAT matches the debug format the current test was
1471 # compiled with.  FORMAT is a shell-style globbing pattern; it can use
1472 # `*', `[...]', and so on.
1473 #
1474 # This function depends on variables set by `get_debug_format', above.
1475
1476 proc test_debug_format {format} {
1477     global debug_format
1478
1479     return [expr [string match $format $debug_format] != 0]
1480 }
1481
1482 # Like setup_xfail, but takes the name of a debug format (DWARF 1,
1483 # COFF, stabs, etc).  If that format matches the format that the
1484 # current test was compiled with, then the next test is expected to
1485 # fail for any target.  Returns 1 if the next test or set of tests is
1486 # expected to fail, 0 otherwise (or if it is unknown).  Must have
1487 # previously called get_debug_format.
1488 proc setup_xfail_format { format } {
1489     set ret [test_debug_format $format];
1490
1491     if {$ret} then {
1492         setup_xfail "*-*-*"
1493     }
1494     return $ret;
1495 }
1496
1497 proc gdb_step_for_stub { } {
1498     global gdb_prompt;
1499
1500     if ![target_info exists gdb,use_breakpoint_for_stub] {
1501         if [target_info exists gdb_stub_step_command] {
1502             set command [target_info gdb_stub_step_command];
1503         } else {
1504             set command "step";
1505         }
1506         send_gdb "${command}\n";
1507         set tries 0;
1508         gdb_expect 60 {
1509             -re "(main.* at |.*in .*start).*$gdb_prompt" {
1510                 return;
1511             }
1512             -re ".*$gdb_prompt" {
1513                 incr tries;
1514                 if { $tries == 5 } {
1515                     fail "stepping out of breakpoint function";
1516                     return;
1517                 }
1518                 send_gdb "${command}\n";
1519                 exp_continue;
1520             }
1521             default {
1522                 fail "stepping out of breakpoint function";
1523                 return;
1524             }
1525         }
1526     }
1527     send_gdb "where\n";
1528     gdb_expect {
1529         -re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" {
1530             set file $expect_out(1,string);
1531             set linenum [expr $expect_out(2,string) + 1];
1532             set breakplace "${file}:${linenum}";
1533         }
1534         default {}
1535     }
1536     send_gdb "break ${breakplace}\n";
1537     gdb_expect 60 {
1538         -re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" {
1539             set breakpoint $expect_out(1,string);
1540         }
1541         -re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" {
1542             set breakpoint $expect_out(1,string);
1543         }
1544         default {}
1545     }
1546     send_gdb "continue\n";
1547     gdb_expect 60 {
1548         -re "Breakpoint ${breakpoint},.*$gdb_prompt" {
1549             gdb_test "delete $breakpoint" ".*" "";
1550             return;
1551         }
1552         default {}
1553     }
1554 }
1555
1556 ### gdb_get_line_number TEXT [FILE]
1557 ###
1558 ### Search the source file FILE, and return the line number of a line
1559 ### containing TEXT.  Use this function instead of hard-coding line
1560 ### numbers into your test script.
1561 ###
1562 ### Specifically, this function uses GDB's "search" command to search
1563 ### FILE for the first line containing TEXT, and returns its line
1564 ### number.  Thus, FILE must be a source file, compiled into the
1565 ### executable you are running.  If omitted, FILE defaults to the
1566 ### value of the global variable `srcfile'; most test scripts set
1567 ### `srcfile' appropriately at the top anyway.
1568 ###
1569 ### Use this function to keep your test scripts independent of the
1570 ### exact line numbering of the source file.  Don't write:
1571 ###
1572 ###   send_gdb "break 20"
1573 ###
1574 ### This means that if anyone ever edits your test's source file,
1575 ### your test could break.  Instead, put a comment like this on the
1576 ### source file line you want to break at:
1577 ###
1578 ###   /* breakpoint spot: frotz.exp: test name */
1579 ###
1580 ### and then write, in your test script (which we assume is named
1581 ### frotz.exp):
1582 ###
1583 ###   send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n"
1584 ###
1585 ### (Yes, Tcl knows how to handle the nested quotes and brackets.
1586 ### Try this:
1587 ###     $ tclsh
1588 ###     % puts "foo [lindex "bar baz" 1]"
1589 ###     foo baz
1590 ###     %
1591 ### Tcl is quite clever, for a little stringy language.)
1592
1593 proc gdb_get_line_number {text {file /omitted/}} {
1594     global gdb_prompt;
1595     global srcfile;
1596
1597     if {! [string compare $file /omitted/]} {
1598         set file $srcfile
1599     }
1600
1601     set result -1;
1602     gdb_test "list ${file}:1,1" ".*" ""
1603     send_gdb "search ${text}\n"
1604     gdb_expect {
1605         -re "\[\r\n\]+(\[0-9\]+)\[ \t\].*${text}.*$gdb_prompt $" {
1606             set result $expect_out(1,string)
1607         }
1608         -re ".*$gdb_prompt $" {
1609             fail "find line number containing \"${text}\""
1610         }
1611         timeout {
1612             fail "find line number containing \"${text}\" (timeout)"
1613         }
1614     }
1615     return $result;
1616 }
1617
1618 # gdb_continue_to_end:
1619 #       The case where the target uses stubs has to be handled specially. If a
1620 #       stub is used, we set a breakpoint at exit because we cannot rely on
1621 #       exit() behavior of a remote target.
1622 #
1623 # mssg is the error message that gets printed.
1624
1625 proc gdb_continue_to_end {mssg} {
1626   if [target_info exists use_gdb_stub] {
1627     if {![gdb_breakpoint "exit"]} {
1628       return 0
1629     }
1630     gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \
1631       "continue until exit at $mssg"
1632   } else {
1633     # Continue until we exit.  Should not stop again.
1634     # Don't bother to check the output of the program, that may be
1635     # extremely tough for some remote systems.
1636     gdb_test "continue"\
1637       "Continuing.\[\r\n0-9\]+(... EXIT code 0\[\r\n\]+|Program exited normally\\.).*"\
1638       "continue until exit at $mssg"
1639   }
1640 }
1641
1642 proc rerun_to_main {} {
1643   global gdb_prompt
1644
1645   if [target_info exists use_gdb_stub] {
1646     gdb_run_cmd
1647     gdb_expect {
1648       -re ".*Breakpoint .*main .*$gdb_prompt $"\
1649               {pass "rerun to main" ; return 0}
1650       -re "$gdb_prompt $"\
1651               {fail "rerun to main" ; return 0}
1652       timeout {fail "(timeout) rerun to main" ; return 0}
1653     }
1654   } else {
1655     send_gdb "run\n"
1656     gdb_expect {
1657       -re "The program .* has been started already.*y or n. $" {
1658           send_gdb "y\n"
1659           exp_continue
1660       }
1661       -re "Starting program.*$gdb_prompt $"\
1662               {pass "rerun to main" ; return 0}
1663       -re "$gdb_prompt $"\
1664               {fail "rerun to main" ; return 0}
1665       timeout {fail "(timeout) rerun to main" ; return 0}
1666     }
1667   }
1668 }
1669
1670 # Print a message and return true if a test should be skipped
1671 # due to lack of floating point suport.
1672
1673 proc gdb_skip_float_test { msg } {
1674     if [target_info exists gdb,skip_float_tests] {
1675         verbose "Skipping test '$msg': no float tests.";
1676         return 1;
1677     }
1678     return 0;
1679 }
1680
1681 # Print a message and return true if a test should be skipped
1682 # due to lack of stdio support.
1683
1684 proc gdb_skip_stdio_test { msg } {
1685     if [target_info exists gdb,noinferiorio] {
1686         verbose "Skipping test '$msg': no inferior i/o.";
1687         return 1;
1688     }
1689     return 0;
1690 }
1691
1692 proc gdb_skip_bogus_test { msg } {
1693     return 0;
1694 }
1695