gdb/testsuite/lib/gdb.exp

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