gdb/testsuite/lib/gdb.exp

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