1# Copyright 1992-2013 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 3 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, see <http://www.gnu.org/licenses/>. 15 16# This file was written by Fred Fish. (fnf@cygnus.com) 17 18# Generic gdb subroutines that should work for any target. If these 19# need to be modified for any target, it can be done with a variable 20# or by passing arguments. 21 22if {$tool == ""} { 23 # Tests would fail, logs on get_compiler_info() would be missing. 24 send_error "`site.exp' not found, run `make site.exp'!\n" 25 exit 2 26} 27 28load_lib libgloss.exp 29 30global GDB 31 32if [info exists TOOL_EXECUTABLE] { 33 set GDB $TOOL_EXECUTABLE; 34} 35if ![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} 42verbose "using GDB = $GDB" 2 43 44# GDBFLAGS is available for the user to set on the command line. 45# E.g. make check RUNTESTFLAGS=GDBFLAGS=mumble 46# Testcases may use it to add additional flags, but they must: 47# - append new flags, not overwrite 48# - restore the original value when done 49global GDBFLAGS 50if ![info exists GDBFLAGS] { 51 set GDBFLAGS "" 52} 53verbose "using GDBFLAGS = $GDBFLAGS" 2 54 55# Make the build data directory available to tests. 56set BUILD_DATA_DIRECTORY "[pwd]/../data-directory" 57 58# INTERNAL_GDBFLAGS contains flags that the testsuite requires. 59global INTERNAL_GDBFLAGS 60if ![info exists INTERNAL_GDBFLAGS] { 61 set INTERNAL_GDBFLAGS "-nw -nx -data-directory $BUILD_DATA_DIRECTORY" 62} 63 64# The variable gdb_prompt is a regexp which matches the gdb prompt. 65# Set it if it is not already set. 66global gdb_prompt 67if ![info exists gdb_prompt] then { 68 set gdb_prompt "\[(\]gdb\[)\]" 69} 70 71# The variable fullname_syntax_POSIX is a regexp which matches a POSIX 72# absolute path ie. /foo/ 73set fullname_syntax_POSIX {/[^\n]*/} 74# The variable fullname_syntax_UNC is a regexp which matches a Windows 75# UNC path ie. \\D\foo\ 76set fullname_syntax_UNC {\\\\[^\\]+\\[^\n]+\\} 77# The variable fullname_syntax_DOS_CASE is a regexp which matches a 78# particular DOS case that GDB most likely will output 79# ie. \foo\, but don't match \\.*\ 80set fullname_syntax_DOS_CASE {\\[^\\][^\n]*\\} 81# The variable fullname_syntax_DOS is a regexp which matches a DOS path 82# ie. a:\foo\ && a:foo\ 83set fullname_syntax_DOS {[a-zA-Z]:[^\n]*\\} 84# The variable fullname_syntax is a regexp which matches what GDB considers 85# an absolute path. It is currently debatable if the Windows style paths 86# d:foo and \abc should be considered valid as an absolute path. 87# Also, the purpse of this regexp is not to recognize a well formed 88# absolute path, but to say with certainty that a path is absolute. 89set fullname_syntax "($fullname_syntax_POSIX|$fullname_syntax_UNC|$fullname_syntax_DOS_CASE|$fullname_syntax_DOS)" 90 91# Needed for some tests under Cygwin. 92global EXEEXT 93global env 94 95if ![info exists env(EXEEXT)] { 96 set EXEEXT "" 97} else { 98 set EXEEXT $env(EXEEXT) 99} 100 101set octal "\[0-7\]+" 102 103set inferior_exited_re "(\\\[Inferior \[0-9\]+ \\(.*\\) exited)" 104 105### Only procedures should come after this point. 106 107# 108# gdb_version -- extract and print the version number of GDB 109# 110proc default_gdb_version {} { 111 global GDB 112 global INTERNAL_GDBFLAGS GDBFLAGS 113 global gdb_prompt 114 set output [remote_exec host "$GDB $INTERNAL_GDBFLAGS --version"] 115 set tmp [lindex $output 1]; 116 set version "" 117 regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version 118 if ![is_remote host] { 119 clone_output "[which $GDB] version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" 120 } else { 121 clone_output "$GDB on remote host version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" 122 } 123} 124 125proc gdb_version { } { 126 return [default_gdb_version]; 127} 128 129# 130# gdb_unload -- unload a file if one is loaded 131# Return 0 on success, -1 on error. 132# 133 134proc gdb_unload {} { 135 global verbose 136 global GDB 137 global gdb_prompt 138 send_gdb "file\n" 139 gdb_expect 60 { 140 -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue } 141 -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue } 142 -re "A program is being debugged already.*Are you sure you want to change the file.*y or n. $" { 143 send_gdb "y\n" 144 exp_continue 145 } 146 -re "Discard symbol table from .*y or n.*$" { 147 send_gdb "y\n" 148 exp_continue 149 } 150 -re "$gdb_prompt $" {} 151 timeout { 152 perror "couldn't unload file in $GDB (timeout)." 153 return -1 154 } 155 } 156 return 0 157} 158 159# Many of the tests depend on setting breakpoints at various places and 160# running until that breakpoint is reached. At times, we want to start 161# with a clean-slate with respect to breakpoints, so this utility proc 162# lets us do this without duplicating this code everywhere. 163# 164 165proc delete_breakpoints {} { 166 global gdb_prompt 167 168 # we need a larger timeout value here or this thing just confuses 169 # itself. May need a better implementation if possible. - guo 170 # 171 send_gdb "delete breakpoints\n" 172 gdb_expect 100 { 173 -re "Delete all breakpoints.*y or n.*$" { 174 send_gdb "y\n"; 175 exp_continue 176 } 177 -re "$gdb_prompt $" { # This happens if there were no breakpoints 178 } 179 timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return } 180 } 181 send_gdb "info breakpoints\n" 182 gdb_expect 100 { 183 -re "No breakpoints or watchpoints..*$gdb_prompt $" {} 184 -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return } 185 -re "Delete all breakpoints.*or n.*$" { 186 send_gdb "y\n"; 187 exp_continue 188 } 189 timeout { perror "info breakpoints (timeout)" ; return } 190 } 191} 192 193# Generic run command. 194# 195# The second pattern below matches up to the first newline *only*. 196# Using ``.*$'' could swallow up output that we attempt to match 197# elsewhere. 198# 199# N.B. This function does not wait for gdb to return to the prompt, 200# that is the caller's responsibility. 201 202proc gdb_run_cmd {args} { 203 global gdb_prompt use_gdb_stub 204 205 if [target_info exists gdb_init_command] { 206 send_gdb "[target_info gdb_init_command]\n"; 207 gdb_expect 30 { 208 -re "$gdb_prompt $" { } 209 default { 210 perror "gdb_init_command for target failed"; 211 return; 212 } 213 } 214 } 215 216 if $use_gdb_stub { 217 if [target_info exists gdb,do_reload_on_run] { 218 if { [gdb_reload] != 0 } { 219 return; 220 } 221 send_gdb "continue\n"; 222 gdb_expect 60 { 223 -re "Continu\[^\r\n\]*\[\r\n\]" {} 224 default {} 225 } 226 return; 227 } 228 229 if [target_info exists gdb,start_symbol] { 230 set start [target_info gdb,start_symbol]; 231 } else { 232 set start "start"; 233 } 234 send_gdb "jump *$start\n" 235 set start_attempt 1; 236 while { $start_attempt } { 237 # Cap (re)start attempts at three to ensure that this loop 238 # always eventually fails. Don't worry about trying to be 239 # clever and not send a command when it has failed. 240 if [expr $start_attempt > 3] { 241 perror "Jump to start() failed (retry count exceeded)"; 242 return; 243 } 244 set start_attempt [expr $start_attempt + 1]; 245 gdb_expect 30 { 246 -re "Continuing at \[^\r\n\]*\[\r\n\]" { 247 set start_attempt 0; 248 } 249 -re "No symbol \"_start\" in current.*$gdb_prompt $" { 250 perror "Can't find start symbol to run in gdb_run"; 251 return; 252 } 253 -re "No symbol \"start\" in current.*$gdb_prompt $" { 254 send_gdb "jump *_start\n"; 255 } 256 -re "No symbol.*context.*$gdb_prompt $" { 257 set start_attempt 0; 258 } 259 -re "Line.* Jump anyway.*y or n. $" { 260 send_gdb "y\n" 261 } 262 -re "The program is not being run.*$gdb_prompt $" { 263 if { [gdb_reload] != 0 } { 264 return; 265 } 266 send_gdb "jump *$start\n"; 267 } 268 timeout { 269 perror "Jump to start() failed (timeout)"; 270 return 271 } 272 } 273 } 274 return 275 } 276 277 if [target_info exists gdb,do_reload_on_run] { 278 if { [gdb_reload] != 0 } { 279 return; 280 } 281 } 282 send_gdb "run $args\n" 283# This doesn't work quite right yet. 284# Use -notransfer here so that test cases (like chng-sym.exp) 285# may test for additional start-up messages. 286 gdb_expect 60 { 287 -re "The program .* has been started already.*y or n. $" { 288 send_gdb "y\n" 289 exp_continue 290 } 291 -notransfer -re "Starting program: \[^\r\n\]*" {} 292 -notransfer -re "$gdb_prompt $" { 293 # There is no more input expected. 294 } 295 } 296} 297 298# Generic start command. Return 0 if we could start the program, -1 299# if we could not. 300# 301# N.B. This function does not wait for gdb to return to the prompt, 302# that is the caller's responsibility. 303 304proc gdb_start_cmd {args} { 305 global gdb_prompt use_gdb_stub 306 307 if [target_info exists gdb_init_command] { 308 send_gdb "[target_info gdb_init_command]\n"; 309 gdb_expect 30 { 310 -re "$gdb_prompt $" { } 311 default { 312 perror "gdb_init_command for target failed"; 313 return -1; 314 } 315 } 316 } 317 318 if $use_gdb_stub { 319 return -1 320 } 321 322 send_gdb "start $args\n" 323 # Use -notransfer here so that test cases (like chng-sym.exp) 324 # may test for additional start-up messages. 325 gdb_expect 60 { 326 -re "The program .* has been started already.*y or n. $" { 327 send_gdb "y\n" 328 exp_continue 329 } 330 -notransfer -re "Starting program: \[^\r\n\]*" { 331 return 0 332 } 333 } 334 return -1 335} 336 337# Set a breakpoint at FUNCTION. If there is an additional argument it is 338# a list of options; the supported options are allow-pending, temporary, 339# message, no-message, and passfail. 340# The result is 1 for success, 0 for failure. 341# 342# Note: The handling of message vs no-message is messed up, but it's based 343# on historical usage. By default this function does not print passes, 344# only fails. 345# no-message: turns off printing of fails (and passes, but they're already off) 346# message: turns on printing of passes (and fails, but they're already on) 347 348proc gdb_breakpoint { function args } { 349 global gdb_prompt 350 global decimal 351 352 set pending_response n 353 if {[lsearch -exact $args allow-pending] != -1} { 354 set pending_response y 355 } 356 357 set break_command "break" 358 set break_message "Breakpoint" 359 if {[lsearch -exact $args temporary] != -1} { 360 set break_command "tbreak" 361 set break_message "Temporary breakpoint" 362 } 363 364 set print_pass 0 365 set print_fail 1 366 set no_message_loc [lsearch -exact $args no-message] 367 set message_loc [lsearch -exact $args message] 368 # The last one to appear in args wins. 369 if { $no_message_loc > $message_loc } { 370 set print_fail 0 371 } elseif { $message_loc > $no_message_loc } { 372 set print_pass 1 373 } 374 375 set test_name "setting breakpoint at $function" 376 377 send_gdb "$break_command $function\n" 378 # The first two regexps are what we get with -g, the third is without -g. 379 gdb_expect 30 { 380 -re "$break_message \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} 381 -re "$break_message \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} 382 -re "$break_message \[0-9\]* at .*$gdb_prompt $" {} 383 -re "$break_message \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" { 384 if {$pending_response == "n"} { 385 if { $print_fail } { 386 fail $test_name 387 } 388 return 0 389 } 390 } 391 -re "Make breakpoint pending.*y or \\\[n\\\]. $" { 392 send_gdb "$pending_response\n" 393 exp_continue 394 } 395 -re "A problem internal to GDB has been detected" { 396 if { $print_fail } { 397 fail "$test_name (GDB internal error)" 398 } 399 gdb_internal_error_resync 400 return 0 401 } 402 -re "$gdb_prompt $" { 403 if { $print_fail } { 404 fail $test_name 405 } 406 return 0 407 } 408 eof { 409 if { $print_fail } { 410 fail "$test_name (eof)" 411 } 412 return 0 413 } 414 timeout { 415 if { $print_fail } { 416 fail "$test_name (timeout)" 417 } 418 return 0 419 } 420 } 421 if { $print_pass } { 422 pass $test_name 423 } 424 return 1; 425} 426 427# Set breakpoint at function and run gdb until it breaks there. 428# Since this is the only breakpoint that will be set, if it stops 429# at a breakpoint, we will assume it is the one we want. We can't 430# just compare to "function" because it might be a fully qualified, 431# single quoted C++ function specifier. 432# 433# If there are additional arguments, pass them to gdb_breakpoint. 434# We recognize no-message/message ourselves. 435# The default is no-message. 436# no-message is messed up here, like gdb_breakpoint: to preserve 437# historical usage fails are always printed by default. 438# no-message: turns off printing of fails (and passes, but they're already off) 439# message: turns on printing of passes (and fails, but they're already on) 440 441proc runto { function args } { 442 global gdb_prompt 443 global decimal 444 445 delete_breakpoints 446 447 # Default to "no-message". 448 set args "no-message $args" 449 450 set print_pass 0 451 set print_fail 1 452 set no_message_loc [lsearch -exact $args no-message] 453 set message_loc [lsearch -exact $args message] 454 # The last one to appear in args wins. 455 if { $no_message_loc > $message_loc } { 456 set print_fail 0 457 } elseif { $message_loc > $no_message_loc } { 458 set print_pass 1 459 } 460 461 set test_name "running to $function in runto" 462 463 # We need to use eval here to pass our varargs args to gdb_breakpoint 464 # which is also a varargs function. 465 # But we also have to be careful because $function may have multiple 466 # elements, and we don't want Tcl to move the remaining elements after 467 # the first to $args. That is why $function is wrapped in {}. 468 if ![eval gdb_breakpoint {$function} $args] { 469 return 0; 470 } 471 472 gdb_run_cmd 473 474 # the "at foo.c:36" output we get with -g. 475 # the "in func" output we get without -g. 476 gdb_expect 30 { 477 -re "Break.* at .*:$decimal.*$gdb_prompt $" { 478 if { $print_pass } { 479 pass $test_name 480 } 481 return 1 482 } 483 -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { 484 if { $print_pass } { 485 pass $test_name 486 } 487 return 1 488 } 489 -re "The target does not support running in non-stop mode.\r\n$gdb_prompt $" { 490 if { $print_fail } { 491 unsupported "Non-stop mode not supported" 492 } 493 return 0 494 } 495 -re ".*A problem internal to GDB has been detected" { 496 if { $print_fail } { 497 fail "$test_name (GDB internal error)" 498 } 499 gdb_internal_error_resync 500 return 0 501 } 502 -re "$gdb_prompt $" { 503 if { $print_fail } { 504 fail $test_name 505 } 506 return 0 507 } 508 eof { 509 if { $print_fail } { 510 fail "$test_name (eof)" 511 } 512 return 0 513 } 514 timeout { 515 if { $print_fail } { 516 fail "$test_name (timeout)" 517 } 518 return 0 519 } 520 } 521 if { $print_pass } { 522 pass $test_name 523 } 524 return 1 525} 526 527# Ask gdb to run until we hit a breakpoint at main. 528# 529# N.B. This function deletes all existing breakpoints. 530# If you don't want that, use gdb_start_cmd. 531 532proc runto_main { } { 533 return [runto main no-message] 534} 535 536### Continue, and expect to hit a breakpoint. 537### Report a pass or fail, depending on whether it seems to have 538### worked. Use NAME as part of the test name; each call to 539### continue_to_breakpoint should use a NAME which is unique within 540### that test file. 541proc gdb_continue_to_breakpoint {name {location_pattern .*}} { 542 global gdb_prompt 543 set full_name "continue to breakpoint: $name" 544 545 send_gdb "continue\n" 546 gdb_expect { 547 -re "(?:Breakpoint|Temporary breakpoint) .* (at|in) $location_pattern\r\n$gdb_prompt $" { 548 pass $full_name 549 } 550 -re ".*$gdb_prompt $" { 551 fail $full_name 552 } 553 timeout { 554 fail "$full_name (timeout)" 555 } 556 } 557} 558 559 560# gdb_internal_error_resync: 561# 562# Answer the questions GDB asks after it reports an internal error 563# until we get back to a GDB prompt. Decline to quit the debugging 564# session, and decline to create a core file. Return non-zero if the 565# resync succeeds. 566# 567# This procedure just answers whatever questions come up until it sees 568# a GDB prompt; it doesn't require you to have matched the input up to 569# any specific point. However, it only answers questions it sees in 570# the output itself, so if you've matched a question, you had better 571# answer it yourself before calling this. 572# 573# You can use this function thus: 574# 575# gdb_expect { 576# ... 577# -re ".*A problem internal to GDB has been detected" { 578# gdb_internal_error_resync 579# } 580# ... 581# } 582# 583proc gdb_internal_error_resync {} { 584 global gdb_prompt 585 586 verbose -log "Resyncing due to internal error." 587 588 set count 0 589 while {$count < 10} { 590 gdb_expect { 591 -re "Quit this debugging session\\? \\(y or n\\) $" { 592 send_gdb "n\n" 593 incr count 594 } 595 -re "Create a core file of GDB\\? \\(y or n\\) $" { 596 send_gdb "n\n" 597 incr count 598 } 599 -re "$gdb_prompt $" { 600 # We're resynchronized. 601 return 1 602 } 603 timeout { 604 perror "Could not resync from internal error (timeout)" 605 return 0 606 } 607 } 608 } 609 perror "Could not resync from internal error (resync count exceeded)" 610 return 0 611} 612 613 614# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS 615# Send a command to gdb; test the result. 616# 617# COMMAND is the command to execute, send to GDB with send_gdb. If 618# this is the null string no command is sent. 619# MESSAGE is a message to be printed with the built-in failure patterns 620# if one of them matches. If MESSAGE is empty COMMAND will be used. 621# EXPECT_ARGUMENTS will be fed to expect in addition to the standard 622# patterns. Pattern elements will be evaluated in the caller's 623# context; action elements will be executed in the caller's context. 624# Unlike patterns for gdb_test, these patterns should generally include 625# the final newline and prompt. 626# 627# Returns: 628# 1 if the test failed, according to a built-in failure pattern 629# 0 if only user-supplied patterns matched 630# -1 if there was an internal error. 631# 632# You can use this function thus: 633# 634# gdb_test_multiple "print foo" "test foo" { 635# -re "expected output 1" { 636# pass "print foo" 637# } 638# -re "expected output 2" { 639# fail "print foo" 640# } 641# } 642# 643# The standard patterns, such as "Inferior exited..." and "A problem 644# ...", all being implicitly appended to that list. 645# 646proc gdb_test_multiple { command message user_code } { 647 global verbose use_gdb_stub 648 global gdb_prompt 649 global GDB 650 global inferior_exited_re 651 upvar timeout timeout 652 upvar expect_out expect_out 653 654 if { $message == "" } { 655 set message $command 656 } 657 658 if [string match "*\[\r\n\]" $command] { 659 error "Invalid trailing newline in \"$message\" test" 660 } 661 662 if [string match "*\[\r\n\]*" $message] { 663 error "Invalid newline in \"$message\" test" 664 } 665 666 if {$use_gdb_stub 667 && [regexp -nocase {^\s*(r|run|star|start|at|att|atta|attac|attach)\M} \ 668 $command]} { 669 error "gdbserver does not support $command without extended-remote" 670 } 671 672 # TCL/EXPECT WART ALERT 673 # Expect does something very strange when it receives a single braced 674 # argument. It splits it along word separators and performs substitutions. 675 # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is 676 # evaluated as "\[ab\]". But that's not how TCL normally works; inside a 677 # double-quoted list item, "\[ab\]" is just a long way of representing 678 # "[ab]", because the backslashes will be removed by lindex. 679 680 # Unfortunately, there appears to be no easy way to duplicate the splitting 681 # that expect will do from within TCL. And many places make use of the 682 # "\[0-9\]" construct, so we need to support that; and some places make use 683 # of the "[func]" construct, so we need to support that too. In order to 684 # get this right we have to substitute quoted list elements differently 685 # from braced list elements. 686 687 # We do this roughly the same way that Expect does it. We have to use two 688 # lists, because if we leave unquoted newlines in the argument to uplevel 689 # they'll be treated as command separators, and if we escape newlines 690 # we mangle newlines inside of command blocks. This assumes that the 691 # input doesn't contain a pattern which contains actual embedded newlines 692 # at this point! 693 694 regsub -all {\n} ${user_code} { } subst_code 695 set subst_code [uplevel list $subst_code] 696 697 set processed_code "" 698 set patterns "" 699 set expecting_action 0 700 set expecting_arg 0 701 foreach item $user_code subst_item $subst_code { 702 if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } { 703 lappend processed_code $item 704 continue 705 } 706 if { $item == "-indices" || $item == "-re" || $item == "-ex" } { 707 lappend processed_code $item 708 continue 709 } 710 if { $item == "-timeout" } { 711 set expecting_arg 1 712 lappend processed_code $item 713 continue 714 } 715 if { $expecting_arg } { 716 set expecting_arg 0 717 lappend processed_code $item 718 continue 719 } 720 if { $expecting_action } { 721 lappend processed_code "uplevel [list $item]" 722 set expecting_action 0 723 # Cosmetic, no effect on the list. 724 append processed_code "\n" 725 continue 726 } 727 set expecting_action 1 728 lappend processed_code $subst_item 729 if {$patterns != ""} { 730 append patterns "; " 731 } 732 append patterns "\"$subst_item\"" 733 } 734 735 # Also purely cosmetic. 736 regsub -all {\r} $patterns {\\r} patterns 737 regsub -all {\n} $patterns {\\n} patterns 738 739 if $verbose>2 then { 740 send_user "Sending \"$command\" to gdb\n" 741 send_user "Looking to match \"$patterns\"\n" 742 send_user "Message is \"$message\"\n" 743 } 744 745 set result -1 746 set string "${command}\n"; 747 if { $command != "" } { 748 set multi_line_re "\[\r\n\] *>" 749 while { "$string" != "" } { 750 set foo [string first "\n" "$string"]; 751 set len [string length "$string"]; 752 if { $foo < [expr $len - 1] } { 753 set str [string range "$string" 0 $foo]; 754 if { [send_gdb "$str"] != "" } { 755 global suppress_flag; 756 757 if { ! $suppress_flag } { 758 perror "Couldn't send $command to GDB."; 759 } 760 fail "$message"; 761 return $result; 762 } 763 # since we're checking if each line of the multi-line 764 # command are 'accepted' by GDB here, 765 # we need to set -notransfer expect option so that 766 # command output is not lost for pattern matching 767 # - guo 768 gdb_expect 2 { 769 -notransfer -re "$multi_line_re$" { verbose "partial: match" 3 } 770 timeout { verbose "partial: timeout" 3 } 771 } 772 set string [string range "$string" [expr $foo + 1] end]; 773 set multi_line_re "$multi_line_re.*\[\r\n\] *>" 774 } else { 775 break; 776 } 777 } 778 if { "$string" != "" } { 779 if { [send_gdb "$string"] != "" } { 780 global suppress_flag; 781 782 if { ! $suppress_flag } { 783 perror "Couldn't send $command to GDB."; 784 } 785 fail "$message"; 786 return $result; 787 } 788 } 789 } 790 791 if [target_info exists gdb,timeout] { 792 set tmt [target_info gdb,timeout]; 793 } else { 794 if [info exists timeout] { 795 set tmt $timeout; 796 } else { 797 global timeout; 798 if [info exists timeout] { 799 set tmt $timeout; 800 } else { 801 set tmt 60; 802 } 803 } 804 } 805 806 set code { 807 -re ".*A problem internal to GDB has been detected" { 808 fail "$message (GDB internal error)" 809 gdb_internal_error_resync 810 } 811 -re "\\*\\*\\* DOSEXIT code.*" { 812 if { $message != "" } { 813 fail "$message"; 814 } 815 gdb_suppress_entire_file "GDB died"; 816 set result -1; 817 } 818 } 819 append code $processed_code 820 append code { 821 -re "Ending remote debugging.*$gdb_prompt $" { 822 if ![isnative] then { 823 warning "Can`t communicate to remote target." 824 } 825 gdb_exit 826 gdb_start 827 set result -1 828 } 829 -re "Undefined\[a-z\]* command:.*$gdb_prompt $" { 830 perror "Undefined command \"$command\"." 831 fail "$message" 832 set result 1 833 } 834 -re "Ambiguous command.*$gdb_prompt $" { 835 perror "\"$command\" is not a unique command name." 836 fail "$message" 837 set result 1 838 } 839 -re "$inferior_exited_re with code \[0-9\]+.*$gdb_prompt $" { 840 if ![string match "" $message] then { 841 set errmsg "$message (the program exited)" 842 } else { 843 set errmsg "$command (the program exited)" 844 } 845 fail "$errmsg" 846 set result -1 847 } 848 -re "$inferior_exited_re normally.*$gdb_prompt $" { 849 if ![string match "" $message] then { 850 set errmsg "$message (the program exited)" 851 } else { 852 set errmsg "$command (the program exited)" 853 } 854 fail "$errmsg" 855 set result -1 856 } 857 -re "The program is not being run.*$gdb_prompt $" { 858 if ![string match "" $message] then { 859 set errmsg "$message (the program is no longer running)" 860 } else { 861 set errmsg "$command (the program is no longer running)" 862 } 863 fail "$errmsg" 864 set result -1 865 } 866 -re "\r\n$gdb_prompt $" { 867 if ![string match "" $message] then { 868 fail "$message" 869 } 870 set result 1 871 } 872 "<return>" { 873 send_gdb "\n" 874 perror "Window too small." 875 fail "$message" 876 set result -1 877 } 878 -re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " { 879 send_gdb "n\n" 880 gdb_expect -re "$gdb_prompt $" 881 fail "$message (got interactive prompt)" 882 set result -1 883 } 884 -re "\\\[0\\\] cancel\r\n\\\[1\\\] all.*\r\n> $" { 885 send_gdb "0\n" 886 gdb_expect -re "$gdb_prompt $" 887 fail "$message (got breakpoint menu)" 888 set result -1 889 } 890 eof { 891 perror "Process no longer exists" 892 if { $message != "" } { 893 fail "$message" 894 } 895 return -1 896 } 897 full_buffer { 898 perror "internal buffer is full." 899 fail "$message" 900 set result -1 901 } 902 timeout { 903 if ![string match "" $message] then { 904 fail "$message (timeout)" 905 } 906 set result 1 907 } 908 } 909 910 set result 0 911 set code [catch {gdb_expect $tmt $code} string] 912 if {$code == 1} { 913 global errorInfo errorCode; 914 return -code error -errorinfo $errorInfo -errorcode $errorCode $string 915 } elseif {$code > 1} { 916 return -code $code $string 917 } 918 return $result 919} 920 921# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE 922# Send a command to gdb; test the result. 923# 924# COMMAND is the command to execute, send to GDB with send_gdb. If 925# this is the null string no command is sent. 926# PATTERN is the pattern to match for a PASS, and must NOT include 927# the \r\n sequence immediately before the gdb prompt. 928# MESSAGE is an optional message to be printed. If this is 929# omitted, then the pass/fail messages use the command string as the 930# message. (If this is the empty string, then sometimes we don't 931# call pass or fail at all; I don't understand this at all.) 932# QUESTION is a question GDB may ask in response to COMMAND, like 933# "are you sure?" 934# RESPONSE is the response to send if QUESTION appears. 935# 936# Returns: 937# 1 if the test failed, 938# 0 if the test passes, 939# -1 if there was an internal error. 940# 941proc gdb_test { args } { 942 global verbose 943 global gdb_prompt 944 global GDB 945 upvar timeout timeout 946 947 if [llength $args]>2 then { 948 set message [lindex $args 2] 949 } else { 950 set message [lindex $args 0] 951 } 952 set command [lindex $args 0] 953 set pattern [lindex $args 1] 954 955 if [llength $args]==5 { 956 set question_string [lindex $args 3]; 957 set response_string [lindex $args 4]; 958 } else { 959 set question_string "^FOOBAR$" 960 } 961 962 return [gdb_test_multiple $command $message { 963 -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" { 964 if ![string match "" $message] then { 965 pass "$message" 966 } 967 } 968 -re "(${question_string})$" { 969 send_gdb "$response_string\n"; 970 exp_continue; 971 } 972 }] 973} 974 975# gdb_test_no_output COMMAND MESSAGE 976# Send a command to GDB and verify that this command generated no output. 977# 978# See gdb_test_multiple for a description of the COMMAND and MESSAGE 979# parameters. If MESSAGE is ommitted, then COMMAND will be used as 980# the message. (If MESSAGE is the empty string, then sometimes we do not 981# call pass or fail at all; I don't understand this at all.) 982 983proc gdb_test_no_output { args } { 984 global gdb_prompt 985 set command [lindex $args 0] 986 if [llength $args]>1 then { 987 set message [lindex $args 1] 988 } else { 989 set message $command 990 } 991 992 set command_regex [string_to_regexp $command] 993 gdb_test_multiple $command $message { 994 -re "^$command_regex\r\n$gdb_prompt $" { 995 if ![string match "" $message] then { 996 pass "$message" 997 } 998 } 999 } 1000} 1001 1002# Send a command and then wait for a sequence of outputs. 1003# This is useful when the sequence is long and contains ".*", a single 1004# regexp to match the entire output can get a timeout much easier. 1005# 1006# COMMAND is the command to send. 1007# TEST_NAME is passed to pass/fail. COMMAND is used if TEST_NAME is "". 1008# EXPECTED_OUTPUT_LIST is a list of regexps of expected output, which are 1009# processed in order, and all must be present in the output. 1010# 1011# It is unnecessary to specify ".*" at the beginning or end of any regexp, 1012# there is an implicit ".*" between each element of EXPECTED_OUTPUT_LIST. 1013# There is also an implicit ".*" between the last regexp and the gdb prompt. 1014# 1015# Like gdb_test and gdb_test_multiple, the output is expected to end with the 1016# gdb prompt, which must not be specified in EXPECTED_OUTPUT_LIST. 1017# 1018# Returns: 1019# 1 if the test failed, 1020# 0 if the test passes, 1021# -1 if there was an internal error. 1022 1023proc gdb_test_sequence { command test_name expected_output_list } { 1024 global gdb_prompt 1025 if { $test_name == "" } { 1026 set test_name $command 1027 } 1028 lappend expected_output_list ""; # implicit ".*" before gdb prompt 1029 send_gdb "$command\n" 1030 return [gdb_expect_list $test_name "$gdb_prompt $" $expected_output_list] 1031} 1032 1033 1034# Test that a command gives an error. For pass or fail, return 1035# a 1 to indicate that more tests can proceed. However a timeout 1036# is a serious error, generates a special fail message, and causes 1037# a 0 to be returned to indicate that more tests are likely to fail 1038# as well. 1039 1040proc test_print_reject { args } { 1041 global gdb_prompt 1042 global verbose 1043 1044 if [llength $args]==2 then { 1045 set expectthis [lindex $args 1] 1046 } else { 1047 set expectthis "should never match this bogus string" 1048 } 1049 set sendthis [lindex $args 0] 1050 if $verbose>2 then { 1051 send_user "Sending \"$sendthis\" to gdb\n" 1052 send_user "Looking to match \"$expectthis\"\n" 1053 } 1054 send_gdb "$sendthis\n" 1055 #FIXME: Should add timeout as parameter. 1056 gdb_expect { 1057 -re "A .* in expression.*\\.*$gdb_prompt $" { 1058 pass "reject $sendthis" 1059 return 1 1060 } 1061 -re "Invalid syntax in expression.*$gdb_prompt $" { 1062 pass "reject $sendthis" 1063 return 1 1064 } 1065 -re "Junk after end of expression.*$gdb_prompt $" { 1066 pass "reject $sendthis" 1067 return 1 1068 } 1069 -re "Invalid number.*$gdb_prompt $" { 1070 pass "reject $sendthis" 1071 return 1 1072 } 1073 -re "Invalid character constant.*$gdb_prompt $" { 1074 pass "reject $sendthis" 1075 return 1 1076 } 1077 -re "No symbol table is loaded.*$gdb_prompt $" { 1078 pass "reject $sendthis" 1079 return 1 1080 } 1081 -re "No symbol .* in current context.*$gdb_prompt $" { 1082 pass "reject $sendthis" 1083 return 1 1084 } 1085 -re "Unmatched single quote.*$gdb_prompt $" { 1086 pass "reject $sendthis" 1087 return 1 1088 } 1089 -re "A character constant must contain at least one character.*$gdb_prompt $" { 1090 pass "reject $sendthis" 1091 return 1 1092 } 1093 -re "$expectthis.*$gdb_prompt $" { 1094 pass "reject $sendthis" 1095 return 1 1096 } 1097 -re ".*$gdb_prompt $" { 1098 fail "reject $sendthis" 1099 return 1 1100 } 1101 default { 1102 fail "reject $sendthis (eof or timeout)" 1103 return 0 1104 } 1105 } 1106} 1107 1108# Given an input string, adds backslashes as needed to create a 1109# regexp that will match the string. 1110 1111proc string_to_regexp {str} { 1112 set result $str 1113 regsub -all {[]*+.|()^$\[\\]} $str {\\&} result 1114 return $result 1115} 1116 1117# Same as gdb_test, but the second parameter is not a regexp, 1118# but a string that must match exactly. 1119 1120proc gdb_test_exact { args } { 1121 upvar timeout timeout 1122 1123 set command [lindex $args 0] 1124 1125 # This applies a special meaning to a null string pattern. Without 1126 # this, "$pattern\r\n$gdb_prompt $" will match anything, including error 1127 # messages from commands that should have no output except a new 1128 # prompt. With this, only results of a null string will match a null 1129 # string pattern. 1130 1131 set pattern [lindex $args 1] 1132 if [string match $pattern ""] { 1133 set pattern [string_to_regexp [lindex $args 0]] 1134 } else { 1135 set pattern [string_to_regexp [lindex $args 1]] 1136 } 1137 1138 # It is most natural to write the pattern argument with only 1139 # embedded \n's, especially if you are trying to avoid Tcl quoting 1140 # problems. But gdb_expect really wants to see \r\n in patterns. So 1141 # transform the pattern here. First transform \r\n back to \n, in 1142 # case some users of gdb_test_exact already do the right thing. 1143 regsub -all "\r\n" $pattern "\n" pattern 1144 regsub -all "\n" $pattern "\r\n" pattern 1145 if [llength $args]==3 then { 1146 set message [lindex $args 2] 1147 } else { 1148 set message $command 1149 } 1150 1151 return [gdb_test $command $pattern $message] 1152} 1153 1154# Wrapper around gdb_test_multiple that looks for a list of expected 1155# output elements, but which can appear in any order. 1156# CMD is the gdb command. 1157# NAME is the name of the test. 1158# ELM_FIND_REGEXP specifies how to partition the output into elements to 1159# compare. 1160# ELM_EXTRACT_REGEXP specifies the part of ELM_FIND_REGEXP to compare. 1161# RESULT_MATCH_LIST is a list of exact matches for each expected element. 1162# All elements of RESULT_MATCH_LIST must appear for the test to pass. 1163# 1164# A typical use of ELM_FIND_REGEXP/ELM_EXTRACT_REGEXP is to extract one line 1165# of text per element and then strip trailing \r\n's. 1166# Example: 1167# gdb_test_list_exact "foo" "bar" \ 1168# "\[^\r\n\]+\[\r\n\]+" \ 1169# "\[^\r\n\]+" \ 1170# { \ 1171# {expected result 1} \ 1172# {expected result 2} \ 1173# } 1174 1175proc gdb_test_list_exact { cmd name elm_find_regexp elm_extract_regexp result_match_list } { 1176 global gdb_prompt 1177 1178 set matches [lsort $result_match_list] 1179 set seen {} 1180 gdb_test_multiple $cmd $name { 1181 "$cmd\[\r\n\]" { exp_continue } 1182 -re $elm_find_regexp { 1183 set str $expect_out(0,string) 1184 verbose -log "seen: $str" 3 1185 regexp -- $elm_extract_regexp $str elm_seen 1186 verbose -log "extracted: $elm_seen" 3 1187 lappend seen $elm_seen 1188 exp_continue 1189 } 1190 -re "$gdb_prompt $" { 1191 set failed "" 1192 foreach got [lsort $seen] have $matches { 1193 if {![string equal $got $have]} { 1194 set failed $have 1195 break 1196 } 1197 } 1198 if {[string length $failed] != 0} { 1199 fail "$name ($failed not found)" 1200 } else { 1201 pass $name 1202 } 1203 } 1204 } 1205} 1206 1207proc gdb_reinitialize_dir { subdir } { 1208 global gdb_prompt 1209 1210 if [is_remote host] { 1211 return ""; 1212 } 1213 send_gdb "dir\n" 1214 gdb_expect 60 { 1215 -re "Reinitialize source path to empty.*y or n. " { 1216 send_gdb "y\n" 1217 gdb_expect 60 { 1218 -re "Source directories searched.*$gdb_prompt $" { 1219 send_gdb "dir $subdir\n" 1220 gdb_expect 60 { 1221 -re "Source directories searched.*$gdb_prompt $" { 1222 verbose "Dir set to $subdir" 1223 } 1224 -re "$gdb_prompt $" { 1225 perror "Dir \"$subdir\" failed." 1226 } 1227 } 1228 } 1229 -re "$gdb_prompt $" { 1230 perror "Dir \"$subdir\" failed." 1231 } 1232 } 1233 } 1234 -re "$gdb_prompt $" { 1235 perror "Dir \"$subdir\" failed." 1236 } 1237 } 1238} 1239 1240# 1241# gdb_exit -- exit the GDB, killing the target program if necessary 1242# 1243proc default_gdb_exit {} { 1244 global GDB 1245 global INTERNAL_GDBFLAGS GDBFLAGS 1246 global verbose 1247 global gdb_spawn_id; 1248 1249 gdb_stop_suppressing_tests; 1250 1251 if ![info exists gdb_spawn_id] { 1252 return; 1253 } 1254 1255 verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" 1256 1257 if { [is_remote host] && [board_info host exists fileid] } { 1258 send_gdb "quit\n"; 1259 gdb_expect 10 { 1260 -re "y or n" { 1261 send_gdb "y\n"; 1262 exp_continue; 1263 } 1264 -re "DOSEXIT code" { } 1265 default { } 1266 } 1267 } 1268 1269 if ![is_remote host] { 1270 remote_close host; 1271 } 1272 unset gdb_spawn_id 1273} 1274 1275# Load a file into the debugger. 1276# The return value is 0 for success, -1 for failure. 1277# 1278# This procedure also set the global variable GDB_FILE_CMD_DEBUG_INFO 1279# to one of these values: 1280# 1281# debug file was loaded successfully and has debug information 1282# nodebug file was loaded successfully and has no debug information 1283# lzma file was loaded, .gnu_debugdata found, but no LZMA support 1284# compiled in 1285# fail file was not loaded 1286# 1287# I tried returning this information as part of the return value, 1288# but ran into a mess because of the many re-implementations of 1289# gdb_load in config/*.exp. 1290# 1291# TODO: gdb.base/sepdebug.exp and gdb.stabs/weird.exp might be able to use 1292# this if they can get more information set. 1293 1294proc gdb_file_cmd { arg } { 1295 global gdb_prompt 1296 global verbose 1297 global GDB 1298 global last_loaded_file 1299 1300 # Save this for the benefit of gdbserver-support.exp. 1301 set last_loaded_file $arg 1302 1303 # Set whether debug info was found. 1304 # Default to "fail". 1305 global gdb_file_cmd_debug_info 1306 set gdb_file_cmd_debug_info "fail" 1307 1308 if [is_remote host] { 1309 set arg [remote_download host $arg] 1310 if { $arg == "" } { 1311 perror "download failed" 1312 return -1 1313 } 1314 } 1315 1316 # The file command used to kill the remote target. For the benefit 1317 # of the testsuite, preserve this behavior. 1318 send_gdb "kill\n" 1319 gdb_expect 120 { 1320 -re "Kill the program being debugged. .y or n. $" { 1321 send_gdb "y\n" 1322 verbose "\t\tKilling previous program being debugged" 1323 exp_continue 1324 } 1325 -re "$gdb_prompt $" { 1326 # OK. 1327 } 1328 } 1329 1330 send_gdb "file $arg\n" 1331 gdb_expect 120 { 1332 -re "Reading symbols from.*LZMA support was disabled.*done.*$gdb_prompt $" { 1333 verbose "\t\tLoaded $arg into $GDB; .gnu_debugdata found but no LZMA available" 1334 set gdb_file_cmd_debug_info "lzma" 1335 return 0 1336 } 1337 -re "Reading symbols from.*no debugging symbols found.*done.*$gdb_prompt $" { 1338 verbose "\t\tLoaded $arg into $GDB with no debugging symbols" 1339 set gdb_file_cmd_debug_info "nodebug" 1340 return 0 1341 } 1342 -re "Reading symbols from.*done.*$gdb_prompt $" { 1343 verbose "\t\tLoaded $arg into $GDB" 1344 set gdb_file_cmd_debug_info "debug" 1345 return 0 1346 } 1347 -re "Load new symbol table from \".*\".*y or n. $" { 1348 send_gdb "y\n" 1349 gdb_expect 120 { 1350 -re "Reading symbols from.*done.*$gdb_prompt $" { 1351 verbose "\t\tLoaded $arg with new symbol table into $GDB" 1352 set gdb_file_cmd_debug_info "debug" 1353 return 0 1354 } 1355 timeout { 1356 perror "Couldn't load $arg, other program already loaded (timeout)." 1357 return -1 1358 } 1359 eof { 1360 perror "Couldn't load $arg, other program already loaded (eof)." 1361 return -1 1362 } 1363 } 1364 } 1365 -re "No such file or directory.*$gdb_prompt $" { 1366 perror "($arg) No such file or directory" 1367 return -1 1368 } 1369 -re "A problem internal to GDB has been detected" { 1370 fail "($arg) (GDB internal error)" 1371 gdb_internal_error_resync 1372 return -1 1373 } 1374 -re "$gdb_prompt $" { 1375 perror "Couldn't load $arg into $GDB." 1376 return -1 1377 } 1378 timeout { 1379 perror "Couldn't load $arg into $GDB (timeout)." 1380 return -1 1381 } 1382 eof { 1383 # This is an attempt to detect a core dump, but seems not to 1384 # work. Perhaps we need to match .* followed by eof, in which 1385 # gdb_expect does not seem to have a way to do that. 1386 perror "Couldn't load $arg into $GDB (eof)." 1387 return -1 1388 } 1389 } 1390} 1391 1392# 1393# start gdb -- start gdb running, default procedure 1394# 1395# When running over NFS, particularly if running many simultaneous 1396# tests on different hosts all using the same server, things can 1397# get really slow. Give gdb at least 3 minutes to start up. 1398# 1399proc default_gdb_start { } { 1400 global verbose use_gdb_stub 1401 global GDB 1402 global INTERNAL_GDBFLAGS GDBFLAGS 1403 global gdb_prompt 1404 global timeout 1405 global gdb_spawn_id; 1406 1407 gdb_stop_suppressing_tests; 1408 1409 # Set the default value, it may be overriden later by specific testfile. 1410 # 1411 # Use `set_board_info use_gdb_stub' for the board file to flag the inferior 1412 # is already started after connecting and run/attach are not supported. 1413 # This is used for the "remote" protocol. After GDB starts you should 1414 # check global $use_gdb_stub instead of the board as the testfile may force 1415 # a specific different target protocol itself. 1416 set use_gdb_stub [target_info exists use_gdb_stub] 1417 1418 verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" 1419 1420 if [info exists gdb_spawn_id] { 1421 return 0; 1422 } 1423 1424 if ![is_remote host] { 1425 if { [which $GDB] == 0 } then { 1426 perror "$GDB does not exist." 1427 exit 1 1428 } 1429 } 1430 set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS [host_info gdb_opts]"]; 1431 if { $res < 0 || $res == "" } { 1432 perror "Spawning $GDB failed." 1433 return 1; 1434 } 1435 gdb_expect 360 { 1436 -re "\[\r\n\]$gdb_prompt $" { 1437 verbose "GDB initialized." 1438 } 1439 -re "$gdb_prompt $" { 1440 perror "GDB never initialized." 1441 return -1 1442 } 1443 timeout { 1444 perror "(timeout) GDB never initialized after 10 seconds." 1445 remote_close host; 1446 return -1 1447 } 1448 } 1449 set gdb_spawn_id -1; 1450 # force the height to "unlimited", so no pagers get used 1451 1452 send_gdb "set height 0\n" 1453 gdb_expect 10 { 1454 -re "$gdb_prompt $" { 1455 verbose "Setting height to 0." 2 1456 } 1457 timeout { 1458 warning "Couldn't set the height to 0" 1459 } 1460 } 1461 # force the width to "unlimited", so no wraparound occurs 1462 send_gdb "set width 0\n" 1463 gdb_expect 10 { 1464 -re "$gdb_prompt $" { 1465 verbose "Setting width to 0." 2 1466 } 1467 timeout { 1468 warning "Couldn't set the width to 0." 1469 } 1470 } 1471 return 0; 1472} 1473 1474# Examine the output of compilation to determine whether compilation 1475# failed or not. If it failed determine whether it is due to missing 1476# compiler or due to compiler error. Report pass, fail or unsupported 1477# as appropriate 1478 1479proc gdb_compile_test {src output} { 1480 if { $output == "" } { 1481 pass "compilation [file tail $src]" 1482 } elseif { [regexp {^[a-zA-Z_0-9]+: Can't find [^ ]+\.$} $output] } { 1483 unsupported "compilation [file tail $src]" 1484 } elseif { [regexp {.*: command not found[\r|\n]*$} $output] } { 1485 unsupported "compilation [file tail $src]" 1486 } elseif { [regexp {.*: [^\r\n]*compiler not installed[^\r\n]*[\r|\n]*$} $output] } { 1487 unsupported "compilation [file tail $src]" 1488 } else { 1489 verbose -log "compilation failed: $output" 2 1490 fail "compilation [file tail $src]" 1491 } 1492} 1493 1494# Return a 1 for configurations for which we don't even want to try to 1495# test C++. 1496 1497proc skip_cplus_tests {} { 1498 if { [istarget "h8300-*-*"] } { 1499 return 1 1500 } 1501 1502 # The C++ IO streams are too large for HC11/HC12 and are thus not 1503 # available. The gdb C++ tests use them and don't compile. 1504 if { [istarget "m6811-*-*"] } { 1505 return 1 1506 } 1507 if { [istarget "m6812-*-*"] } { 1508 return 1 1509 } 1510 return 0 1511} 1512 1513# Return a 1 for configurations for which don't have both C++ and the STL. 1514 1515proc skip_stl_tests {} { 1516 # Symbian supports the C++ language, but the STL is missing 1517 # (both headers and libraries). 1518 if { [istarget "arm*-*-symbianelf*"] } { 1519 return 1 1520 } 1521 1522 return [skip_cplus_tests] 1523} 1524 1525# Return a 1 if I don't even want to try to test FORTRAN. 1526 1527proc skip_fortran_tests {} { 1528 return 0 1529} 1530 1531# Return a 1 if I don't even want to try to test ada. 1532 1533proc skip_ada_tests {} { 1534 return 0 1535} 1536 1537# Return a 1 if I don't even want to try to test GO. 1538 1539proc skip_go_tests {} { 1540 return 0 1541} 1542 1543# Return a 1 if I don't even want to try to test java. 1544 1545proc skip_java_tests {} { 1546 return 0 1547} 1548 1549# Return a 1 for configurations that do not support Python scripting. 1550 1551proc skip_python_tests {} { 1552 global gdb_prompt 1553 global gdb_py_is_py3k 1554 global gdb_py_is_py24 1555 1556 gdb_test_multiple "python print ('test')" "verify python support" { 1557 -re "not supported.*$gdb_prompt $" { 1558 unsupported "Python support is disabled." 1559 return 1 1560 } 1561 -re "$gdb_prompt $" {} 1562 } 1563 1564 set gdb_py_is_py24 0 1565 gdb_test_multiple "python print (sys.version_info\[0\])" "check if python 3" { 1566 -re "3.*$gdb_prompt $" { 1567 set gdb_py_is_py3k 1 1568 } 1569 -re ".*$gdb_prompt $" { 1570 set gdb_py_is_py3k 0 1571 } 1572 } 1573 if { $gdb_py_is_py3k == 0 } { 1574 gdb_test_multiple "python print (sys.version_info\[1\])" "check if python 2.4" { 1575 -re "\[45\].*$gdb_prompt $" { 1576 set gdb_py_is_py24 1 1577 } 1578 -re ".*$gdb_prompt $" { 1579 set gdb_py_is_py24 0 1580 } 1581 } 1582 } 1583 1584 return 0 1585} 1586 1587# Return a 1 if we should skip shared library tests. 1588 1589proc skip_shlib_tests {} { 1590 # Run the shared library tests on native systems. 1591 if {[isnative]} { 1592 return 0 1593 } 1594 1595 # An abbreviated list of remote targets where we should be able to 1596 # run shared library tests. 1597 if {([istarget *-*-linux*] 1598 || [istarget *-*-*bsd*] 1599 || [istarget *-*-solaris2*] 1600 || [istarget arm*-*-symbianelf*] 1601 || [istarget *-*-mingw*] 1602 || [istarget *-*-cygwin*] 1603 || [istarget *-*-pe*])} { 1604 return 0 1605 } 1606 1607 return 1 1608} 1609 1610# Test files shall make sure all the test result lines in gdb.sum are 1611# unique in a test run, so that comparing the gdb.sum files of two 1612# test runs gives correct results. Test files that exercise 1613# variations of the same tests more than once, shall prefix the 1614# different test invocations with different identifying strings in 1615# order to make them unique. 1616# 1617# About test prefixes: 1618# 1619# $pf_prefix is the string that dejagnu prints after the result (FAIL, 1620# PASS, etc.), and before the test message/name in gdb.sum. E.g., the 1621# underlined substring in 1622# 1623# PASS: gdb.base/mytest.exp: some test 1624# ^^^^^^^^^^^^^^^^^^^^ 1625# 1626# is $pf_prefix. 1627# 1628# The easiest way to adjust the test prefix is to append a test 1629# variation prefix to the $pf_prefix, using the with_test_prefix 1630# procedure. E.g., 1631# 1632# proc do_tests {} { 1633# gdb_test ... ... "test foo" 1634# gdb_test ... ... "test bar" 1635# 1636# with_test_prefix "subvariation a" { 1637# gdb_test ... ... "test x" 1638# } 1639# 1640# with_test_prefix "subvariation b" { 1641# gdb_test ... ... "test x" 1642# } 1643# } 1644# 1645# with_test_prefix "variation1" { 1646# ...do setup for variation 1... 1647# do_tests 1648# } 1649# 1650# with_test_prefix "variation2" { 1651# ...do setup for variation 2... 1652# do_tests 1653# } 1654# 1655# Results in: 1656# 1657# PASS: gdb.base/mytest.exp: variation1: test foo 1658# PASS: gdb.base/mytest.exp: variation1: test bar 1659# PASS: gdb.base/mytest.exp: variation1: subvariation a: test x 1660# PASS: gdb.base/mytest.exp: variation1: subvariation b: test x 1661# PASS: gdb.base/mytest.exp: variation2: test foo 1662# PASS: gdb.base/mytest.exp: variation2: test bar 1663# PASS: gdb.base/mytest.exp: variation2: subvariation a: test x 1664# PASS: gdb.base/mytest.exp: variation2: subvariation b: test x 1665# 1666# If for some reason more flexibility is necessary, one can also 1667# manipulate the pf_prefix global directly, treating it as a string. 1668# E.g., 1669# 1670# global pf_prefix 1671# set saved_pf_prefix 1672# append pf_prefix "${foo}: bar" 1673# ... actual tests ... 1674# set pf_prefix $saved_pf_prefix 1675# 1676 1677# Run BODY in the context of the caller, with the current test prefix 1678# (pf_prefix) appended with one space, then PREFIX, and then a colon. 1679# Returns the result of BODY. 1680# 1681proc with_test_prefix { prefix body } { 1682 global pf_prefix 1683 1684 set saved $pf_prefix 1685 append pf_prefix " " $prefix ":" 1686 set code [catch {uplevel 1 $body} result] 1687 set pf_prefix $saved 1688 1689 if {$code == 1} { 1690 global errorInfo errorCode 1691 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 1692 } else { 1693 return -code $code $result 1694 } 1695} 1696 1697# Return 1 if _Complex types are supported, otherwise, return 0. 1698 1699proc support_complex_tests {} { 1700 global support_complex_tests_saved 1701 1702 # Use the cached value, if it exists. 1703 if [info exists support_complex_tests_saved] { 1704 verbose "returning saved $support_complex_tests_saved" 2 1705 return $support_complex_tests_saved 1706 } 1707 1708 # Set up, compile, and execute a test program containing _Complex types. 1709 # Include the current process ID in the file names to prevent conflicts 1710 # with invocations for multiple testsuites. 1711 set src complex[pid].c 1712 set exe complex[pid].x 1713 1714 set f [open $src "w"] 1715 puts $f "int main() {" 1716 puts $f "_Complex float cf;" 1717 puts $f "_Complex double cd;" 1718 puts $f "_Complex long double cld;" 1719 puts $f " return 0; }" 1720 close $f 1721 1722 verbose "compiling testfile $src" 2 1723 set compile_flags {debug nowarnings quiet} 1724 set lines [gdb_compile $src $exe executable $compile_flags] 1725 file delete $src 1726 file delete $exe 1727 1728 if ![string match "" $lines] then { 1729 verbose "testfile compilation failed, returning 0" 2 1730 set support_complex_tests_saved 0 1731 } else { 1732 set support_complex_tests_saved 1 1733 } 1734 1735 return $support_complex_tests_saved 1736} 1737 1738# Return 1 if target hardware or OS supports single stepping to signal 1739# handler, otherwise, return 0. 1740 1741proc can_single_step_to_signal_handler {} { 1742 1743 # Targets don't have hardware single step. On these targets, when 1744 # a signal is delivered during software single step, gdb is unable 1745 # to determine the next instruction addresses, because start of signal 1746 # handler is one of them. 1747 if { [istarget "arm*-*-*"] || [istarget "mips*-*-*"] 1748 || [istarget "tic6x-*-*"] || [istarget "sparc*-*-linux*"] } { 1749 return 0 1750 } 1751 1752 return 1 1753} 1754 1755# Return 1 if target supports process record, otherwise return 0. 1756 1757proc supports_process_record {} { 1758 1759 if [target_info exists gdb,use_precord] { 1760 return [target_info gdb,use_precord] 1761 } 1762 1763 if { [istarget "x86_64-*-linux*"] || [istarget "i\[34567\]86-*-linux*"] } { 1764 return 1 1765 } 1766 1767 return 0 1768} 1769 1770# Return 1 if target supports reverse debugging, otherwise return 0. 1771 1772proc supports_reverse {} { 1773 1774 if [target_info exists gdb,can_reverse] { 1775 return [target_info gdb,can_reverse] 1776 } 1777 1778 if { [istarget "x86_64-*-linux*"] || [istarget "i\[34567\]86-*-linux*"] } { 1779 return 1 1780 } 1781 1782 return 0 1783} 1784 1785# Return 1 if target is ILP32. 1786# This cannot be decided simply from looking at the target string, 1787# as it might depend on externally passed compiler options like -m64. 1788proc is_ilp32_target {} { 1789 global is_ilp32_target_saved 1790 1791 # Use the cached value, if it exists. Cache value per "board" to handle 1792 # runs with multiple options (e.g. unix/{-m32,-64}) correctly. 1793 set me "is_ilp32_target" 1794 set board [target_info name] 1795 if [info exists is_ilp32_target_saved($board)] { 1796 verbose "$me: returning saved $is_ilp32_target_saved($board)" 2 1797 return $is_ilp32_target_saved($board) 1798 } 1799 1800 1801 set src ilp32[pid].c 1802 set obj ilp32[pid].o 1803 1804 set f [open $src "w"] 1805 puts $f "int dummy\[sizeof (int) == 4" 1806 puts $f " && sizeof (void *) == 4" 1807 puts $f " && sizeof (long) == 4 ? 1 : -1\];" 1808 close $f 1809 1810 verbose "$me: compiling testfile $src" 2 1811 set lines [gdb_compile $src $obj object {quiet}] 1812 file delete $src 1813 file delete $obj 1814 1815 if ![string match "" $lines] then { 1816 verbose "$me: testfile compilation failed, returning 0" 2 1817 return [set is_ilp32_target_saved($board) 0] 1818 } 1819 1820 verbose "$me: returning 1" 2 1821 return [set is_ilp32_target_saved($board) 1] 1822} 1823 1824# Return 1 if target is LP64. 1825# This cannot be decided simply from looking at the target string, 1826# as it might depend on externally passed compiler options like -m64. 1827proc is_lp64_target {} { 1828 global is_lp64_target_saved 1829 1830 # Use the cached value, if it exists. Cache value per "board" to handle 1831 # runs with multiple options (e.g. unix/{-m32,-64}) correctly. 1832 set me "is_lp64_target" 1833 set board [target_info name] 1834 if [info exists is_lp64_target_saved($board)] { 1835 verbose "$me: returning saved $is_lp64_target_saved($board)" 2 1836 return $is_lp64_target_saved($board) 1837 } 1838 1839 set src lp64[pid].c 1840 set obj lp64[pid].o 1841 1842 set f [open $src "w"] 1843 puts $f "int dummy\[sizeof (int) == 4" 1844 puts $f " && sizeof (void *) == 8" 1845 puts $f " && sizeof (long) == 8 ? 1 : -1\];" 1846 close $f 1847 1848 verbose "$me: compiling testfile $src" 2 1849 set lines [gdb_compile $src $obj object {quiet}] 1850 file delete $src 1851 file delete $obj 1852 1853 if ![string match "" $lines] then { 1854 verbose "$me: testfile compilation failed, returning 0" 2 1855 return [set is_lp64_target_saved($board) 0] 1856 } 1857 1858 verbose "$me: returning 1" 2 1859 return [set is_lp64_target_saved($board) 1] 1860} 1861 1862# Return 1 if target has x86_64 registers - either amd64 or x32. 1863# x32 target identifies as x86_64-*-linux*, therefore it cannot be determined 1864# just from the target string. 1865proc is_amd64_regs_target {} { 1866 global is_amd64_regs_target_saved 1867 1868 if {![istarget "x86_64-*-*"] && ![istarget "i?86-*"]} { 1869 return 0 1870 } 1871 1872 # Use the cached value, if it exists. Cache value per "board" to handle 1873 # runs with multiple options (e.g. unix/{-m32,-64}) correctly. 1874 set me "is_amd64_regs_target" 1875 set board [target_info name] 1876 if [info exists is_amd64_regs_target_saved($board)] { 1877 verbose "$me: returning saved $is_amd64_regs_target_saved($board)" 2 1878 return $is_amd64_regs_target_saved($board) 1879 } 1880 1881 set src reg64[pid].s 1882 set obj reg64[pid].o 1883 1884 set f [open $src "w"] 1885 foreach reg \ 1886 {rax rbx rcx rdx rsi rdi rbp rsp r8 r9 r10 r11 r12 r13 r14 r15} { 1887 puts $f "\tincq %$reg" 1888 } 1889 close $f 1890 1891 verbose "$me: compiling testfile $src" 2 1892 set lines [gdb_compile $src $obj object {quiet}] 1893 file delete $src 1894 file delete $obj 1895 1896 if ![string match "" $lines] then { 1897 verbose "$me: testfile compilation failed, returning 0" 2 1898 return [set is_amd64_regs_target_saved($board) 0] 1899 } 1900 1901 verbose "$me: returning 1" 2 1902 return [set is_amd64_regs_target_saved($board) 1] 1903} 1904 1905# Return 1 if this target is an x86 or x86-64 with -m32. 1906proc is_x86_like_target {} { 1907 if {![istarget "x86_64-*-*"] && ![istarget i?86-*]} { 1908 return 0 1909 } 1910 return [expr [is_ilp32_target] && ![is_amd64_regs_target]] 1911} 1912 1913# Return 1 if displaced stepping is supported on target, otherwise, return 0. 1914proc support_displaced_stepping {} { 1915 1916 if { [istarget "x86_64-*-linux*"] || [istarget "i\[34567\]86-*-linux*"] 1917 || [istarget "arm*-*-linux*"] || [istarget "powerpc-*-linux*"] 1918 || [istarget "powerpc64-*-linux*"] || [istarget "s390*-*-*"] } { 1919 return 1 1920 } 1921 1922 return 0 1923} 1924 1925# Run a test on the target to see if it supports vmx hardware. Return 0 if so, 1926# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 1927 1928proc skip_altivec_tests {} { 1929 global skip_vmx_tests_saved 1930 global srcdir subdir gdb_prompt inferior_exited_re 1931 1932 # Use the cached value, if it exists. 1933 set me "skip_altivec_tests" 1934 if [info exists skip_vmx_tests_saved] { 1935 verbose "$me: returning saved $skip_vmx_tests_saved" 2 1936 return $skip_vmx_tests_saved 1937 } 1938 1939 # Some simulators are known to not support VMX instructions. 1940 if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } { 1941 verbose "$me: target known to not support VMX, returning 1" 2 1942 return [set skip_vmx_tests_saved 1] 1943 } 1944 1945 # Make sure we have a compiler that understands altivec. 1946 set compile_flags {debug nowarnings} 1947 if [get_compiler_info] { 1948 warning "Could not get compiler info" 1949 return 1 1950 } 1951 if [test_compiler_info gcc*] { 1952 set compile_flags "$compile_flags additional_flags=-maltivec" 1953 } elseif [test_compiler_info xlc*] { 1954 set compile_flags "$compile_flags additional_flags=-qaltivec" 1955 } else { 1956 verbose "Could not compile with altivec support, returning 1" 2 1957 return 1 1958 } 1959 1960 # Set up, compile, and execute a test program containing VMX instructions. 1961 # Include the current process ID in the file names to prevent conflicts 1962 # with invocations for multiple testsuites. 1963 set src vmx[pid].c 1964 set exe vmx[pid].x 1965 1966 set f [open $src "w"] 1967 puts $f "int main() {" 1968 puts $f "#ifdef __MACH__" 1969 puts $f " asm volatile (\"vor v0,v0,v0\");" 1970 puts $f "#else" 1971 puts $f " asm volatile (\"vor 0,0,0\");" 1972 puts $f "#endif" 1973 puts $f " return 0; }" 1974 close $f 1975 1976 verbose "$me: compiling testfile $src" 2 1977 set lines [gdb_compile $src $exe executable $compile_flags] 1978 file delete $src 1979 1980 if ![string match "" $lines] then { 1981 verbose "$me: testfile compilation failed, returning 1" 2 1982 return [set skip_vmx_tests_saved 1] 1983 } 1984 1985 # No error message, compilation succeeded so now run it via gdb. 1986 1987 gdb_exit 1988 gdb_start 1989 gdb_reinitialize_dir $srcdir/$subdir 1990 gdb_load "$exe" 1991 gdb_run_cmd 1992 gdb_expect { 1993 -re ".*Illegal instruction.*${gdb_prompt} $" { 1994 verbose -log "\n$me altivec hardware not detected" 1995 set skip_vmx_tests_saved 1 1996 } 1997 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 1998 verbose -log "\n$me: altivec hardware detected" 1999 set skip_vmx_tests_saved 0 2000 } 2001 default { 2002 warning "\n$me: default case taken" 2003 set skip_vmx_tests_saved 1 2004 } 2005 } 2006 gdb_exit 2007 remote_file build delete $exe 2008 2009 verbose "$me: returning $skip_vmx_tests_saved" 2 2010 return $skip_vmx_tests_saved 2011} 2012 2013# Run a test on the target to see if it supports vmx hardware. Return 0 if so, 2014# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 2015 2016proc skip_vsx_tests {} { 2017 global skip_vsx_tests_saved 2018 global srcdir subdir gdb_prompt inferior_exited_re 2019 2020 # Use the cached value, if it exists. 2021 set me "skip_vsx_tests" 2022 if [info exists skip_vsx_tests_saved] { 2023 verbose "$me: returning saved $skip_vsx_tests_saved" 2 2024 return $skip_vsx_tests_saved 2025 } 2026 2027 # Some simulators are known to not support Altivec instructions, so 2028 # they won't support VSX instructions as well. 2029 if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } { 2030 verbose "$me: target known to not support VSX, returning 1" 2 2031 return [set skip_vsx_tests_saved 1] 2032 } 2033 2034 # Make sure we have a compiler that understands altivec. 2035 set compile_flags {debug nowarnings quiet} 2036 if [get_compiler_info] { 2037 warning "Could not get compiler info" 2038 return 1 2039 } 2040 if [test_compiler_info gcc*] { 2041 set compile_flags "$compile_flags additional_flags=-mvsx" 2042 } elseif [test_compiler_info xlc*] { 2043 set compile_flags "$compile_flags additional_flags=-qasm=gcc" 2044 } else { 2045 verbose "Could not compile with vsx support, returning 1" 2 2046 return 1 2047 } 2048 2049 set src vsx[pid].c 2050 set exe vsx[pid].x 2051 2052 set f [open $src "w"] 2053 puts $f "int main() {" 2054 puts $f " double a\[2\] = { 1.0, 2.0 };" 2055 puts $f "#ifdef __MACH__" 2056 puts $f " asm volatile (\"lxvd2x v0,v0,%\[addr\]\" : : \[addr\] \"r\" (a));" 2057 puts $f "#else" 2058 puts $f " asm volatile (\"lxvd2x 0,0,%\[addr\]\" : : \[addr\] \"r\" (a));" 2059 puts $f "#endif" 2060 puts $f " return 0; }" 2061 close $f 2062 2063 verbose "$me: compiling testfile $src" 2 2064 set lines [gdb_compile $src $exe executable $compile_flags] 2065 file delete $src 2066 2067 if ![string match "" $lines] then { 2068 verbose "$me: testfile compilation failed, returning 1" 2 2069 return [set skip_vsx_tests_saved 1] 2070 } 2071 2072 # No error message, compilation succeeded so now run it via gdb. 2073 2074 gdb_exit 2075 gdb_start 2076 gdb_reinitialize_dir $srcdir/$subdir 2077 gdb_load "$exe" 2078 gdb_run_cmd 2079 gdb_expect { 2080 -re ".*Illegal instruction.*${gdb_prompt} $" { 2081 verbose -log "\n$me VSX hardware not detected" 2082 set skip_vsx_tests_saved 1 2083 } 2084 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 2085 verbose -log "\n$me: VSX hardware detected" 2086 set skip_vsx_tests_saved 0 2087 } 2088 default { 2089 warning "\n$me: default case taken" 2090 set skip_vsx_tests_saved 1 2091 } 2092 } 2093 gdb_exit 2094 remote_file build delete $exe 2095 2096 verbose "$me: returning $skip_vsx_tests_saved" 2 2097 return $skip_vsx_tests_saved 2098} 2099 2100# Run a test on the target to see if it supports btrace hardware. Return 0 if so, 2101# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 2102 2103proc skip_btrace_tests {} { 2104 global skip_btrace_tests_saved 2105 global srcdir subdir gdb_prompt inferior_exited_re 2106 2107 # Use the cached value, if it exists. 2108 set me "skip_btrace_tests" 2109 if [info exists skip_btrace_tests_saved] { 2110 verbose "$me: returning saved $skip_btrace_tests_saved" 2 2111 return $skip_btrace_tests_saved 2112 } 2113 2114 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 2115 verbose "$me: target does not support btrace, returning 1" 2 2116 return [set skip_btrace_tests_saved 1] 2117 } 2118 2119 # Set up, compile, and execute a test program. 2120 # Include the current process ID in the file names to prevent conflicts 2121 # with invocations for multiple testsuites. 2122 set src [standard_output_file btrace[pid].c] 2123 set exe [standard_output_file btrace[pid].x] 2124 2125 set f [open $src "w"] 2126 puts $f "int main(void) { return 0; }" 2127 close $f 2128 2129 verbose "$me: compiling testfile $src" 2 2130 set compile_flags {debug nowarnings quiet} 2131 set lines [gdb_compile $src $exe executable $compile_flags] 2132 file delete $src 2133 2134 if ![string match "" $lines] then { 2135 verbose "$me: testfile compilation failed, returning 1" 2 2136 return [set skip_btrace_tests_saved 1] 2137 } 2138 2139 # No error message, compilation succeeded so now run it via gdb. 2140 2141 clean_restart btrace[pid].x 2142 if ![runto_main] { 2143 return [set skip_btrace_tests_saved 1] 2144 } 2145 # In case of an unexpected output, we return 2 as a fail value. 2146 set skip_btrace_tests_saved 2 2147 gdb_test_multiple "record btrace" "check btrace support" { 2148 -re "You can't do that when your target is.*\r\n$gdb_prompt $" { 2149 set skip_btrace_tests_saved 1 2150 } 2151 -re "Target does not support branch tracing.*\r\n$gdb_prompt $" { 2152 set skip_btrace_tests_saved 1 2153 } 2154 -re "Could not enable branch tracing.*\r\n$gdb_prompt $" { 2155 set skip_btrace_tests_saved 1 2156 } 2157 -re "^record btrace\r\n$gdb_prompt $" { 2158 set skip_btrace_tests_saved 0 2159 } 2160 } 2161 gdb_exit 2162 remote_file build delete $exe 2163 2164 verbose "$me: returning $skip_btrace_tests_saved" 2 2165 return $skip_btrace_tests_saved 2166} 2167 2168# Skip all the tests in the file if you are not on an hppa running 2169# hpux target. 2170 2171proc skip_hp_tests {} { 2172 eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ] 2173 verbose "Skip hp tests is $skip_hp" 2174 return $skip_hp 2175} 2176 2177# Return whether we should skip tests for showing inlined functions in 2178# backtraces. Requires get_compiler_info and get_debug_format. 2179 2180proc skip_inline_frame_tests {} { 2181 # GDB only recognizes inlining information in DWARF 2 (DWARF 3). 2182 if { ! [test_debug_format "DWARF 2"] } { 2183 return 1 2184 } 2185 2186 # GCC before 4.1 does not emit DW_AT_call_file / DW_AT_call_line. 2187 if { ([test_compiler_info "gcc-2-*"] 2188 || [test_compiler_info "gcc-3-*"] 2189 || [test_compiler_info "gcc-4-0-*"]) } { 2190 return 1 2191 } 2192 2193 return 0 2194} 2195 2196# Return whether we should skip tests for showing variables from 2197# inlined functions. Requires get_compiler_info and get_debug_format. 2198 2199proc skip_inline_var_tests {} { 2200 # GDB only recognizes inlining information in DWARF 2 (DWARF 3). 2201 if { ! [test_debug_format "DWARF 2"] } { 2202 return 1 2203 } 2204 2205 return 0 2206} 2207 2208# Return a 1 if we should skip tests that require hardware breakpoints 2209 2210proc skip_hw_breakpoint_tests {} { 2211 # Skip tests if requested by the board (note that no_hardware_watchpoints 2212 # disables both watchpoints and breakpoints) 2213 if { [target_info exists gdb,no_hardware_watchpoints]} { 2214 return 1 2215 } 2216 2217 # These targets support hardware breakpoints natively 2218 if { [istarget "i?86-*-*"] 2219 || [istarget "x86_64-*-*"] 2220 || [istarget "ia64-*-*"] 2221 || [istarget "arm*-*-*"]} { 2222 return 0 2223 } 2224 2225 return 1 2226} 2227 2228# Return a 1 if we should skip tests that require hardware watchpoints 2229 2230proc skip_hw_watchpoint_tests {} { 2231 # Skip tests if requested by the board 2232 if { [target_info exists gdb,no_hardware_watchpoints]} { 2233 return 1 2234 } 2235 2236 # These targets support hardware watchpoints natively 2237 if { [istarget "i?86-*-*"] 2238 || [istarget "x86_64-*-*"] 2239 || [istarget "ia64-*-*"] 2240 || [istarget "arm*-*-*"] 2241 || [istarget "powerpc*-*-linux*"] 2242 || [istarget "s390*-*-*"] } { 2243 return 0 2244 } 2245 2246 return 1 2247} 2248 2249# Return a 1 if we should skip tests that require *multiple* hardware 2250# watchpoints to be active at the same time 2251 2252proc skip_hw_watchpoint_multi_tests {} { 2253 if { [skip_hw_watchpoint_tests] } { 2254 return 1 2255 } 2256 2257 # These targets support just a single hardware watchpoint 2258 if { [istarget "arm*-*-*"] 2259 || [istarget "powerpc*-*-linux*"] } { 2260 return 1 2261 } 2262 2263 return 0 2264} 2265 2266# Return a 1 if we should skip tests that require read/access watchpoints 2267 2268proc skip_hw_watchpoint_access_tests {} { 2269 if { [skip_hw_watchpoint_tests] } { 2270 return 1 2271 } 2272 2273 # These targets support just write watchpoints 2274 if { [istarget "s390*-*-*"] } { 2275 return 1 2276 } 2277 2278 return 0 2279} 2280 2281# Return 1 if we should skip tests that require the runtime unwinder 2282# hook. This must be invoked while gdb is running, after shared 2283# libraries have been loaded. This is needed because otherwise a 2284# shared libgcc won't be visible. 2285 2286proc skip_unwinder_tests {} { 2287 global gdb_prompt 2288 2289 set ok 0 2290 gdb_test_multiple "print _Unwind_DebugHook" "check for unwinder hook" { 2291 -re "= .*no debug info.*_Unwind_DebugHook.*\r\n$gdb_prompt $" { 2292 } 2293 -re "= .*_Unwind_DebugHook.*\r\n$gdb_prompt $" { 2294 set ok 1 2295 } 2296 -re "No symbol .* in current context.\r\n$gdb_prompt $" { 2297 } 2298 } 2299 if {!$ok} { 2300 gdb_test_multiple "info probe" "check for stap probe in unwinder" { 2301 -re ".*libgcc.*unwind.*\r\n$gdb_prompt $" { 2302 set ok 1 2303 } 2304 -re "\r\n$gdb_prompt $" { 2305 } 2306 } 2307 } 2308 return $ok 2309} 2310 2311set compiler_info "unknown" 2312set gcc_compiled 0 2313set hp_cc_compiler 0 2314set hp_aCC_compiler 0 2315 2316# Figure out what compiler I am using. 2317# 2318# ARG can be empty or "C++". If empty, "C" is assumed. 2319# 2320# There are several ways to do this, with various problems. 2321# 2322# [ gdb_compile -E $ifile -o $binfile.ci ] 2323# source $binfile.ci 2324# 2325# Single Unix Spec v3 says that "-E -o ..." together are not 2326# specified. And in fact, the native compiler on hp-ux 11 (among 2327# others) does not work with "-E -o ...". Most targets used to do 2328# this, and it mostly worked, because it works with gcc. 2329# 2330# [ catch "exec $compiler -E $ifile > $binfile.ci" exec_output ] 2331# source $binfile.ci 2332# 2333# This avoids the problem with -E and -o together. This almost works 2334# if the build machine is the same as the host machine, which is 2335# usually true of the targets which are not gcc. But this code does 2336# not figure which compiler to call, and it always ends up using the C 2337# compiler. Not good for setting hp_aCC_compiler. Targets 2338# hppa*-*-hpux* and mips*-*-irix* used to do this. 2339# 2340# [ gdb_compile -E $ifile > $binfile.ci ] 2341# source $binfile.ci 2342# 2343# dejagnu target_compile says that it supports output redirection, 2344# but the code is completely different from the normal path and I 2345# don't want to sweep the mines from that path. So I didn't even try 2346# this. 2347# 2348# set cppout [ gdb_compile $ifile "" preprocess $args quiet ] 2349# eval $cppout 2350# 2351# I actually do this for all targets now. gdb_compile runs the right 2352# compiler, and TCL captures the output, and I eval the output. 2353# 2354# Unfortunately, expect logs the output of the command as it goes by, 2355# and dejagnu helpfully prints a second copy of it right afterwards. 2356# So I turn off expect logging for a moment. 2357# 2358# [ gdb_compile $ifile $ciexe_file executable $args ] 2359# [ remote_exec $ciexe_file ] 2360# [ source $ci_file.out ] 2361# 2362# I could give up on -E and just do this. 2363# I didn't get desperate enough to try this. 2364# 2365# -- chastain 2004-01-06 2366 2367proc get_compiler_info {{arg ""}} { 2368 # For compiler.c and compiler.cc 2369 global srcdir 2370 2371 # I am going to play with the log to keep noise out. 2372 global outdir 2373 global tool 2374 2375 # These come from compiler.c or compiler.cc 2376 global compiler_info 2377 2378 # Legacy global data symbols. 2379 global gcc_compiled 2380 global hp_cc_compiler 2381 global hp_aCC_compiler 2382 2383 # Choose which file to preprocess. 2384 set ifile "${srcdir}/lib/compiler.c" 2385 if { $arg == "c++" } { 2386 set ifile "${srcdir}/lib/compiler.cc" 2387 } 2388 2389 # Run $ifile through the right preprocessor. 2390 # Toggle gdb.log to keep the compiler output out of the log. 2391 log_file 2392 if [is_remote host] { 2393 # We have to use -E and -o together, despite the comments 2394 # above, because of how DejaGnu handles remote host testing. 2395 set ppout "$outdir/compiler.i" 2396 gdb_compile "${ifile}" "$ppout" preprocess [list "$arg" quiet] 2397 set file [open $ppout r] 2398 set cppout [read $file] 2399 close $file 2400 } else { 2401 set cppout [ gdb_compile "${ifile}" "" preprocess [list "$arg" quiet] ] 2402 } 2403 log_file -a "$outdir/$tool.log" 2404 2405 # Eval the output. 2406 set unknown 0 2407 foreach cppline [ split "$cppout" "\n" ] { 2408 if { [ regexp "^#" "$cppline" ] } { 2409 # line marker 2410 } elseif { [ regexp "^\[\n\r\t \]*$" "$cppline" ] } { 2411 # blank line 2412 } elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } { 2413 # eval this line 2414 verbose "get_compiler_info: $cppline" 2 2415 eval "$cppline" 2416 } else { 2417 # unknown line 2418 verbose -log "get_compiler_info: $cppline" 2419 set unknown 1 2420 } 2421 } 2422 2423 # Reset to unknown compiler if any diagnostics happened. 2424 if { $unknown } { 2425 set compiler_info "unknown" 2426 } 2427 2428 # Set the legacy symbols. 2429 set gcc_compiled 0 2430 set hp_cc_compiler 0 2431 set hp_aCC_compiler 0 2432 if { [regexp "^gcc-1-" "$compiler_info" ] } { set gcc_compiled 1 } 2433 if { [regexp "^gcc-2-" "$compiler_info" ] } { set gcc_compiled 2 } 2434 if { [regexp "^gcc-3-" "$compiler_info" ] } { set gcc_compiled 3 } 2435 if { [regexp "^gcc-4-" "$compiler_info" ] } { set gcc_compiled 4 } 2436 if { [regexp "^gcc-5-" "$compiler_info" ] } { set gcc_compiled 5 } 2437 if { [regexp "^hpcc-" "$compiler_info" ] } { set hp_cc_compiler 1 } 2438 if { [regexp "^hpacc-" "$compiler_info" ] } { set hp_aCC_compiler 1 } 2439 2440 # Log what happened. 2441 verbose -log "get_compiler_info: $compiler_info" 2442 2443 # Most compilers will evaluate comparisons and other boolean 2444 # operations to 0 or 1. 2445 uplevel \#0 { set true 1 } 2446 uplevel \#0 { set false 0 } 2447 2448 # Use of aCC results in boolean results being displayed as 2449 # "true" or "false" 2450 if { $hp_aCC_compiler } { 2451 uplevel \#0 { set true true } 2452 uplevel \#0 { set false false } 2453 } 2454 2455 return 0; 2456} 2457 2458proc test_compiler_info { {compiler ""} } { 2459 global compiler_info 2460 2461 # if no arg, return the compiler_info string 2462 2463 if [string match "" $compiler] { 2464 if [info exists compiler_info] { 2465 return $compiler_info 2466 } else { 2467 perror "No compiler info found." 2468 } 2469 } 2470 2471 return [string match $compiler $compiler_info] 2472} 2473 2474proc current_target_name { } { 2475 global target_info 2476 if [info exists target_info(target,name)] { 2477 set answer $target_info(target,name) 2478 } else { 2479 set answer "" 2480 } 2481 return $answer 2482} 2483 2484set gdb_wrapper_initialized 0 2485set gdb_wrapper_target "" 2486 2487proc gdb_wrapper_init { args } { 2488 global gdb_wrapper_initialized; 2489 global gdb_wrapper_file; 2490 global gdb_wrapper_flags; 2491 global gdb_wrapper_target 2492 2493 if { $gdb_wrapper_initialized == 1 } { return; } 2494 2495 if {[target_info exists needs_status_wrapper] && \ 2496 [target_info needs_status_wrapper] != "0"} { 2497 set result [build_wrapper "testglue.o"]; 2498 if { $result != "" } { 2499 set gdb_wrapper_file [lindex $result 0]; 2500 set gdb_wrapper_flags [lindex $result 1]; 2501 } else { 2502 warning "Status wrapper failed to build." 2503 } 2504 } 2505 set gdb_wrapper_initialized 1 2506 set gdb_wrapper_target [current_target_name] 2507} 2508 2509# Some targets need to always link a special object in. Save its path here. 2510global gdb_saved_set_unbuffered_mode_obj 2511set gdb_saved_set_unbuffered_mode_obj "" 2512 2513proc gdb_compile {source dest type options} { 2514 global GDB_TESTCASE_OPTIONS; 2515 global gdb_wrapper_file; 2516 global gdb_wrapper_flags; 2517 global gdb_wrapper_initialized; 2518 global srcdir 2519 global objdir 2520 global gdb_saved_set_unbuffered_mode_obj 2521 2522 set outdir [file dirname $dest] 2523 2524 # Add platform-specific options if a shared library was specified using 2525 # "shlib=librarypath" in OPTIONS. 2526 set new_options "" 2527 set shlib_found 0 2528 set shlib_load 0 2529 foreach opt $options { 2530 if [regexp {^shlib=(.*)} $opt dummy_var shlib_name] { 2531 if [test_compiler_info "xlc-*"] { 2532 # IBM xlc compiler doesn't accept shared library named other 2533 # than .so: use "-Wl," to bypass this 2534 lappend source "-Wl,$shlib_name" 2535 } elseif { ([istarget "*-*-mingw*"] 2536 || [istarget *-*-cygwin*] 2537 || [istarget *-*-pe*])} { 2538 lappend source "${shlib_name}.a" 2539 } else { 2540 lappend source $shlib_name 2541 } 2542 if { $shlib_found == 0 } { 2543 set shlib_found 1 2544 if { ([istarget "*-*-mingw*"] 2545 || [istarget *-*-cygwin*]) } { 2546 lappend new_options "additional_flags=-Wl,--enable-auto-import" 2547 } 2548 } 2549 } elseif { $opt == "shlib_load" } { 2550 set shlib_load 1 2551 } else { 2552 lappend new_options $opt 2553 } 2554 } 2555 2556 # We typically link to shared libraries using an absolute path, and 2557 # that's how they are found at runtime. If we are going to 2558 # dynamically load one by basename, we must specify rpath. If we 2559 # are using a remote host, DejaGNU will link to the shared library 2560 # using a relative path, so again we must specify an rpath. 2561 if { $shlib_load || ($shlib_found && [is_remote target]) } { 2562 if { ([istarget "*-*-mingw*"] 2563 || [istarget *-*-cygwin*] 2564 || [istarget *-*-pe*] 2565 || [istarget hppa*-*-hpux*])} { 2566 # Do not need anything. 2567 } elseif { [istarget *-*-freebsd*] || [istarget *-*-openbsd*] } { 2568 lappend new_options "ldflags=-Wl,-rpath,${outdir}" 2569 } elseif { [istarget arm*-*-symbianelf*] } { 2570 if { $shlib_load } { 2571 lappend new_options "libs=-ldl" 2572 } 2573 } else { 2574 if { $shlib_load } { 2575 lappend new_options "libs=-ldl" 2576 } 2577 lappend new_options "ldflags=-Wl,-rpath,\\\$ORIGIN" 2578 } 2579 } 2580 set options $new_options 2581 2582 if [target_info exists is_vxworks] { 2583 set options2 { "additional_flags=-Dvxworks" } 2584 set options [concat $options2 $options] 2585 } 2586 if [info exists GDB_TESTCASE_OPTIONS] { 2587 lappend options "additional_flags=$GDB_TESTCASE_OPTIONS"; 2588 } 2589 verbose "options are $options" 2590 verbose "source is $source $dest $type $options" 2591 2592 if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init } 2593 2594 if {[target_info exists needs_status_wrapper] && \ 2595 [target_info needs_status_wrapper] != "0" && \ 2596 [info exists gdb_wrapper_file]} { 2597 lappend options "libs=${gdb_wrapper_file}" 2598 lappend options "ldflags=${gdb_wrapper_flags}" 2599 } 2600 2601 # Replace the "nowarnings" option with the appropriate additional_flags 2602 # to disable compiler warnings. 2603 set nowarnings [lsearch -exact $options nowarnings] 2604 if {$nowarnings != -1} { 2605 if [target_info exists gdb,nowarnings_flag] { 2606 set flag "additional_flags=[target_info gdb,nowarnings_flag]" 2607 } else { 2608 set flag "additional_flags=-w" 2609 } 2610 set options [lreplace $options $nowarnings $nowarnings $flag] 2611 } 2612 2613 if { $type == "executable" } { 2614 if { ([istarget "*-*-mingw*"] 2615 || [istarget "*-*-*djgpp"] 2616 || [istarget "*-*-cygwin*"])} { 2617 # Force output to unbuffered mode, by linking in an object file 2618 # with a global contructor that calls setvbuf. 2619 # 2620 # Compile the special object seperatelly for two reasons: 2621 # 1) Insulate it from $options. 2622 # 2) Avoid compiling it for every gdb_compile invocation, 2623 # which is time consuming, especially if we're remote 2624 # host testing. 2625 # 2626 if { $gdb_saved_set_unbuffered_mode_obj == "" } { 2627 verbose "compiling gdb_saved_set_unbuffered_obj" 2628 set unbuf_src ${srcdir}/lib/set_unbuffered_mode.c 2629 set unbuf_obj ${objdir}/set_unbuffered_mode.o 2630 2631 set result [gdb_compile "${unbuf_src}" "${unbuf_obj}" object {nowarnings}] 2632 if { $result != "" } { 2633 return $result 2634 } 2635 2636 set gdb_saved_set_unbuffered_mode_obj ${objdir}/set_unbuffered_mode_saved.o 2637 # Link a copy of the output object, because the 2638 # original may be automatically deleted. 2639 remote_exec host "cp -f $unbuf_obj $gdb_saved_set_unbuffered_mode_obj" 2640 } else { 2641 verbose "gdb_saved_set_unbuffered_obj already compiled" 2642 } 2643 2644 # Rely on the internal knowledge that the global ctors are ran in 2645 # reverse link order. In that case, we can use ldflags to 2646 # avoid copying the object file to the host multiple 2647 # times. 2648 # This object can only be added if standard libraries are 2649 # used. Thus, we need to disable it if -nostdlib option is used 2650 if {[lsearch -regexp $options "-nostdlib"] < 0 } { 2651 lappend options "ldflags=$gdb_saved_set_unbuffered_mode_obj" 2652 } 2653 } 2654 } 2655 2656 set result [target_compile $source $dest $type $options]; 2657 2658 # Prune uninteresting compiler (and linker) output. 2659 regsub "Creating library file: \[^\r\n\]*\[\r\n\]+" $result "" result 2660 2661 regsub "\[\r\n\]*$" "$result" "" result; 2662 regsub "^\[\r\n\]*" "$result" "" result; 2663 2664 if {[lsearch $options quiet] < 0} { 2665 # We shall update this on a per language basis, to avoid 2666 # changing the entire testsuite in one go. 2667 if {[lsearch $options f77] >= 0} { 2668 gdb_compile_test $source $result 2669 } elseif { $result != "" } { 2670 clone_output "gdb compile failed, $result" 2671 } 2672 } 2673 return $result; 2674} 2675 2676 2677# This is just like gdb_compile, above, except that it tries compiling 2678# against several different thread libraries, to see which one this 2679# system has. 2680proc gdb_compile_pthreads {source dest type options} { 2681 set built_binfile 0 2682 set why_msg "unrecognized error" 2683 foreach lib {-lpthreads -lpthread -lthread ""} { 2684 # This kind of wipes out whatever libs the caller may have 2685 # set. Or maybe theirs will override ours. How infelicitous. 2686 set options_with_lib [concat $options [list libs=$lib quiet]] 2687 set ccout [gdb_compile $source $dest $type $options_with_lib] 2688 switch -regexp -- $ccout { 2689 ".*no posix threads support.*" { 2690 set why_msg "missing threads include file" 2691 break 2692 } 2693 ".*cannot open -lpthread.*" { 2694 set why_msg "missing runtime threads library" 2695 } 2696 ".*Can't find library for -lpthread.*" { 2697 set why_msg "missing runtime threads library" 2698 } 2699 {^$} { 2700 pass "successfully compiled posix threads test case" 2701 set built_binfile 1 2702 break 2703 } 2704 } 2705 } 2706 if {!$built_binfile} { 2707 unsupported "Couldn't compile $source: ${why_msg}" 2708 return -1 2709 } 2710} 2711 2712# Build a shared library from SOURCES. You must use get_compiler_info 2713# first. 2714 2715proc gdb_compile_shlib {sources dest options} { 2716 set obj_options $options 2717 2718 switch -glob [test_compiler_info] { 2719 "xlc-*" { 2720 lappend obj_options "additional_flags=-qpic" 2721 } 2722 "gcc-*" { 2723 if { !([istarget "powerpc*-*-aix*"] 2724 || [istarget "rs6000*-*-aix*"] 2725 || [istarget "*-*-cygwin*"] 2726 || [istarget "*-*-mingw*"] 2727 || [istarget "*-*-pe*"]) } { 2728 lappend obj_options "additional_flags=-fpic" 2729 } 2730 } 2731 default { 2732 switch -glob [istarget] { 2733 "hppa*-hp-hpux*" { 2734 lappend obj_options "additional_flags=+z" 2735 } 2736 "mips-sgi-irix*" { 2737 # Disable SGI compiler's implicit -Dsgi 2738 lappend obj_options "additional_flags=-Usgi" 2739 } 2740 default { 2741 # don't know what the compiler is... 2742 } 2743 } 2744 } 2745 } 2746 2747 set outdir [file dirname $dest] 2748 set objects "" 2749 foreach source $sources { 2750 set sourcebase [file tail $source] 2751 if {[gdb_compile $source "${outdir}/${sourcebase}.o" object $obj_options] != ""} { 2752 return -1 2753 } 2754 lappend objects ${outdir}/${sourcebase}.o 2755 } 2756 2757 if [istarget "hppa*-*-hpux*"] { 2758 remote_exec build "ld -b ${objects} -o ${dest}" 2759 } else { 2760 set link_options $options 2761 if [test_compiler_info "xlc-*"] { 2762 lappend link_options "additional_flags=-qmkshrobj" 2763 } else { 2764 lappend link_options "additional_flags=-shared" 2765 2766 if { ([istarget "*-*-mingw*"] 2767 || [istarget *-*-cygwin*] 2768 || [istarget *-*-pe*])} { 2769 lappend link_options "additional_flags=-Wl,--out-implib,${dest}.a" 2770 } elseif [is_remote target] { 2771 # By default, we do not set the soname. This causes the linker 2772 # on ELF systems to create a DT_NEEDED entry in the executable 2773 # refering to the full path name of the library. This is a 2774 # problem in remote testing if the library is in a different 2775 # directory there. To fix this, we set a soname of just the 2776 # base filename for the library, and add an appropriate -rpath 2777 # to the main executable (in gdb_compile). 2778 set destbase [file tail $dest] 2779 lappend link_options "additional_flags=-Wl,-soname,$destbase" 2780 } 2781 } 2782 if {[gdb_compile "${objects}" "${dest}" executable $link_options] != ""} { 2783 return -1 2784 } 2785 } 2786} 2787 2788# This is just like gdb_compile_shlib, above, except that it tries compiling 2789# against several different thread libraries, to see which one this 2790# system has. 2791proc gdb_compile_shlib_pthreads {sources dest options} { 2792 set built_binfile 0 2793 set why_msg "unrecognized error" 2794 foreach lib {-lpthreads -lpthread -lthread ""} { 2795 # This kind of wipes out whatever libs the caller may have 2796 # set. Or maybe theirs will override ours. How infelicitous. 2797 set options_with_lib [concat $options [list libs=$lib quiet]] 2798 set ccout [gdb_compile_shlib $sources $dest $options_with_lib] 2799 switch -regexp -- $ccout { 2800 ".*no posix threads support.*" { 2801 set why_msg "missing threads include file" 2802 break 2803 } 2804 ".*cannot open -lpthread.*" { 2805 set why_msg "missing runtime threads library" 2806 } 2807 ".*Can't find library for -lpthread.*" { 2808 set why_msg "missing runtime threads library" 2809 } 2810 {^$} { 2811 pass "successfully compiled posix threads test case" 2812 set built_binfile 1 2813 break 2814 } 2815 } 2816 } 2817 if {!$built_binfile} { 2818 unsupported "Couldn't compile $sources: ${why_msg}" 2819 return -1 2820 } 2821} 2822 2823# This is just like gdb_compile_pthreads, above, except that we always add the 2824# objc library for compiling Objective-C programs 2825proc gdb_compile_objc {source dest type options} { 2826 set built_binfile 0 2827 set why_msg "unrecognized error" 2828 foreach lib {-lobjc -lpthreads -lpthread -lthread solaris} { 2829 # This kind of wipes out whatever libs the caller may have 2830 # set. Or maybe theirs will override ours. How infelicitous. 2831 if { $lib == "solaris" } { 2832 set lib "-lpthread -lposix4" 2833 } 2834 if { $lib != "-lobjc" } { 2835 set lib "-lobjc $lib" 2836 } 2837 set options_with_lib [concat $options [list libs=$lib quiet]] 2838 set ccout [gdb_compile $source $dest $type $options_with_lib] 2839 switch -regexp -- $ccout { 2840 ".*no posix threads support.*" { 2841 set why_msg "missing threads include file" 2842 break 2843 } 2844 ".*cannot open -lpthread.*" { 2845 set why_msg "missing runtime threads library" 2846 } 2847 ".*Can't find library for -lpthread.*" { 2848 set why_msg "missing runtime threads library" 2849 } 2850 {^$} { 2851 pass "successfully compiled objc with posix threads test case" 2852 set built_binfile 1 2853 break 2854 } 2855 } 2856 } 2857 if {!$built_binfile} { 2858 unsupported "Couldn't compile $source: ${why_msg}" 2859 return -1 2860 } 2861} 2862 2863proc send_gdb { string } { 2864 global suppress_flag; 2865 if { $suppress_flag } { 2866 return "suppressed"; 2867 } 2868 return [remote_send host "$string"]; 2869} 2870 2871# 2872# 2873 2874proc gdb_expect { args } { 2875 if { [llength $args] == 2 && [lindex $args 0] != "-re" } { 2876 set atimeout [lindex $args 0]; 2877 set expcode [list [lindex $args 1]]; 2878 } else { 2879 set expcode $args; 2880 } 2881 2882 upvar timeout timeout; 2883 2884 if [target_info exists gdb,timeout] { 2885 if [info exists timeout] { 2886 if { $timeout < [target_info gdb,timeout] } { 2887 set gtimeout [target_info gdb,timeout]; 2888 } else { 2889 set gtimeout $timeout; 2890 } 2891 } else { 2892 set gtimeout [target_info gdb,timeout]; 2893 } 2894 } 2895 2896 if ![info exists gtimeout] { 2897 global timeout; 2898 if [info exists timeout] { 2899 set gtimeout $timeout; 2900 } 2901 } 2902 2903 if [info exists atimeout] { 2904 if { ![info exists gtimeout] || $gtimeout < $atimeout } { 2905 set gtimeout $atimeout; 2906 } 2907 } else { 2908 if ![info exists gtimeout] { 2909 # Eeeeew. 2910 set gtimeout 60; 2911 } 2912 } 2913 2914 global suppress_flag; 2915 global remote_suppress_flag; 2916 if [info exists remote_suppress_flag] { 2917 set old_val $remote_suppress_flag; 2918 } 2919 if [info exists suppress_flag] { 2920 if { $suppress_flag } { 2921 set remote_suppress_flag 1; 2922 } 2923 } 2924 set code [catch \ 2925 {uplevel remote_expect host $gtimeout $expcode} string]; 2926 if [info exists old_val] { 2927 set remote_suppress_flag $old_val; 2928 } else { 2929 if [info exists remote_suppress_flag] { 2930 unset remote_suppress_flag; 2931 } 2932 } 2933 2934 if {$code == 1} { 2935 global errorInfo errorCode; 2936 2937 return -code error -errorinfo $errorInfo -errorcode $errorCode $string 2938 } else { 2939 return -code $code $string 2940 } 2941} 2942 2943# gdb_expect_list TEST SENTINEL LIST -- expect a sequence of outputs 2944# 2945# Check for long sequence of output by parts. 2946# TEST: is the test message to be printed with the test success/fail. 2947# SENTINEL: Is the terminal pattern indicating that output has finished. 2948# LIST: is the sequence of outputs to match. 2949# If the sentinel is recognized early, it is considered an error. 2950# 2951# Returns: 2952# 1 if the test failed, 2953# 0 if the test passes, 2954# -1 if there was an internal error. 2955 2956proc gdb_expect_list {test sentinel list} { 2957 global gdb_prompt 2958 global suppress_flag 2959 set index 0 2960 set ok 1 2961 if { $suppress_flag } { 2962 set ok 0 2963 unresolved "${test}" 2964 } 2965 while { ${index} < [llength ${list}] } { 2966 set pattern [lindex ${list} ${index}] 2967 set index [expr ${index} + 1] 2968 verbose -log "gdb_expect_list pattern: /$pattern/" 2 2969 if { ${index} == [llength ${list}] } { 2970 if { ${ok} } { 2971 gdb_expect { 2972 -re "${pattern}${sentinel}" { 2973 # pass "${test}, pattern ${index} + sentinel" 2974 } 2975 -re "${sentinel}" { 2976 fail "${test} (pattern ${index} + sentinel)" 2977 set ok 0 2978 } 2979 -re ".*A problem internal to GDB has been detected" { 2980 fail "${test} (GDB internal error)" 2981 set ok 0 2982 gdb_internal_error_resync 2983 } 2984 timeout { 2985 fail "${test} (pattern ${index} + sentinel) (timeout)" 2986 set ok 0 2987 } 2988 } 2989 } else { 2990 # unresolved "${test}, pattern ${index} + sentinel" 2991 } 2992 } else { 2993 if { ${ok} } { 2994 gdb_expect { 2995 -re "${pattern}" { 2996 # pass "${test}, pattern ${index}" 2997 } 2998 -re "${sentinel}" { 2999 fail "${test} (pattern ${index})" 3000 set ok 0 3001 } 3002 -re ".*A problem internal to GDB has been detected" { 3003 fail "${test} (GDB internal error)" 3004 set ok 0 3005 gdb_internal_error_resync 3006 } 3007 timeout { 3008 fail "${test} (pattern ${index}) (timeout)" 3009 set ok 0 3010 } 3011 } 3012 } else { 3013 # unresolved "${test}, pattern ${index}" 3014 } 3015 } 3016 } 3017 if { ${ok} } { 3018 pass "${test}" 3019 return 0 3020 } else { 3021 return 1 3022 } 3023} 3024 3025# 3026# 3027proc gdb_suppress_entire_file { reason } { 3028 global suppress_flag; 3029 3030 warning "$reason\n"; 3031 set suppress_flag -1; 3032} 3033 3034# 3035# Set suppress_flag, which will cause all subsequent calls to send_gdb and 3036# gdb_expect to fail immediately (until the next call to 3037# gdb_stop_suppressing_tests). 3038# 3039proc gdb_suppress_tests { args } { 3040 global suppress_flag; 3041 3042 return; # fnf - disable pending review of results where 3043 # testsuite ran better without this 3044 incr suppress_flag; 3045 3046 if { $suppress_flag == 1 } { 3047 if { [llength $args] > 0 } { 3048 warning "[lindex $args 0]\n"; 3049 } else { 3050 warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n"; 3051 } 3052 } 3053} 3054 3055# 3056# Clear suppress_flag. 3057# 3058proc gdb_stop_suppressing_tests { } { 3059 global suppress_flag; 3060 3061 if [info exists suppress_flag] { 3062 if { $suppress_flag > 0 } { 3063 set suppress_flag 0; 3064 clone_output "Tests restarted.\n"; 3065 } 3066 } else { 3067 set suppress_flag 0; 3068 } 3069} 3070 3071proc gdb_clear_suppressed { } { 3072 global suppress_flag; 3073 3074 set suppress_flag 0; 3075} 3076 3077proc gdb_start { } { 3078 default_gdb_start 3079} 3080 3081proc gdb_exit { } { 3082 catch default_gdb_exit 3083} 3084 3085# 3086# gdb_load_cmd -- load a file into the debugger. 3087# ARGS - additional args to load command. 3088# return a -1 if anything goes wrong. 3089# 3090proc gdb_load_cmd { args } { 3091 global gdb_prompt 3092 3093 if [target_info exists gdb_load_timeout] { 3094 set loadtimeout [target_info gdb_load_timeout] 3095 } else { 3096 set loadtimeout 1600 3097 } 3098 send_gdb "load $args\n" 3099 verbose "Timeout is now $loadtimeout seconds" 2 3100 gdb_expect $loadtimeout { 3101 -re "Loading section\[^\r\]*\r\n" { 3102 exp_continue 3103 } 3104 -re "Start address\[\r\]*\r\n" { 3105 exp_continue 3106 } 3107 -re "Transfer rate\[\r\]*\r\n" { 3108 exp_continue 3109 } 3110 -re "Memory access error\[^\r\]*\r\n" { 3111 perror "Failed to load program" 3112 return -1 3113 } 3114 -re "$gdb_prompt $" { 3115 return 0 3116 } 3117 -re "(.*)\r\n$gdb_prompt " { 3118 perror "Unexpected reponse from 'load' -- $expect_out(1,string)" 3119 return -1 3120 } 3121 timeout { 3122 perror "Timed out trying to load $args." 3123 return -1 3124 } 3125 } 3126 return -1 3127} 3128 3129# Invoke "gcore". CORE is the name of the core file to write. TEST 3130# is the name of the test case. This will return 1 if the core file 3131# was created, 0 otherwise. If this fails to make a core file because 3132# this configuration of gdb does not support making core files, it 3133# will call "unsupported", not "fail". However, if this fails to make 3134# a core file for some other reason, then it will call "fail". 3135 3136proc gdb_gcore_cmd {core test} { 3137 global gdb_prompt 3138 3139 set result 0 3140 gdb_test_multiple "gcore $core" $test { 3141 -re "Saved corefile .*\[\r\n\]+$gdb_prompt $" { 3142 pass $test 3143 set result 1 3144 } 3145 3146 -re "Undefined command.*$gdb_prompt $" { 3147 unsupported $test 3148 verbose -log "'gcore' command undefined in gdb_gcore_cmd" 3149 } 3150 3151 -re "Can't create a corefile\[\r\n\]+$gdb_prompt $" { 3152 unsupported $test 3153 } 3154 } 3155 3156 return $result 3157} 3158 3159# Return the filename to download to the target and load on the target 3160# for this shared library. Normally just LIBNAME, unless shared libraries 3161# for this target have separate link and load images. 3162 3163proc shlib_target_file { libname } { 3164 return $libname 3165} 3166 3167# Return the filename GDB will load symbols from when debugging this 3168# shared library. Normally just LIBNAME, unless shared libraries for 3169# this target have separate link and load images. 3170 3171proc shlib_symbol_file { libname } { 3172 return $libname 3173} 3174 3175# Return the filename to download to the target and load for this 3176# executable. Normally just BINFILE unless it is renamed to something 3177# else for this target. 3178 3179proc exec_target_file { binfile } { 3180 return $binfile 3181} 3182 3183# Return the filename GDB will load symbols from when debugging this 3184# executable. Normally just BINFILE unless executables for this target 3185# have separate files for symbols. 3186 3187proc exec_symbol_file { binfile } { 3188 return $binfile 3189} 3190 3191# Rename the executable file. Normally this is just BINFILE1 being renamed 3192# to BINFILE2, but some targets require multiple binary files. 3193proc gdb_rename_execfile { binfile1 binfile2 } { 3194 file rename -force [exec_target_file ${binfile1}] \ 3195 [exec_target_file ${binfile2}] 3196 if { [exec_target_file ${binfile1}] != [exec_symbol_file ${binfile1}] } { 3197 file rename -force [exec_symbol_file ${binfile1}] \ 3198 [exec_symbol_file ${binfile2}] 3199 } 3200} 3201 3202# "Touch" the executable file to update the date. Normally this is just 3203# BINFILE, but some targets require multiple files. 3204proc gdb_touch_execfile { binfile } { 3205 set time [clock seconds] 3206 file mtime [exec_target_file ${binfile}] $time 3207 if { [exec_target_file ${binfile}] != [exec_symbol_file ${binfile}] } { 3208 file mtime [exec_symbol_file ${binfile}] $time 3209 } 3210} 3211 3212# gdb_download 3213# 3214# Copy a file to the remote target and return its target filename. 3215# Schedule the file to be deleted at the end of this test. 3216 3217proc gdb_download { filename } { 3218 global cleanfiles 3219 3220 set destname [remote_download target $filename] 3221 lappend cleanfiles $destname 3222 return $destname 3223} 3224 3225# gdb_load_shlibs LIB... 3226# 3227# Copy the listed libraries to the target. 3228 3229proc gdb_load_shlibs { args } { 3230 if {![is_remote target]} { 3231 return 3232 } 3233 3234 foreach file $args { 3235 gdb_download [shlib_target_file $file] 3236 } 3237 3238 # Even if the target supplies full paths for shared libraries, 3239 # they may not be paths for this system. 3240 gdb_test "set solib-search-path [file dirname [lindex $args 0]]" "" "" 3241} 3242 3243# 3244# gdb_load -- load a file into the debugger. 3245# Many files in config/*.exp override this procedure. 3246# 3247proc gdb_load { arg } { 3248 return [gdb_file_cmd $arg] 3249} 3250 3251# gdb_reload -- load a file into the target. Called before "running", 3252# either the first time or after already starting the program once, 3253# for remote targets. Most files that override gdb_load should now 3254# override this instead. 3255 3256proc gdb_reload { } { 3257 # For the benefit of existing configurations, default to gdb_load. 3258 # Specifying no file defaults to the executable currently being 3259 # debugged. 3260 return [gdb_load ""] 3261} 3262 3263proc gdb_continue { function } { 3264 global decimal 3265 3266 return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"]; 3267} 3268 3269proc default_gdb_init { args } { 3270 global gdb_wrapper_initialized 3271 global gdb_wrapper_target 3272 global gdb_test_file_name 3273 global cleanfiles 3274 3275 set cleanfiles {} 3276 3277 gdb_clear_suppressed; 3278 3279 set gdb_test_file_name [file rootname [file tail [lindex $args 0]]] 3280 3281 # Make sure that the wrapper is rebuilt 3282 # with the appropriate multilib option. 3283 if { $gdb_wrapper_target != [current_target_name] } { 3284 set gdb_wrapper_initialized 0 3285 } 3286 3287 # Unlike most tests, we have a small number of tests that generate 3288 # a very large amount of output. We therefore increase the expect 3289 # buffer size to be able to contain the entire test output. 3290 match_max -d 30000 3291 # Also set this value for the currently running GDB. 3292 match_max [match_max -d] 3293 3294 # We want to add the name of the TCL testcase to the PASS/FAIL messages. 3295 if { [llength $args] > 0 } { 3296 global pf_prefix 3297 3298 set file [lindex $args 0]; 3299 3300 set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:"; 3301 } 3302 global gdb_prompt; 3303 if [target_info exists gdb_prompt] { 3304 set gdb_prompt [target_info gdb_prompt]; 3305 } else { 3306 set gdb_prompt "\\(gdb\\)" 3307 } 3308 global use_gdb_stub 3309 if [info exists use_gdb_stub] { 3310 unset use_gdb_stub 3311 } 3312} 3313 3314# Turn BASENAME into a full file name in the standard output 3315# directory. It is ok if BASENAME is the empty string; in this case 3316# the directory is returned. 3317 3318proc standard_output_file {basename} { 3319 global objdir subdir 3320 3321 return [file join $objdir $subdir $basename] 3322} 3323 3324# Set 'testfile', 'srcfile', and 'binfile'. 3325# 3326# ARGS is a list of source file specifications. 3327# Without any arguments, the .exp file's base name is used to 3328# compute the source file name. The ".c" extension is added in this case. 3329# If ARGS is not empty, each entry is a source file specification. 3330# If the specification starts with a ".", it is treated as a suffix 3331# to append to the .exp file's base name. 3332# If the specification is the empty string, it is treated as if it 3333# were ".c". 3334# Otherwise it is a file name. 3335# The first file in the list is used to set the 'srcfile' global. 3336# Each subsequent name is used to set 'srcfile2', 'srcfile3', etc. 3337# 3338# Most tests should call this without arguments. 3339# 3340# If a completely different binary file name is needed, then it 3341# should be handled in the .exp file with a suitable comment. 3342 3343proc standard_testfile {args} { 3344 global gdb_test_file_name 3345 global subdir 3346 global gdb_test_file_last_vars 3347 3348 # Outputs. 3349 global testfile binfile 3350 3351 set testfile $gdb_test_file_name 3352 set binfile [standard_output_file ${testfile}] 3353 3354 if {[llength $args] == 0} { 3355 set args .c 3356 } 3357 3358 # Unset our previous output variables. 3359 # This can help catch hidden bugs. 3360 if {[info exists gdb_test_file_last_vars]} { 3361 foreach varname $gdb_test_file_last_vars { 3362 global $varname 3363 catch {unset $varname} 3364 } 3365 } 3366 # 'executable' is often set by tests. 3367 set gdb_test_file_last_vars {executable} 3368 3369 set suffix "" 3370 foreach arg $args { 3371 set varname srcfile$suffix 3372 global $varname 3373 3374 # Handle an extension. 3375 if {$arg == ""} { 3376 set arg $testfile.c 3377 } elseif {[string range $arg 0 0] == "."} { 3378 set arg $testfile$arg 3379 } 3380 3381 set $varname $arg 3382 lappend gdb_test_file_last_vars $varname 3383 3384 if {$suffix == ""} { 3385 set suffix 2 3386 } else { 3387 incr suffix 3388 } 3389 } 3390} 3391 3392# The default timeout used when testing GDB commands. We want to use 3393# the same timeout as the default dejagnu timeout, unless the user has 3394# already provided a specific value (probably through a site.exp file). 3395global gdb_test_timeout 3396if ![info exists gdb_test_timeout] { 3397 set gdb_test_timeout $timeout 3398} 3399 3400# A list of global variables that GDB testcases should not use. 3401# We try to prevent their use by monitoring write accesses and raising 3402# an error when that happens. 3403set banned_variables { bug_id prms_id } 3404 3405# A list of procedures that GDB testcases should not use. 3406# We try to prevent their use by monitoring invocations and raising 3407# an error when that happens. 3408set banned_procedures { strace } 3409 3410# gdb_init is called by runtest at start, but also by several 3411# tests directly; gdb_finish is only called from within runtest after 3412# each test source execution. 3413# Placing several traces by repetitive calls to gdb_init leads 3414# to problems, as only one trace is removed in gdb_finish. 3415# To overcome this possible problem, we add a variable that records 3416# if the banned variables and procedures are already traced. 3417set banned_traced 0 3418 3419proc gdb_init { args } { 3420 # Reset the timeout value to the default. This way, any testcase 3421 # that changes the timeout value without resetting it cannot affect 3422 # the timeout used in subsequent testcases. 3423 global gdb_test_timeout 3424 global timeout 3425 set timeout $gdb_test_timeout 3426 3427 # Block writes to all banned variables, and invocation of all 3428 # banned procedures... 3429 global banned_variables 3430 global banned_procedures 3431 global banned_traced 3432 if (!$banned_traced) { 3433 foreach banned_var $banned_variables { 3434 global "$banned_var" 3435 trace add variable "$banned_var" write error 3436 } 3437 foreach banned_proc $banned_procedures { 3438 global "$banned_proc" 3439 trace add execution "$banned_proc" enter error 3440 } 3441 set banned_traced 1 3442 } 3443 3444 # We set LC_ALL, LC_CTYPE, and LANG to C so that we get the same 3445 # messages as expected. 3446 setenv LC_ALL C 3447 setenv LC_CTYPE C 3448 setenv LANG C 3449 3450 # Don't let a .inputrc file or an existing setting of INPUTRC mess up 3451 # the test results. Even if /dev/null doesn't exist on the particular 3452 # platform, the readline library will use the default setting just by 3453 # failing to open the file. OTOH, opening /dev/null successfully will 3454 # also result in the default settings being used since nothing will be 3455 # read from this file. 3456 setenv INPUTRC "/dev/null" 3457 3458 # The gdb.base/readline.exp arrow key test relies on the standard VT100 3459 # bindings, so make sure that an appropriate terminal is selected. 3460 # The same bug doesn't show up if we use ^P / ^N instead. 3461 setenv TERM "vt100" 3462 3463 # Some tests (for example gdb.base/maint.exp) shell out from gdb to use 3464 # grep. Clear GREP_OPTIONS to make the behavoiur predictable, 3465 # especially having color output turned on can cause tests to fail. 3466 setenv GREP_OPTIONS "" 3467 3468 # Clear $gdbserver_reconnect_p. 3469 global gdbserver_reconnect_p 3470 set gdbserver_reconnect_p 1 3471 unset gdbserver_reconnect_p 3472 3473 return [eval default_gdb_init $args]; 3474} 3475 3476proc gdb_finish { } { 3477 global cleanfiles 3478 3479 # Exit first, so that the files are no longer in use. 3480 gdb_exit 3481 3482 if { [llength $cleanfiles] > 0 } { 3483 eval remote_file target delete $cleanfiles 3484 set cleanfiles {} 3485 } 3486 3487 # Unblock write access to the banned variables. Dejagnu typically 3488 # resets some of them between testcases. 3489 global banned_variables 3490 global banned_procedures 3491 global banned_traced 3492 if ($banned_traced) { 3493 foreach banned_var $banned_variables { 3494 global "$banned_var" 3495 trace remove variable "$banned_var" write error 3496 } 3497 foreach banned_proc $banned_procedures { 3498 global "$banned_proc" 3499 trace remove execution "$banned_proc" enter error 3500 } 3501 set banned_traced 0 3502 } 3503} 3504 3505global debug_format 3506set debug_format "unknown" 3507 3508# Run the gdb command "info source" and extract the debugging format 3509# information from the output and save it in debug_format. 3510 3511proc get_debug_format { } { 3512 global gdb_prompt 3513 global verbose 3514 global expect_out 3515 global debug_format 3516 3517 set debug_format "unknown" 3518 send_gdb "info source\n" 3519 gdb_expect 10 { 3520 -re "Compiled with (.*) debugging format.\r\n.*$gdb_prompt $" { 3521 set debug_format $expect_out(1,string) 3522 verbose "debug format is $debug_format" 3523 return 1; 3524 } 3525 -re "No current source file.\r\n$gdb_prompt $" { 3526 perror "get_debug_format used when no current source file" 3527 return 0; 3528 } 3529 -re "$gdb_prompt $" { 3530 warning "couldn't check debug format (no valid response)." 3531 return 1; 3532 } 3533 timeout { 3534 warning "couldn't check debug format (timeout)." 3535 return 1; 3536 } 3537 } 3538} 3539 3540# Return true if FORMAT matches the debug format the current test was 3541# compiled with. FORMAT is a shell-style globbing pattern; it can use 3542# `*', `[...]', and so on. 3543# 3544# This function depends on variables set by `get_debug_format', above. 3545 3546proc test_debug_format {format} { 3547 global debug_format 3548 3549 return [expr [string match $format $debug_format] != 0] 3550} 3551 3552# Like setup_xfail, but takes the name of a debug format (DWARF 1, 3553# COFF, stabs, etc). If that format matches the format that the 3554# current test was compiled with, then the next test is expected to 3555# fail for any target. Returns 1 if the next test or set of tests is 3556# expected to fail, 0 otherwise (or if it is unknown). Must have 3557# previously called get_debug_format. 3558proc setup_xfail_format { format } { 3559 set ret [test_debug_format $format]; 3560 3561 if {$ret} then { 3562 setup_xfail "*-*-*" 3563 } 3564 return $ret; 3565} 3566 3567# gdb_get_line_number TEXT [FILE] 3568# 3569# Search the source file FILE, and return the line number of the 3570# first line containing TEXT. If no match is found, an error is thrown. 3571# 3572# TEXT is a string literal, not a regular expression. 3573# 3574# The default value of FILE is "$srcdir/$subdir/$srcfile". If FILE is 3575# specified, and does not start with "/", then it is assumed to be in 3576# "$srcdir/$subdir". This is awkward, and can be fixed in the future, 3577# by changing the callers and the interface at the same time. 3578# In particular: gdb.base/break.exp, gdb.base/condbreak.exp, 3579# gdb.base/ena-dis-br.exp. 3580# 3581# Use this function to keep your test scripts independent of the 3582# exact line numbering of the source file. Don't write: 3583# 3584# send_gdb "break 20" 3585# 3586# This means that if anyone ever edits your test's source file, 3587# your test could break. Instead, put a comment like this on the 3588# source file line you want to break at: 3589# 3590# /* breakpoint spot: frotz.exp: test name */ 3591# 3592# and then write, in your test script (which we assume is named 3593# frotz.exp): 3594# 3595# send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n" 3596# 3597# (Yes, Tcl knows how to handle the nested quotes and brackets. 3598# Try this: 3599# $ tclsh 3600# % puts "foo [lindex "bar baz" 1]" 3601# foo baz 3602# % 3603# Tcl is quite clever, for a little stringy language.) 3604# 3605# === 3606# 3607# The previous implementation of this procedure used the gdb search command. 3608# This version is different: 3609# 3610# . It works with MI, and it also works when gdb is not running. 3611# 3612# . It operates on the build machine, not the host machine. 3613# 3614# . For now, this implementation fakes a current directory of 3615# $srcdir/$subdir to be compatible with the old implementation. 3616# This will go away eventually and some callers will need to 3617# be changed. 3618# 3619# . The TEXT argument is literal text and matches literally, 3620# not a regular expression as it was before. 3621# 3622# . State changes in gdb, such as changing the current file 3623# and setting $_, no longer happen. 3624# 3625# After a bit of time we can forget about the differences from the 3626# old implementation. 3627# 3628# --chastain 2004-08-05 3629 3630proc gdb_get_line_number { text { file "" } } { 3631 global srcdir 3632 global subdir 3633 global srcfile 3634 3635 if { "$file" == "" } then { 3636 set file "$srcfile" 3637 } 3638 if { ! [regexp "^/" "$file"] } then { 3639 set file "$srcdir/$subdir/$file" 3640 } 3641 3642 if { [ catch { set fd [open "$file"] } message ] } then { 3643 error "$message" 3644 } 3645 3646 set found -1 3647 for { set line 1 } { 1 } { incr line } { 3648 if { [ catch { set nchar [gets "$fd" body] } message ] } then { 3649 error "$message" 3650 } 3651 if { $nchar < 0 } then { 3652 break 3653 } 3654 if { [string first "$text" "$body"] >= 0 } then { 3655 set found $line 3656 break 3657 } 3658 } 3659 3660 if { [ catch { close "$fd" } message ] } then { 3661 error "$message" 3662 } 3663 3664 if {$found == -1} { 3665 error "undefined tag \"$text\"" 3666 } 3667 3668 return $found 3669} 3670 3671# gdb_continue_to_end: 3672# The case where the target uses stubs has to be handled specially. If a 3673# stub is used, we set a breakpoint at exit because we cannot rely on 3674# exit() behavior of a remote target. 3675# 3676# MSSG is the error message that gets printed. If not given, a 3677# default is used. 3678# COMMAND is the command to invoke. If not given, "continue" is 3679# used. 3680# ALLOW_EXTRA is a flag indicating whether the test should expect 3681# extra output between the "Continuing." line and the program 3682# exiting. By default it is zero; if nonzero, any extra output 3683# is accepted. 3684 3685proc gdb_continue_to_end {{mssg ""} {command continue} {allow_extra 0}} { 3686 global inferior_exited_re use_gdb_stub 3687 3688 if {$mssg == ""} { 3689 set text "continue until exit" 3690 } else { 3691 set text "continue until exit at $mssg" 3692 } 3693 if {$allow_extra} { 3694 set extra ".*" 3695 } else { 3696 set extra "" 3697 } 3698 if $use_gdb_stub { 3699 if {![gdb_breakpoint "exit"]} { 3700 return 0 3701 } 3702 gdb_test $command "Continuing..*Breakpoint .*exit.*" \ 3703 $text 3704 } else { 3705 # Continue until we exit. Should not stop again. 3706 # Don't bother to check the output of the program, that may be 3707 # extremely tough for some remote systems. 3708 gdb_test $command \ 3709 "Continuing.\[\r\n0-9\]+${extra}(... EXIT code 0\[\r\n\]+|$inferior_exited_re normally).*"\ 3710 $text 3711 } 3712} 3713 3714proc rerun_to_main {} { 3715 global gdb_prompt use_gdb_stub 3716 3717 if $use_gdb_stub { 3718 gdb_run_cmd 3719 gdb_expect { 3720 -re ".*Breakpoint .*main .*$gdb_prompt $"\ 3721 {pass "rerun to main" ; return 0} 3722 -re "$gdb_prompt $"\ 3723 {fail "rerun to main" ; return 0} 3724 timeout {fail "(timeout) rerun to main" ; return 0} 3725 } 3726 } else { 3727 send_gdb "run\n" 3728 gdb_expect { 3729 -re "The program .* has been started already.*y or n. $" { 3730 send_gdb "y\n" 3731 exp_continue 3732 } 3733 -re "Starting program.*$gdb_prompt $"\ 3734 {pass "rerun to main" ; return 0} 3735 -re "$gdb_prompt $"\ 3736 {fail "rerun to main" ; return 0} 3737 timeout {fail "(timeout) rerun to main" ; return 0} 3738 } 3739 } 3740} 3741 3742# Print a message and return true if a test should be skipped 3743# due to lack of floating point suport. 3744 3745proc gdb_skip_float_test { msg } { 3746 if [target_info exists gdb,skip_float_tests] { 3747 verbose "Skipping test '$msg': no float tests."; 3748 return 1; 3749 } 3750 return 0; 3751} 3752 3753# Print a message and return true if a test should be skipped 3754# due to lack of stdio support. 3755 3756proc gdb_skip_stdio_test { msg } { 3757 if [target_info exists gdb,noinferiorio] { 3758 verbose "Skipping test '$msg': no inferior i/o."; 3759 return 1; 3760 } 3761 return 0; 3762} 3763 3764proc gdb_skip_bogus_test { msg } { 3765 return 0; 3766} 3767 3768# Return true if a test should be skipped due to lack of XML support 3769# in the host GDB. 3770# NOTE: This must be called while gdb is *not* running. 3771 3772proc gdb_skip_xml_test { } { 3773 global gdb_prompt 3774 global srcdir 3775 global xml_missing_cached 3776 3777 if {[info exists xml_missing_cached]} { 3778 return $xml_missing_cached 3779 } 3780 3781 gdb_start 3782 set xml_missing_cached 0 3783 gdb_test_multiple "set tdesc filename ${srcdir}/gdb.xml/trivial.xml" "" { 3784 -re ".*XML support was disabled at compile time.*$gdb_prompt $" { 3785 set xml_missing_cached 1 3786 } 3787 -re ".*$gdb_prompt $" { } 3788 } 3789 gdb_exit 3790 return $xml_missing_cached 3791} 3792 3793# Note: the procedure gdb_gnu_strip_debug will produce an executable called 3794# ${binfile}.dbglnk, which is just like the executable ($binfile) but without 3795# the debuginfo. Instead $binfile has a .gnu_debuglink section which contains 3796# the name of a debuginfo only file. This file will be stored in the same 3797# subdirectory. 3798 3799# Functions for separate debug info testing 3800 3801# starting with an executable: 3802# foo --> original executable 3803 3804# at the end of the process we have: 3805# foo.stripped --> foo w/o debug info 3806# foo.debug --> foo's debug info 3807# foo --> like foo, but with a new .gnu_debuglink section pointing to foo.debug. 3808 3809# Return the build-id hex string (usually 160 bits as 40 hex characters) 3810# converted to the form: .build-id/ab/cdef1234...89.debug 3811# Return "" if no build-id found. 3812proc build_id_debug_filename_get { exec } { 3813 set tmp "${exec}-tmp" 3814 set objcopy_program [transform objcopy] 3815 3816 set result [catch "exec $objcopy_program -j .note.gnu.build-id -O binary $exec $tmp" output] 3817 verbose "result is $result" 3818 verbose "output is $output" 3819 if {$result == 1} { 3820 return "" 3821 } 3822 set fi [open $tmp] 3823 fconfigure $fi -translation binary 3824 # Skip the NOTE header. 3825 read $fi 16 3826 set data [read $fi] 3827 close $fi 3828 file delete $tmp 3829 if ![string compare $data ""] then { 3830 return "" 3831 } 3832 # Convert it to hex. 3833 binary scan $data H* data 3834 regsub {^..} $data {\0/} data 3835 return ".build-id/${data}.debug"; 3836} 3837 3838# Create stripped files for DEST, replacing it. If ARGS is passed, it is a 3839# list of optional flags. The only currently supported flag is no-main, 3840# which removes the symbol entry for main from the separate debug file. 3841# 3842# Function returns zero on success. Function will return non-zero failure code 3843# on some targets not supporting separate debug info (such as i386-msdos). 3844 3845proc gdb_gnu_strip_debug { dest args } { 3846 3847 # Use the first separate debug info file location searched by GDB so the 3848 # run cannot be broken by some stale file searched with higher precedence. 3849 set debug_file "${dest}.debug" 3850 3851 set strip_to_file_program [transform strip] 3852 set objcopy_program [transform objcopy] 3853 3854 set debug_link [file tail $debug_file] 3855 set stripped_file "${dest}.stripped" 3856 3857 # Get rid of the debug info, and store result in stripped_file 3858 # something like gdb/testsuite/gdb.base/blah.stripped. 3859 set result [catch "exec $strip_to_file_program --strip-debug ${dest} -o ${stripped_file}" output] 3860 verbose "result is $result" 3861 verbose "output is $output" 3862 if {$result == 1} { 3863 return 1 3864 } 3865 3866 # Workaround PR binutils/10802: 3867 # Preserve the 'x' bit also for PIEs (Position Independent Executables). 3868 set perm [file attributes ${dest} -permissions] 3869 file attributes ${stripped_file} -permissions $perm 3870 3871 # Get rid of everything but the debug info, and store result in debug_file 3872 # This will be in the .debug subdirectory, see above. 3873 set result [catch "exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}" output] 3874 verbose "result is $result" 3875 verbose "output is $output" 3876 if {$result == 1} { 3877 return 1 3878 } 3879 3880 # If no-main is passed, strip the symbol for main from the separate 3881 # file. This is to simulate the behavior of elfutils's eu-strip, which 3882 # leaves the symtab in the original file only. There's no way to get 3883 # objcopy or strip to remove the symbol table without also removing the 3884 # debugging sections, so this is as close as we can get. 3885 if { [llength $args] == 1 && [lindex $args 0] == "no-main" } { 3886 set result [catch "exec $objcopy_program -N main ${debug_file} ${debug_file}-tmp" output] 3887 verbose "result is $result" 3888 verbose "output is $output" 3889 if {$result == 1} { 3890 return 1 3891 } 3892 file delete "${debug_file}" 3893 file rename "${debug_file}-tmp" "${debug_file}" 3894 } 3895 3896 # Link the two previous output files together, adding the .gnu_debuglink 3897 # section to the stripped_file, containing a pointer to the debug_file, 3898 # save the new file in dest. 3899 # This will be the regular executable filename, in the usual location. 3900 set result [catch "exec $objcopy_program --add-gnu-debuglink=${debug_file} ${stripped_file} ${dest}" output] 3901 verbose "result is $result" 3902 verbose "output is $output" 3903 if {$result == 1} { 3904 return 1 3905 } 3906 3907 # Workaround PR binutils/10802: 3908 # Preserve the 'x' bit also for PIEs (Position Independent Executables). 3909 set perm [file attributes ${stripped_file} -permissions] 3910 file attributes ${dest} -permissions $perm 3911 3912 return 0 3913} 3914 3915# Test the output of GDB_COMMAND matches the pattern obtained 3916# by concatenating all elements of EXPECTED_LINES. This makes 3917# it possible to split otherwise very long string into pieces. 3918# If third argument is not empty, it's used as the name of the 3919# test to be printed on pass/fail. 3920proc help_test_raw { gdb_command expected_lines args } { 3921 set message $gdb_command 3922 if [llength $args]>0 then { 3923 set message [lindex $args 0] 3924 } 3925 set expected_output [join $expected_lines ""] 3926 gdb_test "${gdb_command}" "${expected_output}" $message 3927} 3928 3929# Test the output of "help COMMAND_CLASS". EXPECTED_INITIAL_LINES 3930# are regular expressions that should match the beginning of output, 3931# before the list of commands in that class. The presence of 3932# command list and standard epilogue will be tested automatically. 3933proc test_class_help { command_class expected_initial_lines args } { 3934 set l_stock_body { 3935 "List of commands\:.*\[\r\n\]+" 3936 "Type \"help\" followed by command name for full documentation\.\[\r\n\]+" 3937 "Type \"apropos word\" to search for commands related to \"word\"\.[\r\n\]+" 3938 "Command name abbreviations are allowed if unambiguous\." 3939 } 3940 set l_entire_body [concat $expected_initial_lines $l_stock_body] 3941 3942 eval [list help_test_raw "help ${command_class}" $l_entire_body] $args 3943} 3944 3945# COMMAND_LIST should have either one element -- command to test, or 3946# two elements -- abbreviated command to test, and full command the first 3947# element is abbreviation of. 3948# The command must be a prefix command. EXPECTED_INITIAL_LINES 3949# are regular expressions that should match the beginning of output, 3950# before the list of subcommands. The presence of 3951# subcommand list and standard epilogue will be tested automatically. 3952proc test_prefix_command_help { command_list expected_initial_lines args } { 3953 set command [lindex $command_list 0] 3954 if {[llength $command_list]>1} { 3955 set full_command [lindex $command_list 1] 3956 } else { 3957 set full_command $command 3958 } 3959 # Use 'list' and not just {} because we want variables to 3960 # be expanded in this list. 3961 set l_stock_body [list\ 3962 "List of $full_command subcommands\:.*\[\r\n\]+"\ 3963 "Type \"help $full_command\" followed by $full_command subcommand name for full documentation\.\[\r\n\]+"\ 3964 "Type \"apropos word\" to search for commands related to \"word\"\.\[\r\n\]+"\ 3965 "Command name abbreviations are allowed if unambiguous\."] 3966 set l_entire_body [concat $expected_initial_lines $l_stock_body] 3967 if {[llength $args]>0} { 3968 help_test_raw "help ${command}" $l_entire_body [lindex $args 0] 3969 } else { 3970 help_test_raw "help ${command}" $l_entire_body 3971 } 3972} 3973 3974# Build executable named EXECUTABLE from specifications that allow 3975# different options to be passed to different sub-compilations. 3976# TESTNAME is the name of the test; this is passed to 'untested' if 3977# something fails. 3978# OPTIONS is passed to the final link, using gdb_compile. 3979# ARGS is a flat list of source specifications, of the form: 3980# { SOURCE1 OPTIONS1 [ SOURCE2 OPTIONS2 ]... } 3981# Each SOURCE is compiled to an object file using its OPTIONS, 3982# using gdb_compile. 3983# Returns 0 on success, -1 on failure. 3984proc build_executable_from_specs {testname executable options args} { 3985 global subdir 3986 global srcdir 3987 3988 set binfile [standard_output_file $executable] 3989 3990 set objects {} 3991 set i 0 3992 foreach {s local_options} $args { 3993 if { [gdb_compile "${srcdir}/${subdir}/${s}" "${binfile}${i}.o" object $local_options] != "" } { 3994 untested $testname 3995 return -1 3996 } 3997 lappend objects "${binfile}${i}.o" 3998 incr i 3999 } 4000 4001 if { [gdb_compile $objects "${binfile}" executable $options] != "" } { 4002 untested $testname 4003 return -1 4004 } 4005 4006 set info_options "" 4007 if { [lsearch -exact $options "c++"] >= 0 } { 4008 set info_options "c++" 4009 } 4010 if [get_compiler_info ${info_options}] { 4011 return -1 4012 } 4013 return 0 4014} 4015 4016# Build executable named EXECUTABLE, from SOURCES. If SOURCES are not 4017# provided, uses $EXECUTABLE.c. The TESTNAME paramer is the name of test 4018# to pass to untested, if something is wrong. OPTIONS are passed 4019# to gdb_compile directly. 4020proc build_executable { testname executable {sources ""} {options {debug}} } { 4021 if {[llength $sources]==0} { 4022 set sources ${executable}.c 4023 } 4024 4025 set arglist [list $testname $executable $options] 4026 foreach source $sources { 4027 lappend arglist $source $options 4028 } 4029 4030 return [eval build_executable_from_specs $arglist] 4031} 4032 4033# Starts fresh GDB binary and loads EXECUTABLE into GDB. EXECUTABLE is 4034# the basename of the binary. 4035proc clean_restart { executable } { 4036 global srcdir 4037 global subdir 4038 set binfile [standard_output_file ${executable}] 4039 4040 gdb_exit 4041 gdb_start 4042 gdb_reinitialize_dir $srcdir/$subdir 4043 gdb_load ${binfile} 4044} 4045 4046# Prepares for testing by calling build_executable_full, then 4047# clean_restart. 4048# TESTNAME is the name of the test. 4049# Each element in ARGS is a list of the form 4050# { EXECUTABLE OPTIONS SOURCE_SPEC... } 4051# These are passed to build_executable_from_specs, which see. 4052# The last EXECUTABLE is passed to clean_restart. 4053# Returns 0 on success, non-zero on failure. 4054proc prepare_for_testing_full {testname args} { 4055 foreach spec $args { 4056 if {[eval build_executable_from_specs [list $testname] $spec] == -1} { 4057 return -1 4058 } 4059 set executable [lindex $spec 0] 4060 } 4061 clean_restart $executable 4062 return 0 4063} 4064 4065# Prepares for testing, by calling build_executable, and then clean_restart. 4066# Please refer to build_executable for parameter description. 4067proc prepare_for_testing { testname executable {sources ""} {options {debug}}} { 4068 4069 if {[build_executable $testname $executable $sources $options] == -1} { 4070 return -1 4071 } 4072 clean_restart $executable 4073 4074 return 0 4075} 4076 4077proc get_valueof { fmt exp default } { 4078 global gdb_prompt 4079 4080 set test "get valueof \"${exp}\"" 4081 set val ${default} 4082 gdb_test_multiple "print${fmt} ${exp}" "$test" { 4083 -re "\\$\[0-9\]* = (.*)\[\r\n\]*$gdb_prompt $" { 4084 set val $expect_out(1,string) 4085 pass "$test ($val)" 4086 } 4087 timeout { 4088 fail "$test (timeout)" 4089 } 4090 } 4091 return ${val} 4092} 4093 4094proc get_integer_valueof { exp default } { 4095 global gdb_prompt 4096 4097 set test "get integer valueof \"${exp}\"" 4098 set val ${default} 4099 gdb_test_multiple "print /d ${exp}" "$test" { 4100 -re "\\$\[0-9\]* = (\[-\]*\[0-9\]*).*$gdb_prompt $" { 4101 set val $expect_out(1,string) 4102 pass "$test ($val)" 4103 } 4104 timeout { 4105 fail "$test (timeout)" 4106 } 4107 } 4108 return ${val} 4109} 4110 4111proc get_hexadecimal_valueof { exp default } { 4112 global gdb_prompt 4113 send_gdb "print /x ${exp}\n" 4114 set test "get hexadecimal valueof \"${exp}\"" 4115 gdb_expect { 4116 -re "\\$\[0-9\]* = (0x\[0-9a-zA-Z\]+).*$gdb_prompt $" { 4117 set val $expect_out(1,string) 4118 pass "$test" 4119 } 4120 timeout { 4121 set val ${default} 4122 fail "$test (timeout)" 4123 } 4124 } 4125 return ${val} 4126} 4127 4128proc get_sizeof { type default } { 4129 return [get_integer_valueof "sizeof (${type})" $default] 4130} 4131 4132# Get the current value for remotetimeout and return it. 4133proc get_remotetimeout { } { 4134 global gdb_prompt 4135 global decimal 4136 4137 gdb_test_multiple "show remotetimeout" "" { 4138 -re "Timeout limit to wait for target to respond is ($decimal).*$gdb_prompt $" { 4139 return $expect_out(1,string); 4140 } 4141 } 4142 4143 # Pick the default that gdb uses 4144 warning "Unable to read remotetimeout" 4145 return 300 4146} 4147 4148# Set the remotetimeout to the specified timeout. Nothing is returned. 4149proc set_remotetimeout { timeout } { 4150 global gdb_prompt 4151 4152 gdb_test_multiple "set remotetimeout $timeout" "" { 4153 -re "$gdb_prompt $" { 4154 verbose "Set remotetimeout to $timeout\n" 4155 } 4156 } 4157} 4158 4159# Log gdb command line and script if requested. 4160if {[info exists TRANSCRIPT]} { 4161 rename send_gdb real_send_gdb 4162 rename remote_spawn real_remote_spawn 4163 rename remote_close real_remote_close 4164 4165 global gdb_transcript 4166 set gdb_transcript "" 4167 4168 global gdb_trans_count 4169 set gdb_trans_count 1 4170 4171 proc remote_spawn {args} { 4172 global gdb_transcript gdb_trans_count outdir 4173 4174 if {$gdb_transcript != ""} { 4175 close $gdb_transcript 4176 } 4177 set gdb_transcript [open [file join $outdir transcript.$gdb_trans_count] w] 4178 puts $gdb_transcript [lindex $args 1] 4179 incr gdb_trans_count 4180 4181 return [uplevel real_remote_spawn $args] 4182 } 4183 4184 proc remote_close {args} { 4185 global gdb_transcript 4186 4187 if {$gdb_transcript != ""} { 4188 close $gdb_transcript 4189 set gdb_transcript "" 4190 } 4191 4192 return [uplevel real_remote_close $args] 4193 } 4194 4195 proc send_gdb {args} { 4196 global gdb_transcript 4197 4198 if {$gdb_transcript != ""} { 4199 puts -nonewline $gdb_transcript [lindex $args 0] 4200 } 4201 4202 return [uplevel real_send_gdb $args] 4203 } 4204} 4205 4206proc core_find {binfile {deletefiles {}} {arg ""}} { 4207 global objdir subdir 4208 4209 set destcore "$binfile.core" 4210 file delete $destcore 4211 4212 # Create a core file named "$destcore" rather than just "core", to 4213 # avoid problems with sys admin types that like to regularly prune all 4214 # files named "core" from the system. 4215 # 4216 # Arbitrarily try setting the core size limit to "unlimited" since 4217 # this does not hurt on systems where the command does not work and 4218 # allows us to generate a core on systems where it does. 4219 # 4220 # Some systems append "core" to the name of the program; others append 4221 # the name of the program to "core"; still others (like Linux, as of 4222 # May 2003) create cores named "core.PID". In the latter case, we 4223 # could have many core files lying around, and it may be difficult to 4224 # tell which one is ours, so let's run the program in a subdirectory. 4225 set found 0 4226 set coredir [standard_output_file coredir.[getpid]] 4227 file mkdir $coredir 4228 catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >/dev/null 2>&1\"" 4229 # remote_exec host "${binfile}" 4230 foreach i "${coredir}/core ${coredir}/core.coremaker.c ${binfile}.core" { 4231 if [remote_file build exists $i] { 4232 remote_exec build "mv $i $destcore" 4233 set found 1 4234 } 4235 } 4236 # Check for "core.PID". 4237 if { $found == 0 } { 4238 set names [glob -nocomplain -directory $coredir core.*] 4239 if {[llength $names] == 1} { 4240 set corefile [file join $coredir [lindex $names 0]] 4241 remote_exec build "mv $corefile $destcore" 4242 set found 1 4243 } 4244 } 4245 if { $found == 0 } { 4246 # The braindamaged HPUX shell quits after the ulimit -c above 4247 # without executing ${binfile}. So we try again without the 4248 # ulimit here if we didn't find a core file above. 4249 # Oh, I should mention that any "braindamaged" non-Unix system has 4250 # the same problem. I like the cd bit too, it's really neat'n stuff. 4251 catch "system \"(cd ${objdir}/${subdir}; ${binfile}; true) >/dev/null 2>&1\"" 4252 foreach i "${objdir}/${subdir}/core ${objdir}/${subdir}/core.coremaker.c ${binfile}.core" { 4253 if [remote_file build exists $i] { 4254 remote_exec build "mv $i $destcore" 4255 set found 1 4256 } 4257 } 4258 } 4259 4260 # Try to clean up after ourselves. 4261 foreach deletefile $deletefiles { 4262 remote_file build delete [file join $coredir $deletefile] 4263 } 4264 remote_exec build "rmdir $coredir" 4265 4266 if { $found == 0 } { 4267 warning "can't generate a core file - core tests suppressed - check ulimit -c" 4268 return "" 4269 } 4270 return $destcore 4271} 4272 4273# gdb_target_symbol_prefix_flags returns a string that can be added 4274# to gdb_compile options to define SYMBOL_PREFIX macro value 4275# symbol_prefix_flags returns a string that can be added 4276# for targets that use underscore as symbol prefix. 4277# TODO: find out automatically if the target needs this. 4278 4279proc gdb_target_symbol_prefix_flags {} { 4280 if { [istarget "*-*-cygwin*"] || [istarget "i?86-*-mingw*"] 4281 || [istarget "*-*-msdosdjgpp*"] || [istarget "*-*-go32*"] } { 4282 return "additional_flags=-DSYMBOL_PREFIX=\"_\"" 4283 } else { 4284 return "" 4285 } 4286} 4287 4288# Always load compatibility stuff. 4289load_lib future.exp 4290