1# Copyright 1992-2021 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 28# List of procs to run in gdb_finish. 29set gdb_finish_hooks [list] 30 31# Variable in which we keep track of globals that are allowed to be live 32# across test-cases. 33array set gdb_persistent_globals {} 34 35# Mark variable names in ARG as a persistent global, and declare them as 36# global in the calling context. Can be used to rewrite "global var_a var_b" 37# into "gdb_persistent_global var_a var_b". 38proc gdb_persistent_global { args } { 39 global gdb_persistent_globals 40 foreach varname $args { 41 uplevel 1 global $varname 42 set gdb_persistent_globals($varname) 1 43 } 44} 45 46# Mark variable names in ARG as a persistent global. 47proc gdb_persistent_global_no_decl { args } { 48 global gdb_persistent_globals 49 foreach varname $args { 50 set gdb_persistent_globals($varname) 1 51 } 52} 53 54# Override proc load_lib. 55rename load_lib saved_load_lib 56# Run the runtest version of load_lib, and mark all variables that were 57# created by this call as persistent. 58proc load_lib { file } { 59 array set known_global {} 60 foreach varname [info globals] { 61 set known_globals($varname) 1 62 } 63 64 set code [catch "saved_load_lib $file" result] 65 66 foreach varname [info globals] { 67 if { ![info exists known_globals($varname)] } { 68 gdb_persistent_global_no_decl $varname 69 } 70 } 71 72 if {$code == 1} { 73 global errorInfo errorCode 74 return -code error -errorinfo $errorInfo -errorcode $errorCode $result 75 } elseif {$code > 1} { 76 return -code $code $result 77 } 78 79 return $result 80} 81 82load_lib libgloss.exp 83load_lib cache.exp 84load_lib gdb-utils.exp 85load_lib memory.exp 86load_lib check-test-names.exp 87 88global GDB 89 90# The spawn ID used for I/O interaction with the inferior. For native 91# targets, or remote targets that can do I/O through GDB 92# (semi-hosting) this will be the same as the host/GDB's spawn ID. 93# Otherwise, the board may set this to some other spawn ID. E.g., 94# when debugging with GDBserver, this is set to GDBserver's spawn ID, 95# so input/output is done on gdbserver's tty. 96global inferior_spawn_id 97 98if [info exists TOOL_EXECUTABLE] { 99 set GDB $TOOL_EXECUTABLE 100} 101if ![info exists GDB] { 102 if ![is_remote host] { 103 set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]] 104 } else { 105 set GDB [transform gdb] 106 } 107} 108verbose "using GDB = $GDB" 2 109 110# GDBFLAGS is available for the user to set on the command line. 111# E.g. make check RUNTESTFLAGS=GDBFLAGS=mumble 112# Testcases may use it to add additional flags, but they must: 113# - append new flags, not overwrite 114# - restore the original value when done 115global GDBFLAGS 116if ![info exists GDBFLAGS] { 117 set GDBFLAGS "" 118} 119verbose "using GDBFLAGS = $GDBFLAGS" 2 120 121# Make the build data directory available to tests. 122set BUILD_DATA_DIRECTORY "[pwd]/../data-directory" 123 124# INTERNAL_GDBFLAGS contains flags that the testsuite requires. 125global INTERNAL_GDBFLAGS 126if ![info exists INTERNAL_GDBFLAGS] { 127 set INTERNAL_GDBFLAGS \ 128 [join [list \ 129 "-nw" \ 130 "-nx" \ 131 "-data-directory $BUILD_DATA_DIRECTORY" \ 132 {-iex "set height 0"} \ 133 {-iex "set width 0"}]] 134} 135 136# The variable gdb_prompt is a regexp which matches the gdb prompt. 137# Set it if it is not already set. This is also set by default_gdb_init 138# but it's not clear what removing one of them will break. 139# See with_gdb_prompt for more details on prompt handling. 140global gdb_prompt 141if ![info exists gdb_prompt] then { 142 set gdb_prompt "\\(gdb\\)" 143} 144 145# A regexp that matches the pagination prompt. 146set pagination_prompt \ 147 "--Type <RET> for more, q to quit, c to continue without paging--" 148 149# The variable fullname_syntax_POSIX is a regexp which matches a POSIX 150# absolute path ie. /foo/ 151set fullname_syntax_POSIX {/[^\n]*/} 152# The variable fullname_syntax_UNC is a regexp which matches a Windows 153# UNC path ie. \\D\foo\ 154set fullname_syntax_UNC {\\\\[^\\]+\\[^\n]+\\} 155# The variable fullname_syntax_DOS_CASE is a regexp which matches a 156# particular DOS case that GDB most likely will output 157# ie. \foo\, but don't match \\.*\ 158set fullname_syntax_DOS_CASE {\\[^\\][^\n]*\\} 159# The variable fullname_syntax_DOS is a regexp which matches a DOS path 160# ie. a:\foo\ && a:foo\ 161set fullname_syntax_DOS {[a-zA-Z]:[^\n]*\\} 162# The variable fullname_syntax is a regexp which matches what GDB considers 163# an absolute path. It is currently debatable if the Windows style paths 164# d:foo and \abc should be considered valid as an absolute path. 165# Also, the purpse of this regexp is not to recognize a well formed 166# absolute path, but to say with certainty that a path is absolute. 167set fullname_syntax "($fullname_syntax_POSIX|$fullname_syntax_UNC|$fullname_syntax_DOS_CASE|$fullname_syntax_DOS)" 168 169# Needed for some tests under Cygwin. 170global EXEEXT 171global env 172 173if ![info exists env(EXEEXT)] { 174 set EXEEXT "" 175} else { 176 set EXEEXT $env(EXEEXT) 177} 178 179set octal "\[0-7\]+" 180 181set inferior_exited_re "(?:\\\[Inferior \[0-9\]+ \\(\[^\n\r\]*\\) exited)" 182 183# A regular expression that matches a value history number. 184# E.g., $1, $2, etc. 185set valnum_re "\\\$$decimal" 186 187### Only procedures should come after this point. 188 189# 190# gdb_version -- extract and print the version number of GDB 191# 192proc default_gdb_version {} { 193 global GDB 194 global INTERNAL_GDBFLAGS GDBFLAGS 195 global gdb_prompt 196 global inotify_pid 197 198 if {[info exists inotify_pid]} { 199 eval exec kill $inotify_pid 200 } 201 202 set output [remote_exec host "$GDB $INTERNAL_GDBFLAGS --version"] 203 set tmp [lindex $output 1] 204 set version "" 205 regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version 206 if ![is_remote host] { 207 clone_output "[which $GDB] version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" 208 } else { 209 clone_output "$GDB on remote host version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" 210 } 211} 212 213proc gdb_version { } { 214 return [default_gdb_version] 215} 216 217# 218# gdb_unload -- unload a file if one is loaded 219# Return 0 on success, -1 on error. 220# 221 222proc gdb_unload {} { 223 global GDB 224 global gdb_prompt 225 send_gdb "file\n" 226 gdb_expect 60 { 227 -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue } 228 -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue } 229 -re "A program is being debugged already.*Are you sure you want to change the file.*y or n. $" { 230 send_gdb "y\n" answer 231 exp_continue 232 } 233 -re "Discard symbol table from .*y or n.*$" { 234 send_gdb "y\n" answer 235 exp_continue 236 } 237 -re "$gdb_prompt $" {} 238 timeout { 239 perror "couldn't unload file in $GDB (timeout)." 240 return -1 241 } 242 } 243 return 0 244} 245 246# Many of the tests depend on setting breakpoints at various places and 247# running until that breakpoint is reached. At times, we want to start 248# with a clean-slate with respect to breakpoints, so this utility proc 249# lets us do this without duplicating this code everywhere. 250# 251 252proc delete_breakpoints {} { 253 global gdb_prompt 254 255 # we need a larger timeout value here or this thing just confuses 256 # itself. May need a better implementation if possible. - guo 257 # 258 set timeout 100 259 260 set msg "delete all breakpoints in delete_breakpoints" 261 set deleted 0 262 gdb_test_multiple "delete breakpoints" "$msg" { 263 -re "Delete all breakpoints.*y or n.*$" { 264 send_gdb "y\n" answer 265 exp_continue 266 } 267 -re "$gdb_prompt $" { 268 set deleted 1 269 } 270 } 271 272 if {$deleted} { 273 # Confirm with "info breakpoints". 274 set deleted 0 275 set msg "info breakpoints" 276 gdb_test_multiple $msg $msg { 277 -re "No breakpoints or watchpoints..*$gdb_prompt $" { 278 set deleted 1 279 } 280 -re "$gdb_prompt $" { 281 } 282 } 283 } 284 285 if {!$deleted} { 286 perror "breakpoints not deleted" 287 } 288} 289 290# Returns true iff the target supports using the "run" command. 291 292proc target_can_use_run_cmd {} { 293 if [target_info exists use_gdb_stub] { 294 # In this case, when we connect, the inferior is already 295 # running. 296 return 0 297 } 298 299 # Assume yes. 300 return 1 301} 302 303# Generic run command. 304# 305# Return 0 if we could start the program, -1 if we could not. 306# 307# The second pattern below matches up to the first newline *only*. 308# Using ``.*$'' could swallow up output that we attempt to match 309# elsewhere. 310# 311# INFERIOR_ARGS is passed as arguments to the start command, so may contain 312# inferior arguments. 313# 314# N.B. This function does not wait for gdb to return to the prompt, 315# that is the caller's responsibility. 316 317proc gdb_run_cmd { {inferior_args {}} } { 318 global gdb_prompt use_gdb_stub 319 320 foreach command [gdb_init_commands] { 321 send_gdb "$command\n" 322 gdb_expect 30 { 323 -re "$gdb_prompt $" { } 324 default { 325 perror "gdb_init_command for target failed" 326 return 327 } 328 } 329 } 330 331 if $use_gdb_stub { 332 if [target_info exists gdb,do_reload_on_run] { 333 if { [gdb_reload $inferior_args] != 0 } { 334 return -1 335 } 336 send_gdb "continue\n" 337 gdb_expect 60 { 338 -re "Continu\[^\r\n\]*\[\r\n\]" {} 339 default {} 340 } 341 return 0 342 } 343 344 if [target_info exists gdb,start_symbol] { 345 set start [target_info gdb,start_symbol] 346 } else { 347 set start "start" 348 } 349 send_gdb "jump *$start\n" 350 set start_attempt 1 351 while { $start_attempt } { 352 # Cap (re)start attempts at three to ensure that this loop 353 # always eventually fails. Don't worry about trying to be 354 # clever and not send a command when it has failed. 355 if [expr $start_attempt > 3] { 356 perror "Jump to start() failed (retry count exceeded)" 357 return -1 358 } 359 set start_attempt [expr $start_attempt + 1] 360 gdb_expect 30 { 361 -re "Continuing at \[^\r\n\]*\[\r\n\]" { 362 set start_attempt 0 363 } 364 -re "No symbol \"_start\" in current.*$gdb_prompt $" { 365 perror "Can't find start symbol to run in gdb_run" 366 return -1 367 } 368 -re "No symbol \"start\" in current.*$gdb_prompt $" { 369 send_gdb "jump *_start\n" 370 } 371 -re "No symbol.*context.*$gdb_prompt $" { 372 set start_attempt 0 373 } 374 -re "Line.* Jump anyway.*y or n. $" { 375 send_gdb "y\n" answer 376 } 377 -re "The program is not being run.*$gdb_prompt $" { 378 if { [gdb_reload $inferior_args] != 0 } { 379 return -1 380 } 381 send_gdb "jump *$start\n" 382 } 383 timeout { 384 perror "Jump to start() failed (timeout)" 385 return -1 386 } 387 } 388 } 389 390 return 0 391 } 392 393 if [target_info exists gdb,do_reload_on_run] { 394 if { [gdb_reload $inferior_args] != 0 } { 395 return -1 396 } 397 } 398 send_gdb "run $inferior_args\n" 399# This doesn't work quite right yet. 400# Use -notransfer here so that test cases (like chng-sym.exp) 401# may test for additional start-up messages. 402 gdb_expect 60 { 403 -re "The program .* has been started already.*y or n. $" { 404 send_gdb "y\n" answer 405 exp_continue 406 } 407 -notransfer -re "Starting program: \[^\r\n\]*" {} 408 -notransfer -re "$gdb_prompt $" { 409 # There is no more input expected. 410 } 411 } 412 413 return 0 414} 415 416# Generic start command. Return 0 if we could start the program, -1 417# if we could not. 418# 419# INFERIOR_ARGS is passed as arguments to the start command, so may contain 420# inferior arguments. 421# 422# N.B. This function does not wait for gdb to return to the prompt, 423# that is the caller's responsibility. 424 425proc gdb_start_cmd { {inferior_args {}} } { 426 global gdb_prompt use_gdb_stub 427 428 foreach command [gdb_init_commands] { 429 send_gdb "$command\n" 430 gdb_expect 30 { 431 -re "$gdb_prompt $" { } 432 default { 433 perror "gdb_init_command for target failed" 434 return -1 435 } 436 } 437 } 438 439 if $use_gdb_stub { 440 return -1 441 } 442 443 send_gdb "start $inferior_args\n" 444 # Use -notransfer here so that test cases (like chng-sym.exp) 445 # may test for additional start-up messages. 446 gdb_expect 60 { 447 -re "The program .* has been started already.*y or n. $" { 448 send_gdb "y\n" answer 449 exp_continue 450 } 451 -notransfer -re "Starting program: \[^\r\n\]*" { 452 return 0 453 } 454 } 455 return -1 456} 457 458# Generic starti command. Return 0 if we could start the program, -1 459# if we could not. 460# 461# INFERIOR_ARGS is passed as arguments to the starti command, so may contain 462# inferior arguments. 463# 464# N.B. This function does not wait for gdb to return to the prompt, 465# that is the caller's responsibility. 466 467proc gdb_starti_cmd { {inferior_args {}} } { 468 global gdb_prompt use_gdb_stub 469 470 foreach command [gdb_init_commands] { 471 send_gdb "$command\n" 472 gdb_expect 30 { 473 -re "$gdb_prompt $" { } 474 default { 475 perror "gdb_init_command for target failed" 476 return -1 477 } 478 } 479 } 480 481 if $use_gdb_stub { 482 return -1 483 } 484 485 send_gdb "starti $inferior_args\n" 486 gdb_expect 60 { 487 -re "The program .* has been started already.*y or n. $" { 488 send_gdb "y\n" answer 489 exp_continue 490 } 491 -re "Starting program: \[^\r\n\]*" { 492 return 0 493 } 494 } 495 return -1 496} 497 498# Set a breakpoint at FUNCTION. If there is an additional argument it is 499# a list of options; the supported options are allow-pending, temporary, 500# message, no-message and qualified. 501# The result is 1 for success, 0 for failure. 502# 503# Note: The handling of message vs no-message is messed up, but it's based 504# on historical usage. By default this function does not print passes, 505# only fails. 506# no-message: turns off printing of fails (and passes, but they're already off) 507# message: turns on printing of passes (and fails, but they're already on) 508 509proc gdb_breakpoint { function args } { 510 global gdb_prompt 511 global decimal 512 513 set pending_response n 514 if {[lsearch -exact $args allow-pending] != -1} { 515 set pending_response y 516 } 517 518 set break_command "break" 519 set break_message "Breakpoint" 520 if {[lsearch -exact $args temporary] != -1} { 521 set break_command "tbreak" 522 set break_message "Temporary breakpoint" 523 } 524 525 if {[lsearch -exact $args qualified] != -1} { 526 append break_command " -qualified" 527 } 528 529 set print_pass 0 530 set print_fail 1 531 set no_message_loc [lsearch -exact $args no-message] 532 set message_loc [lsearch -exact $args message] 533 # The last one to appear in args wins. 534 if { $no_message_loc > $message_loc } { 535 set print_fail 0 536 } elseif { $message_loc > $no_message_loc } { 537 set print_pass 1 538 } 539 540 set test_name "setting breakpoint at $function" 541 542 send_gdb "$break_command $function\n" 543 # The first two regexps are what we get with -g, the third is without -g. 544 gdb_expect 30 { 545 -re "$break_message \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} 546 -re "$break_message \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} 547 -re "$break_message \[0-9\]* at .*$gdb_prompt $" {} 548 -re "$break_message \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" { 549 if {$pending_response == "n"} { 550 if { $print_fail } { 551 fail $test_name 552 } 553 return 0 554 } 555 } 556 -re "Make breakpoint pending.*y or \\\[n\\\]. $" { 557 send_gdb "$pending_response\n" 558 exp_continue 559 } 560 -re "A problem internal to GDB has been detected" { 561 if { $print_fail } { 562 fail "$test_name (GDB internal error)" 563 } 564 gdb_internal_error_resync 565 return 0 566 } 567 -re "$gdb_prompt $" { 568 if { $print_fail } { 569 fail $test_name 570 } 571 return 0 572 } 573 eof { 574 perror "GDB process no longer exists" 575 global gdb_spawn_id 576 set wait_status [wait -i $gdb_spawn_id] 577 verbose -log "GDB process exited with wait status $wait_status" 578 if { $print_fail } { 579 fail "$test_name (eof)" 580 } 581 return 0 582 } 583 timeout { 584 if { $print_fail } { 585 fail "$test_name (timeout)" 586 } 587 return 0 588 } 589 } 590 if { $print_pass } { 591 pass $test_name 592 } 593 return 1 594} 595 596# Set breakpoint at function and run gdb until it breaks there. 597# Since this is the only breakpoint that will be set, if it stops 598# at a breakpoint, we will assume it is the one we want. We can't 599# just compare to "function" because it might be a fully qualified, 600# single quoted C++ function specifier. 601# 602# If there are additional arguments, pass them to gdb_breakpoint. 603# We recognize no-message/message ourselves. 604# The default is no-message. 605# no-message is messed up here, like gdb_breakpoint: to preserve 606# historical usage fails are always printed by default. 607# no-message: turns off printing of fails (and passes, but they're already off) 608# message: turns on printing of passes (and fails, but they're already on) 609 610proc runto { function args } { 611 global gdb_prompt 612 global decimal 613 614 delete_breakpoints 615 616 # Default to "no-message". 617 set args "no-message $args" 618 619 set print_pass 0 620 set print_fail 1 621 set no_message_loc [lsearch -exact $args no-message] 622 set message_loc [lsearch -exact $args message] 623 # The last one to appear in args wins. 624 if { $no_message_loc > $message_loc } { 625 set print_fail 0 626 } elseif { $message_loc > $no_message_loc } { 627 set print_pass 1 628 } 629 630 set test_name "running to $function in runto" 631 632 # We need to use eval here to pass our varargs args to gdb_breakpoint 633 # which is also a varargs function. 634 # But we also have to be careful because $function may have multiple 635 # elements, and we don't want Tcl to move the remaining elements after 636 # the first to $args. That is why $function is wrapped in {}. 637 if ![eval gdb_breakpoint {$function} $args] { 638 return 0 639 } 640 641 gdb_run_cmd 642 643 # the "at foo.c:36" output we get with -g. 644 # the "in func" output we get without -g. 645 gdb_expect 30 { 646 -re "Break.* at .*:$decimal.*$gdb_prompt $" { 647 if { $print_pass } { 648 pass $test_name 649 } 650 return 1 651 } 652 -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { 653 if { $print_pass } { 654 pass $test_name 655 } 656 return 1 657 } 658 -re "The target does not support running in non-stop mode.\r\n$gdb_prompt $" { 659 if { $print_fail } { 660 unsupported "non-stop mode not supported" 661 } 662 return 0 663 } 664 -re ".*A problem internal to GDB has been detected" { 665 # Always emit a FAIL if we encounter an internal error: internal 666 # errors are never expected. 667 fail "$test_name (GDB internal error)" 668 gdb_internal_error_resync 669 return 0 670 } 671 -re "$gdb_prompt $" { 672 if { $print_fail } { 673 fail $test_name 674 } 675 return 0 676 } 677 eof { 678 if { $print_fail } { 679 fail "$test_name (eof)" 680 } 681 return 0 682 } 683 timeout { 684 if { $print_fail } { 685 fail "$test_name (timeout)" 686 } 687 return 0 688 } 689 } 690 if { $print_pass } { 691 pass $test_name 692 } 693 return 1 694} 695 696# Ask gdb to run until we hit a breakpoint at main. 697# 698# N.B. This function deletes all existing breakpoints. 699# If you don't want that, use gdb_start_cmd. 700 701proc runto_main { } { 702 return [runto main no-message qualified] 703} 704 705### Continue, and expect to hit a breakpoint. 706### Report a pass or fail, depending on whether it seems to have 707### worked. Use NAME as part of the test name; each call to 708### continue_to_breakpoint should use a NAME which is unique within 709### that test file. 710proc gdb_continue_to_breakpoint {name {location_pattern .*}} { 711 global gdb_prompt 712 set full_name "continue to breakpoint: $name" 713 714 set kfail_pattern "Process record does not support instruction 0xfae64 at.*" 715 gdb_test_multiple "continue" $full_name { 716 -re "(?:Breakpoint|Temporary breakpoint) .* (at|in) $location_pattern\r\n$gdb_prompt $" { 717 pass $full_name 718 } 719 -re "\[\r\n\]*(?:$kfail_pattern)\[\r\n\]+$gdb_prompt $" { 720 kfail "gdb/25038" $full_name 721 } 722 } 723} 724 725 726# gdb_internal_error_resync: 727# 728# Answer the questions GDB asks after it reports an internal error 729# until we get back to a GDB prompt. Decline to quit the debugging 730# session, and decline to create a core file. Return non-zero if the 731# resync succeeds. 732# 733# This procedure just answers whatever questions come up until it sees 734# a GDB prompt; it doesn't require you to have matched the input up to 735# any specific point. However, it only answers questions it sees in 736# the output itself, so if you've matched a question, you had better 737# answer it yourself before calling this. 738# 739# You can use this function thus: 740# 741# gdb_expect { 742# ... 743# -re ".*A problem internal to GDB has been detected" { 744# gdb_internal_error_resync 745# } 746# ... 747# } 748# 749proc gdb_internal_error_resync {} { 750 global gdb_prompt 751 752 verbose -log "Resyncing due to internal error." 753 754 set count 0 755 while {$count < 10} { 756 gdb_expect { 757 -re "Quit this debugging session\\? \\(y or n\\) $" { 758 send_gdb "n\n" answer 759 incr count 760 } 761 -re "Create a core file of GDB\\? \\(y or n\\) $" { 762 send_gdb "n\n" answer 763 incr count 764 } 765 -re "$gdb_prompt $" { 766 # We're resynchronized. 767 return 1 768 } 769 timeout { 770 perror "Could not resync from internal error (timeout)" 771 return 0 772 } 773 } 774 } 775 perror "Could not resync from internal error (resync count exceeded)" 776 return 0 777} 778 779 780# gdb_test_multiple COMMAND MESSAGE [ -prompt PROMPT_REGEXP] [ -lbl ] 781# EXPECT_ARGUMENTS 782# Send a command to gdb; test the result. 783# 784# COMMAND is the command to execute, send to GDB with send_gdb. If 785# this is the null string no command is sent. 786# MESSAGE is a message to be printed with the built-in failure patterns 787# if one of them matches. If MESSAGE is empty COMMAND will be used. 788# -prompt PROMPT_REGEXP specifies a regexp matching the expected prompt 789# after the command output. If empty, defaults to "$gdb_prompt $". 790# -lbl specifies that line-by-line matching will be used. 791# EXPECT_ARGUMENTS will be fed to expect in addition to the standard 792# patterns. Pattern elements will be evaluated in the caller's 793# context; action elements will be executed in the caller's context. 794# Unlike patterns for gdb_test, these patterns should generally include 795# the final newline and prompt. 796# 797# Returns: 798# 1 if the test failed, according to a built-in failure pattern 799# 0 if only user-supplied patterns matched 800# -1 if there was an internal error. 801# 802# You can use this function thus: 803# 804# gdb_test_multiple "print foo" "test foo" { 805# -re "expected output 1" { 806# pass "test foo" 807# } 808# -re "expected output 2" { 809# fail "test foo" 810# } 811# } 812# 813# Within action elements you can also make use of the variable 814# gdb_test_name. This variable is setup automatically by 815# gdb_test_multiple, and contains the value of MESSAGE. You can then 816# write this, which is equivalent to the above: 817# 818# gdb_test_multiple "print foo" "test foo" { 819# -re "expected output 1" { 820# pass $gdb_test_name 821# } 822# -re "expected output 2" { 823# fail $gdb_test_name 824# } 825# } 826# 827# Like with "expect", you can also specify the spawn id to match with 828# -i "$id". Interesting spawn ids are $inferior_spawn_id and 829# $gdb_spawn_id. The former matches inferior I/O, while the latter 830# matches GDB I/O. E.g.: 831# 832# send_inferior "hello\n" 833# gdb_test_multiple "continue" "test echo" { 834# -i "$inferior_spawn_id" -re "^hello\r\nhello\r\n$" { 835# pass "got echo" 836# } 837# -i "$gdb_spawn_id" -re "Breakpoint.*$gdb_prompt $" { 838# fail "hit breakpoint" 839# } 840# } 841# 842# The standard patterns, such as "Inferior exited..." and "A problem 843# ...", all being implicitly appended to that list. These are always 844# expected from $gdb_spawn_id. IOW, callers do not need to worry 845# about resetting "-i" back to $gdb_spawn_id explicitly. 846# 847# In EXPECT_ARGUMENTS we can use a -wrap pattern flag, that wraps the regexp 848# pattern as gdb_test wraps its message argument. 849# This allows us to rewrite: 850# gdb_test <command> <pattern> <message> 851# into: 852# gdb_test_multiple <command> <message> { 853# -re -wrap <pattern> { 854# pass $gdb_test_name 855# } 856# } 857# 858# In EXPECT_ARGUMENTS, a pattern flag -early can be used. It makes sure the 859# pattern is inserted before any implicit pattern added by gdb_test_multiple. 860# Using this pattern flag, we can f.i. setup a kfail for an assertion failure 861# <assert> during gdb_continue_to_breakpoint by the rewrite: 862# gdb_continue_to_breakpoint <msg> <pattern> 863# into: 864# set breakpoint_pattern "(?:Breakpoint|Temporary breakpoint) .* (at|in)" 865# gdb_test_multiple "continue" "continue to breakpoint: <msg>" { 866# -early -re "internal-error: <assert>" { 867# setup_kfail gdb/nnnnn "*-*-*" 868# exp_continue 869# } 870# -re "$breakpoint_pattern <pattern>\r\n$gdb_prompt $" { 871# pass $gdb_test_name 872# } 873# } 874# 875proc gdb_test_multiple { command message args } { 876 global verbose use_gdb_stub 877 global gdb_prompt pagination_prompt 878 global GDB 879 global gdb_spawn_id 880 global inferior_exited_re 881 upvar timeout timeout 882 upvar expect_out expect_out 883 global any_spawn_id 884 885 set line_by_line 0 886 set prompt_regexp "" 887 for {set i 0} {$i < [llength $args]} {incr i} { 888 set arg [lindex $args $i] 889 if { $arg == "-prompt" } { 890 incr i 891 set prompt_regexp [lindex $args $i] 892 } elseif { $arg == "-lbl" } { 893 set line_by_line 1 894 } else { 895 set user_code $arg 896 break 897 } 898 } 899 if { [expr $i + 1] < [llength $args] } { 900 error "Too many arguments to gdb_test_multiple" 901 } elseif { ![info exists user_code] } { 902 error "Too few arguments to gdb_test_multiple" 903 } 904 905 if { "$prompt_regexp" == "" } { 906 set prompt_regexp "$gdb_prompt $" 907 } 908 909 if { $message == "" } { 910 set message $command 911 } 912 913 if [string match "*\[\r\n\]" $command] { 914 error "Invalid trailing newline in \"$message\" test" 915 } 916 917 if [string match "*\[\r\n\]*" $message] { 918 error "Invalid newline in \"$message\" test" 919 } 920 921 if {$use_gdb_stub 922 && [regexp -nocase {^\s*(r|run|star|start|at|att|atta|attac|attach)\M} \ 923 $command]} { 924 error "gdbserver does not support $command without extended-remote" 925 } 926 927 # TCL/EXPECT WART ALERT 928 # Expect does something very strange when it receives a single braced 929 # argument. It splits it along word separators and performs substitutions. 930 # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is 931 # evaluated as "\[ab\]". But that's not how TCL normally works; inside a 932 # double-quoted list item, "\[ab\]" is just a long way of representing 933 # "[ab]", because the backslashes will be removed by lindex. 934 935 # Unfortunately, there appears to be no easy way to duplicate the splitting 936 # that expect will do from within TCL. And many places make use of the 937 # "\[0-9\]" construct, so we need to support that; and some places make use 938 # of the "[func]" construct, so we need to support that too. In order to 939 # get this right we have to substitute quoted list elements differently 940 # from braced list elements. 941 942 # We do this roughly the same way that Expect does it. We have to use two 943 # lists, because if we leave unquoted newlines in the argument to uplevel 944 # they'll be treated as command separators, and if we escape newlines 945 # we mangle newlines inside of command blocks. This assumes that the 946 # input doesn't contain a pattern which contains actual embedded newlines 947 # at this point! 948 949 regsub -all {\n} ${user_code} { } subst_code 950 set subst_code [uplevel list $subst_code] 951 952 set processed_code "" 953 set early_processed_code "" 954 # The variable current_list holds the name of the currently processed 955 # list, either processed_code or early_processed_code. 956 set current_list "processed_code" 957 set patterns "" 958 set expecting_action 0 959 set expecting_arg 0 960 set wrap_pattern 0 961 foreach item $user_code subst_item $subst_code { 962 if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } { 963 lappend $current_list $item 964 continue 965 } 966 if { $item == "-indices" || $item == "-re" || $item == "-ex" } { 967 lappend $current_list $item 968 continue 969 } 970 if { $item == "-early" } { 971 set current_list "early_processed_code" 972 continue 973 } 974 if { $item == "-timeout" || $item == "-i" } { 975 set expecting_arg 1 976 lappend $current_list $item 977 continue 978 } 979 if { $item == "-wrap" } { 980 set wrap_pattern 1 981 continue 982 } 983 if { $expecting_arg } { 984 set expecting_arg 0 985 lappend $current_list $subst_item 986 continue 987 } 988 if { $expecting_action } { 989 lappend $current_list "uplevel [list $item]" 990 set expecting_action 0 991 # Cosmetic, no effect on the list. 992 append $current_list "\n" 993 # End the effect of -early, it only applies to one action. 994 set current_list "processed_code" 995 continue 996 } 997 set expecting_action 1 998 if { $wrap_pattern } { 999 # Wrap subst_item as is done for the gdb_test PATTERN argument. 1000 lappend $current_list \ 1001 "\[\r\n\]*(?:$subst_item)\[\r\n\]+$gdb_prompt $" 1002 set wrap_pattern 0 1003 } else { 1004 lappend $current_list $subst_item 1005 } 1006 if {$patterns != ""} { 1007 append patterns "; " 1008 } 1009 append patterns "\"$subst_item\"" 1010 } 1011 1012 # Also purely cosmetic. 1013 regsub -all {\r} $patterns {\\r} patterns 1014 regsub -all {\n} $patterns {\\n} patterns 1015 1016 if $verbose>2 then { 1017 send_user "Sending \"$command\" to gdb\n" 1018 send_user "Looking to match \"$patterns\"\n" 1019 send_user "Message is \"$message\"\n" 1020 } 1021 1022 set result -1 1023 set string "${command}\n" 1024 if { $command != "" } { 1025 set multi_line_re "\[\r\n\] *>" 1026 while { "$string" != "" } { 1027 set foo [string first "\n" "$string"] 1028 set len [string length "$string"] 1029 if { $foo < [expr $len - 1] } { 1030 set str [string range "$string" 0 $foo] 1031 if { [send_gdb "$str"] != "" } { 1032 perror "Couldn't send $command to GDB." 1033 } 1034 # since we're checking if each line of the multi-line 1035 # command are 'accepted' by GDB here, 1036 # we need to set -notransfer expect option so that 1037 # command output is not lost for pattern matching 1038 # - guo 1039 gdb_expect 2 { 1040 -notransfer -re "$multi_line_re$" { verbose "partial: match" 3 } 1041 timeout { verbose "partial: timeout" 3 } 1042 } 1043 set string [string range "$string" [expr $foo + 1] end] 1044 set multi_line_re "$multi_line_re.*\[\r\n\] *>" 1045 } else { 1046 break 1047 } 1048 } 1049 if { "$string" != "" } { 1050 if { [send_gdb "$string"] != "" } { 1051 perror "Couldn't send $command to GDB." 1052 } 1053 } 1054 } 1055 1056 set code $early_processed_code 1057 append code { 1058 -re ".*A problem internal to GDB has been detected" { 1059 fail "$message (GDB internal error)" 1060 gdb_internal_error_resync 1061 set result -1 1062 } 1063 -re "\\*\\*\\* DOSEXIT code.*" { 1064 if { $message != "" } { 1065 fail "$message" 1066 } 1067 set result -1 1068 } 1069 } 1070 append code $processed_code 1071 1072 # Reset the spawn id, in case the processed code used -i. 1073 append code { 1074 -i "$gdb_spawn_id" 1075 } 1076 1077 append code { 1078 -re "Ending remote debugging.*$prompt_regexp" { 1079 if ![isnative] then { 1080 warning "Can`t communicate to remote target." 1081 } 1082 gdb_exit 1083 gdb_start 1084 set result -1 1085 } 1086 -re "Undefined\[a-z\]* command:.*$prompt_regexp" { 1087 perror "Undefined command \"$command\"." 1088 fail "$message" 1089 set result 1 1090 } 1091 -re "Ambiguous command.*$prompt_regexp" { 1092 perror "\"$command\" is not a unique command name." 1093 fail "$message" 1094 set result 1 1095 } 1096 -re "$inferior_exited_re with code \[0-9\]+.*$prompt_regexp" { 1097 if ![string match "" $message] then { 1098 set errmsg "$message (the program exited)" 1099 } else { 1100 set errmsg "$command (the program exited)" 1101 } 1102 fail "$errmsg" 1103 set result -1 1104 } 1105 -re "$inferior_exited_re normally.*$prompt_regexp" { 1106 if ![string match "" $message] then { 1107 set errmsg "$message (the program exited)" 1108 } else { 1109 set errmsg "$command (the program exited)" 1110 } 1111 fail "$errmsg" 1112 set result -1 1113 } 1114 -re "The program is not being run.*$prompt_regexp" { 1115 if ![string match "" $message] then { 1116 set errmsg "$message (the program is no longer running)" 1117 } else { 1118 set errmsg "$command (the program is no longer running)" 1119 } 1120 fail "$errmsg" 1121 set result -1 1122 } 1123 -re "\r\n$prompt_regexp" { 1124 if ![string match "" $message] then { 1125 fail "$message" 1126 } 1127 set result 1 1128 } 1129 -re "$pagination_prompt" { 1130 send_gdb "\n" 1131 perror "Window too small." 1132 fail "$message" 1133 set result -1 1134 } 1135 -re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " { 1136 send_gdb "n\n" answer 1137 gdb_expect -re "$prompt_regexp" 1138 fail "$message (got interactive prompt)" 1139 set result -1 1140 } 1141 -re "\\\[0\\\] cancel\r\n\\\[1\\\] all.*\r\n> $" { 1142 send_gdb "0\n" 1143 gdb_expect -re "$prompt_regexp" 1144 fail "$message (got breakpoint menu)" 1145 set result -1 1146 } 1147 1148 -i $gdb_spawn_id 1149 eof { 1150 perror "GDB process no longer exists" 1151 set wait_status [wait -i $gdb_spawn_id] 1152 verbose -log "GDB process exited with wait status $wait_status" 1153 if { $message != "" } { 1154 fail "$message" 1155 } 1156 return -1 1157 } 1158 } 1159 1160 if {$line_by_line} { 1161 append code { 1162 -re "\r\n\[^\r\n\]*(?=\r\n)" { 1163 exp_continue 1164 } 1165 } 1166 } 1167 1168 # Now patterns that apply to any spawn id specified. 1169 append code { 1170 -i $any_spawn_id 1171 eof { 1172 perror "Process no longer exists" 1173 if { $message != "" } { 1174 fail "$message" 1175 } 1176 return -1 1177 } 1178 full_buffer { 1179 perror "internal buffer is full." 1180 fail "$message" 1181 set result -1 1182 } 1183 timeout { 1184 if ![string match "" $message] then { 1185 fail "$message (timeout)" 1186 } 1187 set result 1 1188 } 1189 } 1190 1191 # remote_expect calls the eof section if there is an error on the 1192 # expect call. We already have eof sections above, and we don't 1193 # want them to get called in that situation. Since the last eof 1194 # section becomes the error section, here we define another eof 1195 # section, but with an empty spawn_id list, so that it won't ever 1196 # match. 1197 append code { 1198 -i "" eof { 1199 # This comment is here because the eof section must not be 1200 # the empty string, otherwise remote_expect won't realize 1201 # it exists. 1202 } 1203 } 1204 1205 # Create gdb_test_name in the parent scope. If this variable 1206 # already exists, which it might if we have nested calls to 1207 # gdb_test_multiple, then preserve the old value, otherwise, 1208 # create a new variable in the parent scope. 1209 upvar gdb_test_name gdb_test_name 1210 if { [info exists gdb_test_name] } { 1211 set gdb_test_name_old "$gdb_test_name" 1212 } 1213 set gdb_test_name "$message" 1214 1215 set result 0 1216 set code [catch {gdb_expect $code} string] 1217 1218 # Clean up the gdb_test_name variable. If we had a 1219 # previous value then restore it, otherwise, delete the variable 1220 # from the parent scope. 1221 if { [info exists gdb_test_name_old] } { 1222 set gdb_test_name "$gdb_test_name_old" 1223 } else { 1224 unset gdb_test_name 1225 } 1226 1227 if {$code == 1} { 1228 global errorInfo errorCode 1229 return -code error -errorinfo $errorInfo -errorcode $errorCode $string 1230 } elseif {$code > 1} { 1231 return -code $code $string 1232 } 1233 return $result 1234} 1235 1236# Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ... 1237# Run a test named NAME, consisting of multiple lines of input. 1238# After each input line INPUT, search for result line RESULT. 1239# Succeed if all results are seen; fail otherwise. 1240 1241proc gdb_test_multiline { name args } { 1242 global gdb_prompt 1243 set inputnr 0 1244 foreach {input result} $args { 1245 incr inputnr 1246 if {[gdb_test_multiple $input "$name: input $inputnr: $input" { 1247 -re "\[\r\n\]*($result)\[\r\n\]+($gdb_prompt | *>)$" { 1248 pass $gdb_test_name 1249 } 1250 }]} { 1251 return 1 1252 } 1253 } 1254 return 0 1255} 1256 1257 1258# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE 1259# Send a command to gdb; test the result. 1260# 1261# COMMAND is the command to execute, send to GDB with send_gdb. If 1262# this is the null string no command is sent. 1263# PATTERN is the pattern to match for a PASS, and must NOT include 1264# the \r\n sequence immediately before the gdb prompt. This argument 1265# may be omitted to just match the prompt, ignoring whatever output 1266# precedes it. 1267# MESSAGE is an optional message to be printed. If this is 1268# omitted, then the pass/fail messages use the command string as the 1269# message. (If this is the empty string, then sometimes we don't 1270# call pass or fail at all; I don't understand this at all.) 1271# QUESTION is a question GDB may ask in response to COMMAND, like 1272# "are you sure?" 1273# RESPONSE is the response to send if QUESTION appears. 1274# 1275# Returns: 1276# 1 if the test failed, 1277# 0 if the test passes, 1278# -1 if there was an internal error. 1279# 1280proc gdb_test { args } { 1281 global gdb_prompt 1282 upvar timeout timeout 1283 1284 if [llength $args]>2 then { 1285 set message [lindex $args 2] 1286 } else { 1287 set message [lindex $args 0] 1288 } 1289 set command [lindex $args 0] 1290 set pattern [lindex $args 1] 1291 1292 set user_code {} 1293 lappend user_code { 1294 -re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" { 1295 if ![string match "" $message] then { 1296 pass "$message" 1297 } 1298 } 1299 } 1300 1301 if { [llength $args] == 5 } { 1302 set question_string [lindex $args 3] 1303 set response_string [lindex $args 4] 1304 lappend user_code { 1305 -re "(${question_string})$" { 1306 send_gdb "$response_string\n" 1307 exp_continue 1308 } 1309 } 1310 } 1311 1312 set user_code [join $user_code] 1313 return [gdb_test_multiple $command $message $user_code] 1314} 1315 1316# Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR. 1317proc version_at_least { major minor at_least_major at_least_minor} { 1318 if { $major > $at_least_major } { 1319 return 1 1320 } elseif { $major == $at_least_major \ 1321 && $minor >= $at_least_minor } { 1322 return 1 1323 } else { 1324 return 0 1325 } 1326} 1327 1328# Return 1 if tcl version used is at least MAJOR.MINOR 1329proc tcl_version_at_least { major minor } { 1330 global tcl_version 1331 regexp {^([0-9]+)\.([0-9]+)$} $tcl_version \ 1332 dummy tcl_version_major tcl_version_minor 1333 return [version_at_least $tcl_version_major $tcl_version_minor \ 1334 $major $minor] 1335} 1336 1337if { [tcl_version_at_least 8 5] == 0 } { 1338 # lrepeat was added in tcl 8.5. Only add if missing. 1339 proc lrepeat { n element } { 1340 if { [string is integer -strict $n] == 0 } { 1341 error "expected integer but got \"$n\"" 1342 } 1343 if { $n < 0 } { 1344 error "bad count \"$n\": must be integer >= 0" 1345 } 1346 set res [list] 1347 for {set i 0} {$i < $n} {incr i} { 1348 lappend res $element 1349 } 1350 return $res 1351 } 1352} 1353 1354# gdb_test_no_output COMMAND MESSAGE 1355# Send a command to GDB and verify that this command generated no output. 1356# 1357# See gdb_test_multiple for a description of the COMMAND and MESSAGE 1358# parameters. If MESSAGE is ommitted, then COMMAND will be used as 1359# the message. (If MESSAGE is the empty string, then sometimes we do not 1360# call pass or fail at all; I don't understand this at all.) 1361 1362proc gdb_test_no_output { args } { 1363 global gdb_prompt 1364 set command [lindex $args 0] 1365 if [llength $args]>1 then { 1366 set message [lindex $args 1] 1367 } else { 1368 set message $command 1369 } 1370 1371 set command_regex [string_to_regexp $command] 1372 gdb_test_multiple $command $message { 1373 -re "^$command_regex\r\n$gdb_prompt $" { 1374 if ![string match "" $message] then { 1375 pass "$message" 1376 } 1377 } 1378 } 1379} 1380 1381# Send a command and then wait for a sequence of outputs. 1382# This is useful when the sequence is long and contains ".*", a single 1383# regexp to match the entire output can get a timeout much easier. 1384# 1385# COMMAND is the command to execute, send to GDB with send_gdb. If 1386# this is the null string no command is sent. 1387# TEST_NAME is passed to pass/fail. COMMAND is used if TEST_NAME is "". 1388# EXPECTED_OUTPUT_LIST is a list of regexps of expected output, which are 1389# processed in order, and all must be present in the output. 1390# 1391# The -prompt switch can be used to override the prompt expected at the end of 1392# the output sequence. 1393# 1394# It is unnecessary to specify ".*" at the beginning or end of any regexp, 1395# there is an implicit ".*" between each element of EXPECTED_OUTPUT_LIST. 1396# There is also an implicit ".*" between the last regexp and the gdb prompt. 1397# 1398# Like gdb_test and gdb_test_multiple, the output is expected to end with the 1399# gdb prompt, which must not be specified in EXPECTED_OUTPUT_LIST. 1400# 1401# Returns: 1402# 1 if the test failed, 1403# 0 if the test passes, 1404# -1 if there was an internal error. 1405 1406proc gdb_test_sequence { args } { 1407 global gdb_prompt 1408 1409 parse_args {{prompt ""}} 1410 1411 if { $prompt == "" } { 1412 set prompt "$gdb_prompt $" 1413 } 1414 1415 if { [llength $args] != 3 } { 1416 error "Unexpected # of arguments, expecting: COMMAND TEST_NAME EXPECTED_OUTPUT_LIST" 1417 } 1418 1419 lassign $args command test_name expected_output_list 1420 1421 if { $test_name == "" } { 1422 set test_name $command 1423 } 1424 1425 lappend expected_output_list ""; # implicit ".*" before gdb prompt 1426 1427 if { $command != "" } { 1428 send_gdb "$command\n" 1429 } 1430 1431 return [gdb_expect_list $test_name $prompt $expected_output_list] 1432} 1433 1434 1435# Match output of COMMAND using RE. Read output line-by-line. 1436# Report pass/fail with MESSAGE. 1437# For a command foo with output: 1438# (gdb) foo^M 1439# <line1>^M 1440# <line2>^M 1441# (gdb) 1442# the portion matched using RE is: 1443# '<line1>^M 1444# <line2>^M 1445# ' 1446 1447proc gdb_test_lines { command message re } { 1448 set found 0 1449 set idx 0 1450 if { $message == ""} { 1451 set message $command 1452 } 1453 set lines "" 1454 gdb_test_multiple $command $message { 1455 -re "\r\n(\[^\r\n\]*)(?=\r\n)" { 1456 set line $expect_out(1,string) 1457 if { $lines eq "" } { 1458 append lines "$line" 1459 } else { 1460 append lines "\r\n$line" 1461 } 1462 exp_continue 1463 } 1464 -re -wrap "" { 1465 append lines "\r\n" 1466 } 1467 } 1468 1469 gdb_assert { [regexp $re $lines] } $message 1470} 1471 1472# Test that a command gives an error. For pass or fail, return 1473# a 1 to indicate that more tests can proceed. However a timeout 1474# is a serious error, generates a special fail message, and causes 1475# a 0 to be returned to indicate that more tests are likely to fail 1476# as well. 1477 1478proc test_print_reject { args } { 1479 global gdb_prompt 1480 global verbose 1481 1482 if [llength $args]==2 then { 1483 set expectthis [lindex $args 1] 1484 } else { 1485 set expectthis "should never match this bogus string" 1486 } 1487 set sendthis [lindex $args 0] 1488 if $verbose>2 then { 1489 send_user "Sending \"$sendthis\" to gdb\n" 1490 send_user "Looking to match \"$expectthis\"\n" 1491 } 1492 send_gdb "$sendthis\n" 1493 #FIXME: Should add timeout as parameter. 1494 gdb_expect { 1495 -re "A .* in expression.*\\.*$gdb_prompt $" { 1496 pass "reject $sendthis" 1497 return 1 1498 } 1499 -re "Invalid syntax in expression.*$gdb_prompt $" { 1500 pass "reject $sendthis" 1501 return 1 1502 } 1503 -re "Junk after end of expression.*$gdb_prompt $" { 1504 pass "reject $sendthis" 1505 return 1 1506 } 1507 -re "Invalid number.*$gdb_prompt $" { 1508 pass "reject $sendthis" 1509 return 1 1510 } 1511 -re "Invalid character constant.*$gdb_prompt $" { 1512 pass "reject $sendthis" 1513 return 1 1514 } 1515 -re "No symbol table is loaded.*$gdb_prompt $" { 1516 pass "reject $sendthis" 1517 return 1 1518 } 1519 -re "No symbol .* in current context.*$gdb_prompt $" { 1520 pass "reject $sendthis" 1521 return 1 1522 } 1523 -re "Unmatched single quote.*$gdb_prompt $" { 1524 pass "reject $sendthis" 1525 return 1 1526 } 1527 -re "A character constant must contain at least one character.*$gdb_prompt $" { 1528 pass "reject $sendthis" 1529 return 1 1530 } 1531 -re "$expectthis.*$gdb_prompt $" { 1532 pass "reject $sendthis" 1533 return 1 1534 } 1535 -re ".*$gdb_prompt $" { 1536 fail "reject $sendthis" 1537 return 1 1538 } 1539 default { 1540 fail "reject $sendthis (eof or timeout)" 1541 return 0 1542 } 1543 } 1544} 1545 1546 1547# Same as gdb_test, but the second parameter is not a regexp, 1548# but a string that must match exactly. 1549 1550proc gdb_test_exact { args } { 1551 upvar timeout timeout 1552 1553 set command [lindex $args 0] 1554 1555 # This applies a special meaning to a null string pattern. Without 1556 # this, "$pattern\r\n$gdb_prompt $" will match anything, including error 1557 # messages from commands that should have no output except a new 1558 # prompt. With this, only results of a null string will match a null 1559 # string pattern. 1560 1561 set pattern [lindex $args 1] 1562 if [string match $pattern ""] { 1563 set pattern [string_to_regexp [lindex $args 0]] 1564 } else { 1565 set pattern [string_to_regexp [lindex $args 1]] 1566 } 1567 1568 # It is most natural to write the pattern argument with only 1569 # embedded \n's, especially if you are trying to avoid Tcl quoting 1570 # problems. But gdb_expect really wants to see \r\n in patterns. So 1571 # transform the pattern here. First transform \r\n back to \n, in 1572 # case some users of gdb_test_exact already do the right thing. 1573 regsub -all "\r\n" $pattern "\n" pattern 1574 regsub -all "\n" $pattern "\r\n" pattern 1575 if [llength $args]==3 then { 1576 set message [lindex $args 2] 1577 return [gdb_test $command $pattern $message] 1578 } 1579 1580 return [gdb_test $command $pattern] 1581} 1582 1583# Wrapper around gdb_test_multiple that looks for a list of expected 1584# output elements, but which can appear in any order. 1585# CMD is the gdb command. 1586# NAME is the name of the test. 1587# ELM_FIND_REGEXP specifies how to partition the output into elements to 1588# compare. 1589# ELM_EXTRACT_REGEXP specifies the part of ELM_FIND_REGEXP to compare. 1590# RESULT_MATCH_LIST is a list of exact matches for each expected element. 1591# All elements of RESULT_MATCH_LIST must appear for the test to pass. 1592# 1593# A typical use of ELM_FIND_REGEXP/ELM_EXTRACT_REGEXP is to extract one line 1594# of text per element and then strip trailing \r\n's. 1595# Example: 1596# gdb_test_list_exact "foo" "bar" \ 1597# "\[^\r\n\]+\[\r\n\]+" \ 1598# "\[^\r\n\]+" \ 1599# { \ 1600# {expected result 1} \ 1601# {expected result 2} \ 1602# } 1603 1604proc gdb_test_list_exact { cmd name elm_find_regexp elm_extract_regexp result_match_list } { 1605 global gdb_prompt 1606 1607 set matches [lsort $result_match_list] 1608 set seen {} 1609 gdb_test_multiple $cmd $name { 1610 "$cmd\[\r\n\]" { exp_continue } 1611 -re $elm_find_regexp { 1612 set str $expect_out(0,string) 1613 verbose -log "seen: $str" 3 1614 regexp -- $elm_extract_regexp $str elm_seen 1615 verbose -log "extracted: $elm_seen" 3 1616 lappend seen $elm_seen 1617 exp_continue 1618 } 1619 -re "$gdb_prompt $" { 1620 set failed "" 1621 foreach got [lsort $seen] have $matches { 1622 if {![string equal $got $have]} { 1623 set failed $have 1624 break 1625 } 1626 } 1627 if {[string length $failed] != 0} { 1628 fail "$name ($failed not found)" 1629 } else { 1630 pass $name 1631 } 1632 } 1633 } 1634} 1635 1636# gdb_test_stdio COMMAND INFERIOR_PATTERN GDB_PATTERN MESSAGE 1637# Send a command to gdb; expect inferior and gdb output. 1638# 1639# See gdb_test_multiple for a description of the COMMAND and MESSAGE 1640# parameters. 1641# 1642# INFERIOR_PATTERN is the pattern to match against inferior output. 1643# 1644# GDB_PATTERN is the pattern to match against gdb output, and must NOT 1645# include the \r\n sequence immediately before the gdb prompt, nor the 1646# prompt. The default is empty. 1647# 1648# Both inferior and gdb patterns must match for a PASS. 1649# 1650# If MESSAGE is ommitted, then COMMAND will be used as the message. 1651# 1652# Returns: 1653# 1 if the test failed, 1654# 0 if the test passes, 1655# -1 if there was an internal error. 1656# 1657 1658proc gdb_test_stdio {command inferior_pattern {gdb_pattern ""} {message ""}} { 1659 global inferior_spawn_id gdb_spawn_id 1660 global gdb_prompt 1661 1662 if {$message == ""} { 1663 set message $command 1664 } 1665 1666 set inferior_matched 0 1667 set gdb_matched 0 1668 1669 # Use an indirect spawn id list, and remove the inferior spawn id 1670 # from the expected output as soon as it matches, in case 1671 # $inferior_pattern happens to be a prefix of the resulting full 1672 # gdb pattern below (e.g., "\r\n"). 1673 global gdb_test_stdio_spawn_id_list 1674 set gdb_test_stdio_spawn_id_list "$inferior_spawn_id" 1675 1676 # Note that if $inferior_spawn_id and $gdb_spawn_id are different, 1677 # then we may see gdb's output arriving before the inferior's 1678 # output. 1679 set res [gdb_test_multiple $command $message { 1680 -i gdb_test_stdio_spawn_id_list -re "$inferior_pattern" { 1681 set inferior_matched 1 1682 if {!$gdb_matched} { 1683 set gdb_test_stdio_spawn_id_list "" 1684 exp_continue 1685 } 1686 } 1687 -i $gdb_spawn_id -re "$gdb_pattern\r\n$gdb_prompt $" { 1688 set gdb_matched 1 1689 if {!$inferior_matched} { 1690 exp_continue 1691 } 1692 } 1693 }] 1694 if {$res == 0} { 1695 pass $message 1696 } else { 1697 verbose -log "inferior_matched=$inferior_matched, gdb_matched=$gdb_matched" 1698 } 1699 return $res 1700} 1701 1702# Wrapper around gdb_test_multiple to be used when testing expression 1703# evaluation while 'set debug expression 1' is in effect. 1704# Looks for some patterns that indicates the expression was rejected. 1705# 1706# CMD is the command to execute, which should include an expression 1707# that GDB will need to parse. 1708# 1709# OUTPUT is the expected output pattern. 1710# 1711# TESTNAME is the name to be used for the test, defaults to CMD if not 1712# given. 1713proc gdb_test_debug_expr { cmd output {testname "" }} { 1714 global gdb_prompt 1715 1716 if { ${testname} == "" } { 1717 set testname $cmd 1718 } 1719 1720 gdb_test_multiple $cmd $testname { 1721 -re ".*Invalid expression.*\r\n$gdb_prompt $" { 1722 fail $gdb_test_name 1723 } 1724 -re ".*\[\r\n\]$output\r\n$gdb_prompt $" { 1725 pass $gdb_test_name 1726 } 1727 } 1728} 1729 1730# get_print_expr_at_depths EXP OUTPUTS 1731# 1732# Used for testing 'set print max-depth'. Prints the expression EXP 1733# with 'set print max-depth' set to various depths. OUTPUTS is a list 1734# of `n` different patterns to match at each of the depths from 0 to 1735# (`n` - 1). 1736# 1737# This proc does one final check with the max-depth set to 'unlimited' 1738# which is tested against the last pattern in the OUTPUTS list. The 1739# OUTPUTS list is therefore required to match every depth from 0 to a 1740# depth where the whole of EXP is printed with no ellipsis. 1741# 1742# This proc leaves the 'set print max-depth' set to 'unlimited'. 1743proc gdb_print_expr_at_depths {exp outputs} { 1744 for { set depth 0 } { $depth <= [llength $outputs] } { incr depth } { 1745 if { $depth == [llength $outputs] } { 1746 set expected_result [lindex $outputs [expr [llength $outputs] - 1]] 1747 set depth_string "unlimited" 1748 } else { 1749 set expected_result [lindex $outputs $depth] 1750 set depth_string $depth 1751 } 1752 1753 with_test_prefix "exp='$exp': depth=${depth_string}" { 1754 gdb_test_no_output "set print max-depth ${depth_string}" 1755 gdb_test "p $exp" "$expected_result" 1756 } 1757 } 1758} 1759 1760 1761 1762# Issue a PASS and return true if evaluating CONDITION in the caller's 1763# frame returns true, and issue a FAIL and return false otherwise. 1764# MESSAGE is the pass/fail message to be printed. If MESSAGE is 1765# omitted or is empty, then the pass/fail messages use the condition 1766# string as the message. 1767 1768proc gdb_assert { condition {message ""} } { 1769 if { $message == ""} { 1770 set message $condition 1771 } 1772 1773 set code [catch {uplevel 1 expr $condition} res] 1774 if {$code == 1} { 1775 # If code is 1 (TCL_ERROR), it means evaluation failed and res contains 1776 # an error message. Print the error message, and set res to 0 since we 1777 # want to return a boolean. 1778 warning "While evaluating expression in gdb_assert: $res" 1779 unresolved $message 1780 set res 0 1781 } elseif { !$res } { 1782 fail $message 1783 } else { 1784 pass $message 1785 } 1786 return $res 1787} 1788 1789proc gdb_reinitialize_dir { subdir } { 1790 global gdb_prompt 1791 1792 if [is_remote host] { 1793 return "" 1794 } 1795 send_gdb "dir\n" 1796 gdb_expect 60 { 1797 -re "Reinitialize source path to empty.*y or n. " { 1798 send_gdb "y\n" answer 1799 gdb_expect 60 { 1800 -re "Source directories searched.*$gdb_prompt $" { 1801 send_gdb "dir $subdir\n" 1802 gdb_expect 60 { 1803 -re "Source directories searched.*$gdb_prompt $" { 1804 verbose "Dir set to $subdir" 1805 } 1806 -re "$gdb_prompt $" { 1807 perror "Dir \"$subdir\" failed." 1808 } 1809 } 1810 } 1811 -re "$gdb_prompt $" { 1812 perror "Dir \"$subdir\" failed." 1813 } 1814 } 1815 } 1816 -re "$gdb_prompt $" { 1817 perror "Dir \"$subdir\" failed." 1818 } 1819 } 1820} 1821 1822# 1823# gdb_exit -- exit the GDB, killing the target program if necessary 1824# 1825proc default_gdb_exit {} { 1826 global GDB 1827 global INTERNAL_GDBFLAGS GDBFLAGS 1828 global gdb_spawn_id inferior_spawn_id 1829 global inotify_log_file 1830 1831 if ![info exists gdb_spawn_id] { 1832 return 1833 } 1834 1835 verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" 1836 1837 if {[info exists inotify_log_file] && [file exists $inotify_log_file]} { 1838 set fd [open $inotify_log_file] 1839 set data [read -nonewline $fd] 1840 close $fd 1841 1842 if {[string compare $data ""] != 0} { 1843 warning "parallel-unsafe file creations noticed" 1844 1845 # Clear the log. 1846 set fd [open $inotify_log_file w] 1847 close $fd 1848 } 1849 } 1850 1851 if { [is_remote host] && [board_info host exists fileid] } { 1852 send_gdb "quit\n" 1853 gdb_expect 10 { 1854 -re "y or n" { 1855 send_gdb "y\n" answer 1856 exp_continue 1857 } 1858 -re "DOSEXIT code" { } 1859 default { } 1860 } 1861 } 1862 1863 if ![is_remote host] { 1864 remote_close host 1865 } 1866 unset gdb_spawn_id 1867 unset ::gdb_tty_name 1868 unset inferior_spawn_id 1869} 1870 1871# Load a file into the debugger. 1872# The return value is 0 for success, -1 for failure. 1873# 1874# This procedure also set the global variable GDB_FILE_CMD_DEBUG_INFO 1875# to one of these values: 1876# 1877# debug file was loaded successfully and has debug information 1878# nodebug file was loaded successfully and has no debug information 1879# lzma file was loaded, .gnu_debugdata found, but no LZMA support 1880# compiled in 1881# fail file was not loaded 1882# 1883# This procedure also set the global variable GDB_FILE_CMD_MSG to the 1884# output of the file command in case of success. 1885# 1886# I tried returning this information as part of the return value, 1887# but ran into a mess because of the many re-implementations of 1888# gdb_load in config/*.exp. 1889# 1890# TODO: gdb.base/sepdebug.exp and gdb.stabs/weird.exp might be able to use 1891# this if they can get more information set. 1892 1893proc gdb_file_cmd { arg } { 1894 global gdb_prompt 1895 global GDB 1896 global last_loaded_file 1897 1898 # GCC for Windows target may create foo.exe given "-o foo". 1899 if { ![file exists $arg] && [file exists "$arg.exe"] } { 1900 set arg "$arg.exe" 1901 } 1902 1903 # Save this for the benefit of gdbserver-support.exp. 1904 set last_loaded_file $arg 1905 1906 # Set whether debug info was found. 1907 # Default to "fail". 1908 global gdb_file_cmd_debug_info gdb_file_cmd_msg 1909 set gdb_file_cmd_debug_info "fail" 1910 1911 if [is_remote host] { 1912 set arg [remote_download host $arg] 1913 if { $arg == "" } { 1914 perror "download failed" 1915 return -1 1916 } 1917 } 1918 1919 # The file command used to kill the remote target. For the benefit 1920 # of the testsuite, preserve this behavior. Mark as optional so it doesn't 1921 # get written to the stdin log. 1922 send_gdb "kill\n" optional 1923 gdb_expect 120 { 1924 -re "Kill the program being debugged. .y or n. $" { 1925 send_gdb "y\n" answer 1926 verbose "\t\tKilling previous program being debugged" 1927 exp_continue 1928 } 1929 -re "$gdb_prompt $" { 1930 # OK. 1931 } 1932 } 1933 1934 send_gdb "file $arg\n" 1935 set new_symbol_table 0 1936 set basename [file tail $arg] 1937 gdb_expect 120 { 1938 -re "(Reading symbols from.*LZMA support was disabled.*$gdb_prompt $)" { 1939 verbose "\t\tLoaded $arg into $GDB; .gnu_debugdata found but no LZMA available" 1940 set gdb_file_cmd_msg $expect_out(1,string) 1941 set gdb_file_cmd_debug_info "lzma" 1942 return 0 1943 } 1944 -re "(Reading symbols from.*no debugging symbols found.*$gdb_prompt $)" { 1945 verbose "\t\tLoaded $arg into $GDB with no debugging symbols" 1946 set gdb_file_cmd_msg $expect_out(1,string) 1947 set gdb_file_cmd_debug_info "nodebug" 1948 return 0 1949 } 1950 -re "(Reading symbols from.*$gdb_prompt $)" { 1951 verbose "\t\tLoaded $arg into $GDB" 1952 set gdb_file_cmd_msg $expect_out(1,string) 1953 set gdb_file_cmd_debug_info "debug" 1954 return 0 1955 } 1956 -re "Load new symbol table from \".*\".*y or n. $" { 1957 if { $new_symbol_table > 0 } { 1958 perror [join [list "Couldn't load $basename," 1959 "interactive prompt loop detected."]] 1960 return -1 1961 } 1962 send_gdb "y\n" answer 1963 incr new_symbol_table 1964 set suffix "-- with new symbol table" 1965 set arg "$arg $suffix" 1966 set basename "$basename $suffix" 1967 exp_continue 1968 } 1969 -re "No such file or directory.*$gdb_prompt $" { 1970 perror "($basename) No such file or directory" 1971 return -1 1972 } 1973 -re "A problem internal to GDB has been detected" { 1974 perror "Couldn't load $basename into GDB (GDB internal error)." 1975 gdb_internal_error_resync 1976 return -1 1977 } 1978 -re "$gdb_prompt $" { 1979 perror "Couldn't load $basename into GDB." 1980 return -1 1981 } 1982 timeout { 1983 perror "Couldn't load $basename into GDB (timeout)." 1984 return -1 1985 } 1986 eof { 1987 # This is an attempt to detect a core dump, but seems not to 1988 # work. Perhaps we need to match .* followed by eof, in which 1989 # gdb_expect does not seem to have a way to do that. 1990 perror "Couldn't load $basename into GDB (eof)." 1991 return -1 1992 } 1993 } 1994} 1995 1996# The expect "spawn" function puts the tty name into the spawn_out 1997# array; but dejagnu doesn't export this globally. So, we have to 1998# wrap spawn with our own function and poke in the built-in spawn 1999# so that we can capture this value. 2000# 2001# If available, the TTY name is saved to the LAST_SPAWN_TTY_NAME global. 2002# Otherwise, LAST_SPAWN_TTY_NAME is unset. 2003 2004proc spawn_capture_tty_name { args } { 2005 set result [uplevel builtin_spawn $args] 2006 upvar spawn_out spawn_out 2007 if { [info exists spawn_out] } { 2008 set ::last_spawn_tty_name $spawn_out(slave,name) 2009 } else { 2010 unset ::last_spawn_tty_name 2011 } 2012 return $result 2013} 2014 2015rename spawn builtin_spawn 2016rename spawn_capture_tty_name spawn 2017 2018# Default gdb_spawn procedure. 2019 2020proc default_gdb_spawn { } { 2021 global use_gdb_stub 2022 global GDB 2023 global INTERNAL_GDBFLAGS GDBFLAGS 2024 global gdb_spawn_id 2025 2026 # Set the default value, it may be overriden later by specific testfile. 2027 # 2028 # Use `set_board_info use_gdb_stub' for the board file to flag the inferior 2029 # is already started after connecting and run/attach are not supported. 2030 # This is used for the "remote" protocol. After GDB starts you should 2031 # check global $use_gdb_stub instead of the board as the testfile may force 2032 # a specific different target protocol itself. 2033 set use_gdb_stub [target_info exists use_gdb_stub] 2034 2035 verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" 2036 gdb_write_cmd_file "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS" 2037 2038 if [info exists gdb_spawn_id] { 2039 return 0 2040 } 2041 2042 if ![is_remote host] { 2043 if { [which $GDB] == 0 } then { 2044 perror "$GDB does not exist." 2045 exit 1 2046 } 2047 } 2048 set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS [host_info gdb_opts]"] 2049 if { $res < 0 || $res == "" } { 2050 perror "Spawning $GDB failed." 2051 return 1 2052 } 2053 2054 set gdb_spawn_id $res 2055 set ::gdb_tty_name $::last_spawn_tty_name 2056 return 0 2057} 2058 2059# Default gdb_start procedure. 2060 2061proc default_gdb_start { } { 2062 global gdb_prompt 2063 global gdb_spawn_id 2064 global inferior_spawn_id 2065 2066 if [info exists gdb_spawn_id] { 2067 return 0 2068 } 2069 2070 # Keep track of the number of times GDB has been launched. 2071 global gdb_instances 2072 incr gdb_instances 2073 2074 gdb_stdin_log_init 2075 2076 set res [gdb_spawn] 2077 if { $res != 0} { 2078 return $res 2079 } 2080 2081 # Default to assuming inferior I/O is done on GDB's terminal. 2082 if {![info exists inferior_spawn_id]} { 2083 set inferior_spawn_id $gdb_spawn_id 2084 } 2085 2086 # When running over NFS, particularly if running many simultaneous 2087 # tests on different hosts all using the same server, things can 2088 # get really slow. Give gdb at least 3 minutes to start up. 2089 gdb_expect 360 { 2090 -re "\[\r\n\]$gdb_prompt $" { 2091 verbose "GDB initialized." 2092 } 2093 -re "$gdb_prompt $" { 2094 perror "GDB never initialized." 2095 unset gdb_spawn_id 2096 return -1 2097 } 2098 timeout { 2099 perror "(timeout) GDB never initialized after 10 seconds." 2100 remote_close host 2101 unset gdb_spawn_id 2102 return -1 2103 } 2104 eof { 2105 perror "(eof) GDB never initialized." 2106 unset gdb_spawn_id 2107 return -1 2108 } 2109 } 2110 2111 # force the height to "unlimited", so no pagers get used 2112 2113 send_gdb "set height 0\n" 2114 gdb_expect 10 { 2115 -re "$gdb_prompt $" { 2116 verbose "Setting height to 0." 2 2117 } 2118 timeout { 2119 warning "Couldn't set the height to 0" 2120 } 2121 } 2122 # force the width to "unlimited", so no wraparound occurs 2123 send_gdb "set width 0\n" 2124 gdb_expect 10 { 2125 -re "$gdb_prompt $" { 2126 verbose "Setting width to 0." 2 2127 } 2128 timeout { 2129 warning "Couldn't set the width to 0." 2130 } 2131 } 2132 2133 gdb_debug_init 2134 return 0 2135} 2136 2137# Utility procedure to give user control of the gdb prompt in a script. It is 2138# meant to be used for debugging test cases, and should not be left in the 2139# test cases code. 2140 2141proc gdb_interact { } { 2142 global gdb_spawn_id 2143 set spawn_id $gdb_spawn_id 2144 2145 send_user "+------------------------------------------+\n" 2146 send_user "| Script interrupted, you can now interact |\n" 2147 send_user "| with by gdb. Type >>> to continue. |\n" 2148 send_user "+------------------------------------------+\n" 2149 2150 interact { 2151 ">>>" return 2152 } 2153} 2154 2155# Examine the output of compilation to determine whether compilation 2156# failed or not. If it failed determine whether it is due to missing 2157# compiler or due to compiler error. Report pass, fail or unsupported 2158# as appropriate. 2159 2160proc gdb_compile_test {src output} { 2161 set msg "compilation [file tail $src]" 2162 2163 if { $output == "" } { 2164 pass $msg 2165 return 2166 } 2167 2168 if { [regexp {^[a-zA-Z_0-9]+: Can't find [^ ]+\.$} $output] 2169 || [regexp {.*: command not found[\r|\n]*$} $output] 2170 || [regexp {.*: [^\r\n]*compiler not installed[^\r\n]*[\r|\n]*$} $output] } { 2171 unsupported "$msg (missing compiler)" 2172 return 2173 } 2174 2175 set gcc_re ".*: error: unrecognized command line option " 2176 set clang_re ".*: error: unsupported option " 2177 if { [regexp "(?:$gcc_re|$clang_re)(\[^ \t;\r\n\]*)" $output dummy option] 2178 && $option != "" } { 2179 unsupported "$msg (unsupported option $option)" 2180 return 2181 } 2182 2183 # Unclassified compilation failure, be more verbose. 2184 verbose -log "compilation failed: $output" 2 2185 fail "$msg" 2186} 2187 2188# Return a 1 for configurations for which we don't even want to try to 2189# test C++. 2190 2191proc skip_cplus_tests {} { 2192 if { [istarget "h8300-*-*"] } { 2193 return 1 2194 } 2195 2196 # The C++ IO streams are too large for HC11/HC12 and are thus not 2197 # available. The gdb C++ tests use them and don't compile. 2198 if { [istarget "m6811-*-*"] } { 2199 return 1 2200 } 2201 if { [istarget "m6812-*-*"] } { 2202 return 1 2203 } 2204 return 0 2205} 2206 2207# Return a 1 for configurations for which don't have both C++ and the STL. 2208 2209proc skip_stl_tests {} { 2210 return [skip_cplus_tests] 2211} 2212 2213# Return a 1 if I don't even want to try to test FORTRAN. 2214 2215proc skip_fortran_tests {} { 2216 return 0 2217} 2218 2219# Return a 1 if I don't even want to try to test ada. 2220 2221proc skip_ada_tests {} { 2222 return 0 2223} 2224 2225# Return a 1 if I don't even want to try to test GO. 2226 2227proc skip_go_tests {} { 2228 return 0 2229} 2230 2231# Return a 1 if I don't even want to try to test D. 2232 2233proc skip_d_tests {} { 2234 return 0 2235} 2236 2237# Return 1 to skip Rust tests, 0 to try them. 2238proc skip_rust_tests {} { 2239 if { ![isnative] } { 2240 return 1 2241 } 2242 2243 # The rust compiler does not support "-m32", skip. 2244 global board board_info 2245 set board [target_info name] 2246 if {[board_info $board exists multilib_flags]} { 2247 foreach flag [board_info $board multilib_flags] { 2248 if { $flag == "-m32" } { 2249 return 1 2250 } 2251 } 2252 } 2253 2254 return 0 2255} 2256 2257# Return a 1 for configurations that do not support Python scripting. 2258# PROMPT_REGEXP is the expected prompt. 2259 2260proc skip_python_tests_prompt { prompt_regexp } { 2261 global gdb_py_is_py3k 2262 2263 gdb_test_multiple "python print ('test')" "verify python support" \ 2264 -prompt "$prompt_regexp" { 2265 -re "not supported.*$prompt_regexp" { 2266 unsupported "Python support is disabled." 2267 return 1 2268 } 2269 -re "$prompt_regexp" {} 2270 } 2271 2272 gdb_test_multiple "python print (sys.version_info\[0\])" "check if python 3" \ 2273 -prompt "$prompt_regexp" { 2274 -re "3.*$prompt_regexp" { 2275 set gdb_py_is_py3k 1 2276 } 2277 -re ".*$prompt_regexp" { 2278 set gdb_py_is_py3k 0 2279 } 2280 } 2281 2282 return 0 2283} 2284 2285# Return a 1 for configurations that do not support Python scripting. 2286# Note: This also sets various globals that specify which version of Python 2287# is in use. See skip_python_tests_prompt. 2288 2289proc skip_python_tests {} { 2290 global gdb_prompt 2291 return [skip_python_tests_prompt "$gdb_prompt $"] 2292} 2293 2294# Return a 1 if we should skip shared library tests. 2295 2296proc skip_shlib_tests {} { 2297 # Run the shared library tests on native systems. 2298 if {[isnative]} { 2299 return 0 2300 } 2301 2302 # An abbreviated list of remote targets where we should be able to 2303 # run shared library tests. 2304 if {([istarget *-*-linux*] 2305 || [istarget *-*-*bsd*] 2306 || [istarget *-*-solaris2*] 2307 || [istarget *-*-mingw*] 2308 || [istarget *-*-cygwin*] 2309 || [istarget *-*-pe*])} { 2310 return 0 2311 } 2312 2313 return 1 2314} 2315 2316# Return 1 if we should skip tui related tests. 2317 2318proc skip_tui_tests {} { 2319 global gdb_prompt 2320 2321 gdb_test_multiple "help layout" "verify tui support" { 2322 -re "Undefined command: \"layout\".*$gdb_prompt $" { 2323 return 1 2324 } 2325 -re "$gdb_prompt $" { 2326 } 2327 } 2328 2329 return 0 2330} 2331 2332# Test files shall make sure all the test result lines in gdb.sum are 2333# unique in a test run, so that comparing the gdb.sum files of two 2334# test runs gives correct results. Test files that exercise 2335# variations of the same tests more than once, shall prefix the 2336# different test invocations with different identifying strings in 2337# order to make them unique. 2338# 2339# About test prefixes: 2340# 2341# $pf_prefix is the string that dejagnu prints after the result (FAIL, 2342# PASS, etc.), and before the test message/name in gdb.sum. E.g., the 2343# underlined substring in 2344# 2345# PASS: gdb.base/mytest.exp: some test 2346# ^^^^^^^^^^^^^^^^^^^^ 2347# 2348# is $pf_prefix. 2349# 2350# The easiest way to adjust the test prefix is to append a test 2351# variation prefix to the $pf_prefix, using the with_test_prefix 2352# procedure. E.g., 2353# 2354# proc do_tests {} { 2355# gdb_test ... ... "test foo" 2356# gdb_test ... ... "test bar" 2357# 2358# with_test_prefix "subvariation a" { 2359# gdb_test ... ... "test x" 2360# } 2361# 2362# with_test_prefix "subvariation b" { 2363# gdb_test ... ... "test x" 2364# } 2365# } 2366# 2367# with_test_prefix "variation1" { 2368# ...do setup for variation 1... 2369# do_tests 2370# } 2371# 2372# with_test_prefix "variation2" { 2373# ...do setup for variation 2... 2374# do_tests 2375# } 2376# 2377# Results in: 2378# 2379# PASS: gdb.base/mytest.exp: variation1: test foo 2380# PASS: gdb.base/mytest.exp: variation1: test bar 2381# PASS: gdb.base/mytest.exp: variation1: subvariation a: test x 2382# PASS: gdb.base/mytest.exp: variation1: subvariation b: test x 2383# PASS: gdb.base/mytest.exp: variation2: test foo 2384# PASS: gdb.base/mytest.exp: variation2: test bar 2385# PASS: gdb.base/mytest.exp: variation2: subvariation a: test x 2386# PASS: gdb.base/mytest.exp: variation2: subvariation b: test x 2387# 2388# If for some reason more flexibility is necessary, one can also 2389# manipulate the pf_prefix global directly, treating it as a string. 2390# E.g., 2391# 2392# global pf_prefix 2393# set saved_pf_prefix 2394# append pf_prefix "${foo}: bar" 2395# ... actual tests ... 2396# set pf_prefix $saved_pf_prefix 2397# 2398 2399# Run BODY in the context of the caller, with the current test prefix 2400# (pf_prefix) appended with one space, then PREFIX, and then a colon. 2401# Returns the result of BODY. 2402# 2403proc with_test_prefix { prefix body } { 2404 global pf_prefix 2405 2406 set saved $pf_prefix 2407 append pf_prefix " " $prefix ":" 2408 set code [catch {uplevel 1 $body} result] 2409 set pf_prefix $saved 2410 2411 if {$code == 1} { 2412 global errorInfo errorCode 2413 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2414 } else { 2415 return -code $code $result 2416 } 2417} 2418 2419# Wrapper for foreach that calls with_test_prefix on each iteration, 2420# including the iterator's name and current value in the prefix. 2421 2422proc foreach_with_prefix {var list body} { 2423 upvar 1 $var myvar 2424 foreach myvar $list { 2425 with_test_prefix "$var=$myvar" { 2426 set code [catch {uplevel 1 $body} result] 2427 } 2428 2429 if {$code == 1} { 2430 global errorInfo errorCode 2431 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2432 } elseif {$code == 3} { 2433 break 2434 } elseif {$code == 2} { 2435 return -code $code $result 2436 } 2437 } 2438} 2439 2440# Like TCL's native proc, but defines a procedure that wraps its body 2441# within 'with_test_prefix "$proc_name" { ... }'. 2442proc proc_with_prefix {name arguments body} { 2443 # Define the advertised proc. 2444 proc $name $arguments [list with_test_prefix $name $body] 2445} 2446 2447 2448# Run BODY in the context of the caller. After BODY is run, the variables 2449# listed in VARS will be reset to the values they had before BODY was run. 2450# 2451# This is useful for providing a scope in which it is safe to temporarily 2452# modify global variables, e.g. 2453# 2454# global INTERNAL_GDBFLAGS 2455# global env 2456# 2457# set foo GDBHISTSIZE 2458# 2459# save_vars { INTERNAL_GDBFLAGS env($foo) env(HOME) } { 2460# append INTERNAL_GDBFLAGS " -nx" 2461# unset -nocomplain env(GDBHISTSIZE) 2462# gdb_start 2463# gdb_test ... 2464# } 2465# 2466# Here, although INTERNAL_GDBFLAGS, env(GDBHISTSIZE) and env(HOME) may be 2467# modified inside BODY, this proc guarantees that the modifications will be 2468# undone after BODY finishes executing. 2469 2470proc save_vars { vars body } { 2471 array set saved_scalars { } 2472 array set saved_arrays { } 2473 set unset_vars { } 2474 2475 foreach var $vars { 2476 # First evaluate VAR in the context of the caller in case the variable 2477 # name may be a not-yet-interpolated string like env($foo) 2478 set var [uplevel 1 list $var] 2479 2480 if [uplevel 1 [list info exists $var]] { 2481 if [uplevel 1 [list array exists $var]] { 2482 set saved_arrays($var) [uplevel 1 [list array get $var]] 2483 } else { 2484 set saved_scalars($var) [uplevel 1 [list set $var]] 2485 } 2486 } else { 2487 lappend unset_vars $var 2488 } 2489 } 2490 2491 set code [catch {uplevel 1 $body} result] 2492 2493 foreach {var value} [array get saved_scalars] { 2494 uplevel 1 [list set $var $value] 2495 } 2496 2497 foreach {var value} [array get saved_arrays] { 2498 uplevel 1 [list unset $var] 2499 uplevel 1 [list array set $var $value] 2500 } 2501 2502 foreach var $unset_vars { 2503 uplevel 1 [list unset -nocomplain $var] 2504 } 2505 2506 if {$code == 1} { 2507 global errorInfo errorCode 2508 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2509 } else { 2510 return -code $code $result 2511 } 2512} 2513 2514# As save_vars, but for variables stored in the board_info for the 2515# target board. 2516# 2517# Usage example: 2518# 2519# save_target_board_info { multilib_flags } { 2520# global board 2521# set board [target_info name] 2522# unset_board_info multilib_flags 2523# set_board_info multilib_flags "$multilib_flags" 2524# ... 2525# } 2526 2527proc save_target_board_info { vars body } { 2528 global board board_info 2529 set board [target_info name] 2530 2531 array set saved_target_board_info { } 2532 set unset_target_board_info { } 2533 2534 foreach var $vars { 2535 if { [info exists board_info($board,$var)] } { 2536 set saved_target_board_info($var) [board_info $board $var] 2537 } else { 2538 lappend unset_target_board_info $var 2539 } 2540 } 2541 2542 set code [catch {uplevel 1 $body} result] 2543 2544 foreach {var value} [array get saved_target_board_info] { 2545 unset_board_info $var 2546 set_board_info $var $value 2547 } 2548 2549 foreach var $unset_target_board_info { 2550 unset_board_info $var 2551 } 2552 2553 if {$code == 1} { 2554 global errorInfo errorCode 2555 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2556 } else { 2557 return -code $code $result 2558 } 2559} 2560 2561# Run tests in BODY with the current working directory (CWD) set to 2562# DIR. When BODY is finished, restore the original CWD. Return the 2563# result of BODY. 2564# 2565# This procedure doesn't check if DIR is a valid directory, so you 2566# have to make sure of that. 2567 2568proc with_cwd { dir body } { 2569 set saved_dir [pwd] 2570 verbose -log "Switching to directory $dir (saved CWD: $saved_dir)." 2571 cd $dir 2572 2573 set code [catch {uplevel 1 $body} result] 2574 2575 verbose -log "Switching back to $saved_dir." 2576 cd $saved_dir 2577 2578 if {$code == 1} { 2579 global errorInfo errorCode 2580 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2581 } else { 2582 return -code $code $result 2583 } 2584} 2585 2586# Run tests in BODY with GDB prompt and variable $gdb_prompt set to 2587# PROMPT. When BODY is finished, restore GDB prompt and variable 2588# $gdb_prompt. 2589# Returns the result of BODY. 2590# 2591# Notes: 2592# 2593# 1) If you want to use, for example, "(foo)" as the prompt you must pass it 2594# as "(foo)", and not the regexp form "\(foo\)" (expressed as "\\(foo\\)" in 2595# TCL). PROMPT is internally converted to a suitable regexp for matching. 2596# We do the conversion from "(foo)" to "\(foo\)" here for a few reasons: 2597# a) It's more intuitive for callers to pass the plain text form. 2598# b) We need two forms of the prompt: 2599# - a regexp to use in output matching, 2600# - a value to pass to the "set prompt" command. 2601# c) It's easier to convert the plain text form to its regexp form. 2602# 2603# 2) Don't add a trailing space, we do that here. 2604 2605proc with_gdb_prompt { prompt body } { 2606 global gdb_prompt 2607 2608 # Convert "(foo)" to "\(foo\)". 2609 # We don't use string_to_regexp because while it works today it's not 2610 # clear it will work tomorrow: the value we need must work as both a 2611 # regexp *and* as the argument to the "set prompt" command, at least until 2612 # we start recording both forms separately instead of just $gdb_prompt. 2613 # The testsuite is pretty-much hardwired to interpret $gdb_prompt as the 2614 # regexp form. 2615 regsub -all {[]*+.|()^$\[\\]} $prompt {\\&} prompt 2616 2617 set saved $gdb_prompt 2618 2619 verbose -log "Setting gdb prompt to \"$prompt \"." 2620 set gdb_prompt $prompt 2621 gdb_test_no_output "set prompt $prompt " "" 2622 2623 set code [catch {uplevel 1 $body} result] 2624 2625 verbose -log "Restoring gdb prompt to \"$saved \"." 2626 set gdb_prompt $saved 2627 gdb_test_no_output "set prompt $saved " "" 2628 2629 if {$code == 1} { 2630 global errorInfo errorCode 2631 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2632 } else { 2633 return -code $code $result 2634 } 2635} 2636 2637# Run tests in BODY with target-charset setting to TARGET_CHARSET. When 2638# BODY is finished, restore target-charset. 2639 2640proc with_target_charset { target_charset body } { 2641 global gdb_prompt 2642 2643 set saved "" 2644 gdb_test_multiple "show target-charset" "" { 2645 -re "The target character set is \".*; currently (.*)\"\..*$gdb_prompt " { 2646 set saved $expect_out(1,string) 2647 } 2648 -re "The target character set is \"(.*)\".*$gdb_prompt " { 2649 set saved $expect_out(1,string) 2650 } 2651 -re ".*$gdb_prompt " { 2652 fail "get target-charset" 2653 } 2654 } 2655 2656 gdb_test_no_output "set target-charset $target_charset" "" 2657 2658 set code [catch {uplevel 1 $body} result] 2659 2660 gdb_test_no_output "set target-charset $saved" "" 2661 2662 if {$code == 1} { 2663 global errorInfo errorCode 2664 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2665 } else { 2666 return -code $code $result 2667 } 2668} 2669 2670# Switch the default spawn id to SPAWN_ID, so that gdb_test, 2671# mi_gdb_test etc. default to using it. 2672 2673proc switch_gdb_spawn_id {spawn_id} { 2674 global gdb_spawn_id 2675 global board board_info 2676 2677 set gdb_spawn_id $spawn_id 2678 set board [host_info name] 2679 set board_info($board,fileid) $spawn_id 2680} 2681 2682# Clear the default spawn id. 2683 2684proc clear_gdb_spawn_id {} { 2685 global gdb_spawn_id 2686 global board board_info 2687 2688 unset -nocomplain gdb_spawn_id 2689 set board [host_info name] 2690 unset -nocomplain board_info($board,fileid) 2691} 2692 2693# Run BODY with SPAWN_ID as current spawn id. 2694 2695proc with_spawn_id { spawn_id body } { 2696 global gdb_spawn_id 2697 2698 if [info exists gdb_spawn_id] { 2699 set saved_spawn_id $gdb_spawn_id 2700 } 2701 2702 switch_gdb_spawn_id $spawn_id 2703 2704 set code [catch {uplevel 1 $body} result] 2705 2706 if [info exists saved_spawn_id] { 2707 switch_gdb_spawn_id $saved_spawn_id 2708 } else { 2709 clear_gdb_spawn_id 2710 } 2711 2712 if {$code == 1} { 2713 global errorInfo errorCode 2714 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2715 } else { 2716 return -code $code $result 2717 } 2718} 2719 2720# Select the largest timeout from all the timeouts: 2721# - the local "timeout" variable of the scope two levels above, 2722# - the global "timeout" variable, 2723# - the board variable "gdb,timeout". 2724 2725proc get_largest_timeout {} { 2726 upvar #0 timeout gtimeout 2727 upvar 2 timeout timeout 2728 2729 set tmt 0 2730 if [info exists timeout] { 2731 set tmt $timeout 2732 } 2733 if { [info exists gtimeout] && $gtimeout > $tmt } { 2734 set tmt $gtimeout 2735 } 2736 if { [target_info exists gdb,timeout] 2737 && [target_info gdb,timeout] > $tmt } { 2738 set tmt [target_info gdb,timeout] 2739 } 2740 if { $tmt == 0 } { 2741 # Eeeeew. 2742 set tmt 60 2743 } 2744 2745 return $tmt 2746} 2747 2748# Run tests in BODY with timeout increased by factor of FACTOR. When 2749# BODY is finished, restore timeout. 2750 2751proc with_timeout_factor { factor body } { 2752 global timeout 2753 2754 set savedtimeout $timeout 2755 2756 set timeout [expr [get_largest_timeout] * $factor] 2757 set code [catch {uplevel 1 $body} result] 2758 2759 set timeout $savedtimeout 2760 if {$code == 1} { 2761 global errorInfo errorCode 2762 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 2763 } else { 2764 return -code $code $result 2765 } 2766} 2767 2768# Run BODY with timeout factor FACTOR if check-read1 is used. 2769 2770proc with_read1_timeout_factor { factor body } { 2771 if { [info exists ::env(READ1)] == 1 && $::env(READ1) == 1 } { 2772 # Use timeout factor 2773 } else { 2774 # Reset timeout factor 2775 set factor 1 2776 } 2777 return [uplevel [list with_timeout_factor $factor $body]] 2778} 2779 2780# Return 1 if _Complex types are supported, otherwise, return 0. 2781 2782gdb_caching_proc support_complex_tests { 2783 2784 if { [gdb_skip_float_test] } { 2785 # If floating point is not supported, _Complex is not 2786 # supported. 2787 return 0 2788 } 2789 2790 # Compile a test program containing _Complex types. 2791 2792 return [gdb_can_simple_compile complex { 2793 int main() { 2794 _Complex float cf; 2795 _Complex double cd; 2796 _Complex long double cld; 2797 return 0; 2798 } 2799 } executable] 2800} 2801 2802# Return 1 if compiling go is supported. 2803gdb_caching_proc support_go_compile { 2804 2805 return [gdb_can_simple_compile go-hello { 2806 package main 2807 import "fmt" 2808 func main() { 2809 fmt.Println("hello world") 2810 } 2811 } executable go] 2812} 2813 2814# Return 1 if GDB can get a type for siginfo from the target, otherwise 2815# return 0. 2816 2817proc supports_get_siginfo_type {} { 2818 if { [istarget "*-*-linux*"] } { 2819 return 1 2820 } else { 2821 return 0 2822 } 2823} 2824 2825# Return 1 if memory tagging is supported at runtime, otherwise return 0. 2826 2827gdb_caching_proc supports_memtag { 2828 global gdb_prompt 2829 2830 gdb_test_multiple "memory-tag check" "" { 2831 -re "Memory tagging not supported or disabled by the current architecture\..*$gdb_prompt $" { 2832 return 0 2833 } 2834 -re "Argument required \\(address or pointer\\).*$gdb_prompt $" { 2835 return 1 2836 } 2837 } 2838 return 0 2839} 2840 2841# Return 1 if the target supports hardware single stepping. 2842 2843proc can_hardware_single_step {} { 2844 2845 if { [istarget "arm*-*-*"] || [istarget "mips*-*-*"] 2846 || [istarget "tic6x-*-*"] || [istarget "sparc*-*-linux*"] 2847 || [istarget "nios2-*-*"] } { 2848 return 0 2849 } 2850 2851 return 1 2852} 2853 2854# Return 1 if target hardware or OS supports single stepping to signal 2855# handler, otherwise, return 0. 2856 2857proc can_single_step_to_signal_handler {} { 2858 # Targets don't have hardware single step. On these targets, when 2859 # a signal is delivered during software single step, gdb is unable 2860 # to determine the next instruction addresses, because start of signal 2861 # handler is one of them. 2862 return [can_hardware_single_step] 2863} 2864 2865# Return 1 if target supports process record, otherwise return 0. 2866 2867proc supports_process_record {} { 2868 2869 if [target_info exists gdb,use_precord] { 2870 return [target_info gdb,use_precord] 2871 } 2872 2873 if { [istarget "arm*-*-linux*"] || [istarget "x86_64-*-linux*"] 2874 || [istarget "i\[34567\]86-*-linux*"] 2875 || [istarget "aarch64*-*-linux*"] 2876 || [istarget "powerpc*-*-linux*"] 2877 || [istarget "s390*-*-linux*"] } { 2878 return 1 2879 } 2880 2881 return 0 2882} 2883 2884# Return 1 if target supports reverse debugging, otherwise return 0. 2885 2886proc supports_reverse {} { 2887 2888 if [target_info exists gdb,can_reverse] { 2889 return [target_info gdb,can_reverse] 2890 } 2891 2892 if { [istarget "arm*-*-linux*"] || [istarget "x86_64-*-linux*"] 2893 || [istarget "i\[34567\]86-*-linux*"] 2894 || [istarget "aarch64*-*-linux*"] 2895 || [istarget "powerpc*-*-linux*"] 2896 || [istarget "s390*-*-linux*"] } { 2897 return 1 2898 } 2899 2900 return 0 2901} 2902 2903# Return 1 if readline library is used. 2904 2905proc readline_is_used { } { 2906 global gdb_prompt 2907 2908 gdb_test_multiple "show editing" "" { 2909 -re ".*Editing of command lines as they are typed is on\..*$gdb_prompt $" { 2910 return 1 2911 } 2912 -re ".*$gdb_prompt $" { 2913 return 0 2914 } 2915 } 2916} 2917 2918# Return 1 if target is ELF. 2919gdb_caching_proc is_elf_target { 2920 set me "is_elf_target" 2921 2922 set src { int foo () {return 0;} } 2923 if {![gdb_simple_compile elf_target $src]} { 2924 return 0 2925 } 2926 2927 set fp_obj [open $obj "r"] 2928 fconfigure $fp_obj -translation binary 2929 set data [read $fp_obj] 2930 close $fp_obj 2931 2932 file delete $obj 2933 2934 set ELFMAG "\u007FELF" 2935 2936 if {[string compare -length 4 $data $ELFMAG] != 0} { 2937 verbose "$me: returning 0" 2 2938 return 0 2939 } 2940 2941 verbose "$me: returning 1" 2 2942 return 1 2943} 2944 2945# Return 1 if the memory at address zero is readable. 2946 2947gdb_caching_proc is_address_zero_readable { 2948 global gdb_prompt 2949 2950 set ret 0 2951 gdb_test_multiple "x 0" "" { 2952 -re "Cannot access memory at address 0x0.*$gdb_prompt $" { 2953 set ret 0 2954 } 2955 -re ".*$gdb_prompt $" { 2956 set ret 1 2957 } 2958 } 2959 2960 return $ret 2961} 2962 2963# Produce source file NAME and write SOURCES into it. 2964 2965proc gdb_produce_source { name sources } { 2966 set index 0 2967 set f [open $name "w"] 2968 2969 puts $f $sources 2970 close $f 2971} 2972 2973# Return 1 if target is ILP32. 2974# This cannot be decided simply from looking at the target string, 2975# as it might depend on externally passed compiler options like -m64. 2976gdb_caching_proc is_ilp32_target { 2977 return [gdb_can_simple_compile is_ilp32_target { 2978 int dummy[sizeof (int) == 4 2979 && sizeof (void *) == 4 2980 && sizeof (long) == 4 ? 1 : -1]; 2981 }] 2982} 2983 2984# Return 1 if target is LP64. 2985# This cannot be decided simply from looking at the target string, 2986# as it might depend on externally passed compiler options like -m64. 2987gdb_caching_proc is_lp64_target { 2988 return [gdb_can_simple_compile is_lp64_target { 2989 int dummy[sizeof (int) == 4 2990 && sizeof (void *) == 8 2991 && sizeof (long) == 8 ? 1 : -1]; 2992 }] 2993} 2994 2995# Return 1 if target has 64 bit addresses. 2996# This cannot be decided simply from looking at the target string, 2997# as it might depend on externally passed compiler options like -m64. 2998gdb_caching_proc is_64_target { 2999 return [gdb_can_simple_compile is_64_target { 3000 int function(void) { return 3; } 3001 int dummy[sizeof (&function) == 8 ? 1 : -1]; 3002 }] 3003} 3004 3005# Return 1 if target has x86_64 registers - either amd64 or x32. 3006# x32 target identifies as x86_64-*-linux*, therefore it cannot be determined 3007# just from the target string. 3008gdb_caching_proc is_amd64_regs_target { 3009 if {![istarget "x86_64-*-*"] && ![istarget "i?86-*"]} { 3010 return 0 3011 } 3012 3013 return [gdb_can_simple_compile is_amd64_regs_target { 3014 int main (void) { 3015 asm ("incq %rax"); 3016 asm ("incq %r15"); 3017 3018 return 0; 3019 } 3020 }] 3021} 3022 3023# Return 1 if this target is an x86 or x86-64 with -m32. 3024proc is_x86_like_target {} { 3025 if {![istarget "x86_64-*-*"] && ![istarget i?86-*]} { 3026 return 0 3027 } 3028 return [expr [is_ilp32_target] && ![is_amd64_regs_target]] 3029} 3030 3031# Return 1 if this target is an arm or aarch32 on aarch64. 3032 3033gdb_caching_proc is_aarch32_target { 3034 if { [istarget "arm*-*-*"] } { 3035 return 1 3036 } 3037 3038 if { ![istarget "aarch64*-*-*"] } { 3039 return 0 3040 } 3041 3042 set list {} 3043 foreach reg \ 3044 {r0 r1 r2 r3} { 3045 lappend list "\tmov $reg, $reg" 3046 } 3047 3048 return [gdb_can_simple_compile aarch32 [join $list \n]] 3049} 3050 3051# Return 1 if this target is an aarch64, either lp64 or ilp32. 3052 3053proc is_aarch64_target {} { 3054 if { ![istarget "aarch64*-*-*"] } { 3055 return 0 3056 } 3057 3058 return [expr ![is_aarch32_target]] 3059} 3060 3061# Return 1 if displaced stepping is supported on target, otherwise, return 0. 3062proc support_displaced_stepping {} { 3063 3064 if { [istarget "x86_64-*-linux*"] || [istarget "i\[34567\]86-*-linux*"] 3065 || [istarget "arm*-*-linux*"] || [istarget "powerpc-*-linux*"] 3066 || [istarget "powerpc64-*-linux*"] || [istarget "s390*-*-*"] 3067 || [istarget "aarch64*-*-linux*"] } { 3068 return 1 3069 } 3070 3071 return 0 3072} 3073 3074# Run a test on the target to see if it supports vmx hardware. Return 0 if so, 3075# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 3076 3077gdb_caching_proc skip_altivec_tests { 3078 global srcdir subdir gdb_prompt inferior_exited_re 3079 3080 set me "skip_altivec_tests" 3081 3082 # Some simulators are known to not support VMX instructions. 3083 if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } { 3084 verbose "$me: target known to not support VMX, returning 1" 2 3085 return 1 3086 } 3087 3088 # Make sure we have a compiler that understands altivec. 3089 if [get_compiler_info] { 3090 warning "Could not get compiler info" 3091 return 1 3092 } 3093 if [test_compiler_info gcc*] { 3094 set compile_flags "additional_flags=-maltivec" 3095 } elseif [test_compiler_info xlc*] { 3096 set compile_flags "additional_flags=-qaltivec" 3097 } else { 3098 verbose "Could not compile with altivec support, returning 1" 2 3099 return 1 3100 } 3101 3102 # Compile a test program containing VMX instructions. 3103 set src { 3104 int main() { 3105 #ifdef __MACH__ 3106 asm volatile ("vor v0,v0,v0"); 3107 #else 3108 asm volatile ("vor 0,0,0"); 3109 #endif 3110 return 0; 3111 } 3112 } 3113 if {![gdb_simple_compile $me $src executable $compile_flags]} { 3114 return 1 3115 } 3116 3117 # Compilation succeeded so now run it via gdb. 3118 3119 gdb_exit 3120 gdb_start 3121 gdb_reinitialize_dir $srcdir/$subdir 3122 gdb_load "$obj" 3123 gdb_run_cmd 3124 gdb_expect { 3125 -re ".*Illegal instruction.*${gdb_prompt} $" { 3126 verbose -log "\n$me altivec hardware not detected" 3127 set skip_vmx_tests 1 3128 } 3129 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3130 verbose -log "\n$me: altivec hardware detected" 3131 set skip_vmx_tests 0 3132 } 3133 default { 3134 warning "\n$me: default case taken" 3135 set skip_vmx_tests 1 3136 } 3137 } 3138 gdb_exit 3139 remote_file build delete $obj 3140 3141 verbose "$me: returning $skip_vmx_tests" 2 3142 return $skip_vmx_tests 3143} 3144 3145# Run a test on the power target to see if it supports ISA 3.1 instructions 3146gdb_caching_proc skip_power_isa_3_1_tests { 3147 global srcdir subdir gdb_prompt inferior_exited_re 3148 3149 set me "skip_power_isa_3_1_tests" 3150 3151 # Compile a test program containing ISA 3.1 instructions. 3152 set src { 3153 int main() { 3154 asm volatile ("pnop"); // marker 3155 asm volatile ("nop"); 3156 return 0; 3157 } 3158 } 3159 3160 if {![gdb_simple_compile $me $src executable ]} { 3161 return 1 3162 } 3163 3164 # No error message, compilation succeeded so now run it via gdb. 3165 3166 gdb_exit 3167 gdb_start 3168 gdb_reinitialize_dir $srcdir/$subdir 3169 gdb_load "$obj" 3170 gdb_run_cmd 3171 gdb_expect { 3172 -re ".*Illegal instruction.*${gdb_prompt} $" { 3173 verbose -log "\n$me Power ISA 3.1 hardware not detected" 3174 set skip_power_isa_3_1_tests 1 3175 } 3176 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3177 verbose -log "\n$me: Power ISA 3.1 hardware detected" 3178 set skip_power_isa_3_1_tests 0 3179 } 3180 default { 3181 warning "\n$me: default case taken" 3182 set skip_power_isa_3_1_tests 1 3183 } 3184 } 3185 gdb_exit 3186 remote_file build delete $obj 3187 3188 verbose "$me: returning $skip_power_isa_3_1_tests" 2 3189 return $skip_power_isa_3_1_tests 3190} 3191 3192# Run a test on the target to see if it supports vmx hardware. Return 0 if so, 3193# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 3194 3195gdb_caching_proc skip_vsx_tests { 3196 global srcdir subdir gdb_prompt inferior_exited_re 3197 3198 set me "skip_vsx_tests" 3199 3200 # Some simulators are known to not support Altivec instructions, so 3201 # they won't support VSX instructions as well. 3202 if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } { 3203 verbose "$me: target known to not support VSX, returning 1" 2 3204 return 1 3205 } 3206 3207 # Make sure we have a compiler that understands altivec. 3208 if [get_compiler_info] { 3209 warning "Could not get compiler info" 3210 return 1 3211 } 3212 if [test_compiler_info gcc*] { 3213 set compile_flags "additional_flags=-mvsx" 3214 } elseif [test_compiler_info xlc*] { 3215 set compile_flags "additional_flags=-qasm=gcc" 3216 } else { 3217 verbose "Could not compile with vsx support, returning 1" 2 3218 return 1 3219 } 3220 3221 # Compile a test program containing VSX instructions. 3222 set src { 3223 int main() { 3224 double a[2] = { 1.0, 2.0 }; 3225 #ifdef __MACH__ 3226 asm volatile ("lxvd2x v0,v0,%[addr]" : : [addr] "r" (a)); 3227 #else 3228 asm volatile ("lxvd2x 0,0,%[addr]" : : [addr] "r" (a)); 3229 #endif 3230 return 0; 3231 } 3232 } 3233 if {![gdb_simple_compile $me $src executable $compile_flags]} { 3234 return 1 3235 } 3236 3237 # No error message, compilation succeeded so now run it via gdb. 3238 3239 gdb_exit 3240 gdb_start 3241 gdb_reinitialize_dir $srcdir/$subdir 3242 gdb_load "$obj" 3243 gdb_run_cmd 3244 gdb_expect { 3245 -re ".*Illegal instruction.*${gdb_prompt} $" { 3246 verbose -log "\n$me VSX hardware not detected" 3247 set skip_vsx_tests 1 3248 } 3249 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3250 verbose -log "\n$me: VSX hardware detected" 3251 set skip_vsx_tests 0 3252 } 3253 default { 3254 warning "\n$me: default case taken" 3255 set skip_vsx_tests 1 3256 } 3257 } 3258 gdb_exit 3259 remote_file build delete $obj 3260 3261 verbose "$me: returning $skip_vsx_tests" 2 3262 return $skip_vsx_tests 3263} 3264 3265# Run a test on the target to see if it supports TSX hardware. Return 0 if so, 3266# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 3267 3268gdb_caching_proc skip_tsx_tests { 3269 global srcdir subdir gdb_prompt inferior_exited_re 3270 3271 set me "skip_tsx_tests" 3272 3273 # Compile a test program. 3274 set src { 3275 int main() { 3276 asm volatile ("xbegin .L0"); 3277 asm volatile ("xend"); 3278 asm volatile (".L0: nop"); 3279 return 0; 3280 } 3281 } 3282 if {![gdb_simple_compile $me $src executable]} { 3283 return 1 3284 } 3285 3286 # No error message, compilation succeeded so now run it via gdb. 3287 3288 gdb_exit 3289 gdb_start 3290 gdb_reinitialize_dir $srcdir/$subdir 3291 gdb_load "$obj" 3292 gdb_run_cmd 3293 gdb_expect { 3294 -re ".*Illegal instruction.*${gdb_prompt} $" { 3295 verbose -log "$me: TSX hardware not detected." 3296 set skip_tsx_tests 1 3297 } 3298 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3299 verbose -log "$me: TSX hardware detected." 3300 set skip_tsx_tests 0 3301 } 3302 default { 3303 warning "\n$me: default case taken." 3304 set skip_tsx_tests 1 3305 } 3306 } 3307 gdb_exit 3308 remote_file build delete $obj 3309 3310 verbose "$me: returning $skip_tsx_tests" 2 3311 return $skip_tsx_tests 3312} 3313 3314# Run a test on the target to see if it supports avx512bf16. Return 0 if so, 3315# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 3316 3317gdb_caching_proc skip_avx512bf16_tests { 3318 global srcdir subdir gdb_prompt inferior_exited_re 3319 3320 set me "skip_avx512bf16_tests" 3321 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 3322 verbose "$me: target does not support avx512bf16, returning 1" 2 3323 return 1 3324 } 3325 3326 # Compile a test program. 3327 set src { 3328 int main() { 3329 asm volatile ("vcvtne2ps2bf16 %xmm0, %xmm1, %xmm0"); 3330 return 0; 3331 } 3332 } 3333 if {![gdb_simple_compile $me $src executable]} { 3334 return 1 3335 } 3336 3337 # No error message, compilation succeeded so now run it via gdb. 3338 3339 gdb_exit 3340 gdb_start 3341 gdb_reinitialize_dir $srcdir/$subdir 3342 gdb_load "$obj" 3343 gdb_run_cmd 3344 gdb_expect { 3345 -re ".*Illegal instruction.*${gdb_prompt} $" { 3346 verbose -log "$me: avx512bf16 hardware not detected." 3347 set skip_avx512bf16_tests 1 3348 } 3349 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3350 verbose -log "$me: avx512bf16 hardware detected." 3351 set skip_avx512bf16_tests 0 3352 } 3353 default { 3354 warning "\n$me: default case taken." 3355 set skip_avx512bf16_tests 1 3356 } 3357 } 3358 gdb_exit 3359 remote_file build delete $obj 3360 3361 verbose "$me: returning $skip_avx512bf16_tests" 2 3362 return $skip_avx512bf16_tests 3363} 3364 3365# Run a test on the target to see if it supports btrace hardware. Return 0 if so, 3366# 1 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. 3367 3368gdb_caching_proc skip_btrace_tests { 3369 global srcdir subdir gdb_prompt inferior_exited_re 3370 3371 set me "skip_btrace_tests" 3372 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 3373 verbose "$me: target does not support btrace, returning 1" 2 3374 return 1 3375 } 3376 3377 # Compile a test program. 3378 set src { int main() { return 0; } } 3379 if {![gdb_simple_compile $me $src executable]} { 3380 return 1 3381 } 3382 3383 # No error message, compilation succeeded so now run it via gdb. 3384 3385 gdb_exit 3386 gdb_start 3387 gdb_reinitialize_dir $srcdir/$subdir 3388 gdb_load $obj 3389 if ![runto_main] { 3390 return 1 3391 } 3392 # In case of an unexpected output, we return 2 as a fail value. 3393 set skip_btrace_tests 2 3394 gdb_test_multiple "record btrace" "check btrace support" { 3395 -re "You can't do that when your target is.*\r\n$gdb_prompt $" { 3396 set skip_btrace_tests 1 3397 } 3398 -re "Target does not support branch tracing.*\r\n$gdb_prompt $" { 3399 set skip_btrace_tests 1 3400 } 3401 -re "Could not enable branch tracing.*\r\n$gdb_prompt $" { 3402 set skip_btrace_tests 1 3403 } 3404 -re "^record btrace\r\n$gdb_prompt $" { 3405 set skip_btrace_tests 0 3406 } 3407 } 3408 gdb_exit 3409 remote_file build delete $obj 3410 3411 verbose "$me: returning $skip_btrace_tests" 2 3412 return $skip_btrace_tests 3413} 3414 3415# Run a test on the target to see if it supports btrace pt hardware. 3416# Return 0 if so, 1 if it does not. Based on 'check_vmx_hw_available' 3417# from the GCC testsuite. 3418 3419gdb_caching_proc skip_btrace_pt_tests { 3420 global srcdir subdir gdb_prompt inferior_exited_re 3421 3422 set me "skip_btrace_tests" 3423 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 3424 verbose "$me: target does not support btrace, returning 1" 2 3425 return 1 3426 } 3427 3428 # Compile a test program. 3429 set src { int main() { return 0; } } 3430 if {![gdb_simple_compile $me $src executable]} { 3431 return 1 3432 } 3433 3434 # No error message, compilation succeeded so now run it via gdb. 3435 3436 gdb_exit 3437 gdb_start 3438 gdb_reinitialize_dir $srcdir/$subdir 3439 gdb_load $obj 3440 if ![runto_main] { 3441 return 1 3442 } 3443 # In case of an unexpected output, we return 2 as a fail value. 3444 set skip_btrace_tests 2 3445 gdb_test_multiple "record btrace pt" "check btrace pt support" { 3446 -re "You can't do that when your target is.*\r\n$gdb_prompt $" { 3447 set skip_btrace_tests 1 3448 } 3449 -re "Target does not support branch tracing.*\r\n$gdb_prompt $" { 3450 set skip_btrace_tests 1 3451 } 3452 -re "Could not enable branch tracing.*\r\n$gdb_prompt $" { 3453 set skip_btrace_tests 1 3454 } 3455 -re "support was disabled at compile time.*\r\n$gdb_prompt $" { 3456 set skip_btrace_tests 1 3457 } 3458 -re "^record btrace pt\r\n$gdb_prompt $" { 3459 set skip_btrace_tests 0 3460 } 3461 } 3462 gdb_exit 3463 remote_file build delete $obj 3464 3465 verbose "$me: returning $skip_btrace_tests" 2 3466 return $skip_btrace_tests 3467} 3468 3469# Run a test on the target to see if it supports Aarch64 SVE hardware. 3470# Return 0 if so, 1 if it does not. Note this causes a restart of GDB. 3471 3472gdb_caching_proc skip_aarch64_sve_tests { 3473 global srcdir subdir gdb_prompt inferior_exited_re 3474 3475 set me "skip_aarch64_sve_tests" 3476 3477 if { ![is_aarch64_target]} { 3478 return 1 3479 } 3480 3481 set compile_flags "{additional_flags=-march=armv8-a+sve}" 3482 3483 # Compile a test program containing SVE instructions. 3484 set src { 3485 int main() { 3486 asm volatile ("ptrue p0.b"); 3487 return 0; 3488 } 3489 } 3490 if {![gdb_simple_compile $me $src executable $compile_flags]} { 3491 return 1 3492 } 3493 3494 # Compilation succeeded so now run it via gdb. 3495 clean_restart $obj 3496 gdb_run_cmd 3497 gdb_expect { 3498 -re ".*Illegal instruction.*${gdb_prompt} $" { 3499 verbose -log "\n$me sve hardware not detected" 3500 set skip_sve_tests 1 3501 } 3502 -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { 3503 verbose -log "\n$me: sve hardware detected" 3504 set skip_sve_tests 0 3505 } 3506 default { 3507 warning "\n$me: default case taken" 3508 set skip_sve_tests 1 3509 } 3510 } 3511 gdb_exit 3512 remote_file build delete $obj 3513 3514 verbose "$me: returning $skip_sve_tests" 2 3515 return $skip_sve_tests 3516} 3517 3518 3519# A helper that compiles a test case to see if __int128 is supported. 3520proc gdb_int128_helper {lang} { 3521 return [gdb_can_simple_compile "i128-for-$lang" { 3522 __int128 x; 3523 int main() { return 0; } 3524 } executable $lang] 3525} 3526 3527# Return true if the C compiler understands the __int128 type. 3528gdb_caching_proc has_int128_c { 3529 return [gdb_int128_helper c] 3530} 3531 3532# Return true if the C++ compiler understands the __int128 type. 3533gdb_caching_proc has_int128_cxx { 3534 return [gdb_int128_helper c++] 3535} 3536 3537# Return true if the IFUNC feature is unsupported. 3538gdb_caching_proc skip_ifunc_tests { 3539 if [gdb_can_simple_compile ifunc { 3540 extern void f_ (); 3541 typedef void F (void); 3542 F* g (void) { return &f_; } 3543 void f () __attribute__ ((ifunc ("g"))); 3544 } object] { 3545 return 0 3546 } else { 3547 return 1 3548 } 3549} 3550 3551# Return whether we should skip tests for showing inlined functions in 3552# backtraces. Requires get_compiler_info and get_debug_format. 3553 3554proc skip_inline_frame_tests {} { 3555 # GDB only recognizes inlining information in DWARF 2 (DWARF 3). 3556 if { ! [test_debug_format "DWARF 2"] } { 3557 return 1 3558 } 3559 3560 # GCC before 4.1 does not emit DW_AT_call_file / DW_AT_call_line. 3561 if { ([test_compiler_info "gcc-2-*"] 3562 || [test_compiler_info "gcc-3-*"] 3563 || [test_compiler_info "gcc-4-0-*"]) } { 3564 return 1 3565 } 3566 3567 return 0 3568} 3569 3570# Return whether we should skip tests for showing variables from 3571# inlined functions. Requires get_compiler_info and get_debug_format. 3572 3573proc skip_inline_var_tests {} { 3574 # GDB only recognizes inlining information in DWARF 2 (DWARF 3). 3575 if { ! [test_debug_format "DWARF 2"] } { 3576 return 1 3577 } 3578 3579 return 0 3580} 3581 3582# Return a 1 if we should skip tests that require hardware breakpoints 3583 3584proc skip_hw_breakpoint_tests {} { 3585 # Skip tests if requested by the board (note that no_hardware_watchpoints 3586 # disables both watchpoints and breakpoints) 3587 if { [target_info exists gdb,no_hardware_watchpoints]} { 3588 return 1 3589 } 3590 3591 # These targets support hardware breakpoints natively 3592 if { [istarget "i?86-*-*"] 3593 || [istarget "x86_64-*-*"] 3594 || [istarget "ia64-*-*"] 3595 || [istarget "arm*-*-*"] 3596 || [istarget "aarch64*-*-*"] 3597 || [istarget "s390*-*-*"] } { 3598 return 0 3599 } 3600 3601 return 1 3602} 3603 3604# Return a 1 if we should skip tests that require hardware watchpoints 3605 3606proc skip_hw_watchpoint_tests {} { 3607 # Skip tests if requested by the board 3608 if { [target_info exists gdb,no_hardware_watchpoints]} { 3609 return 1 3610 } 3611 3612 # These targets support hardware watchpoints natively 3613 if { [istarget "i?86-*-*"] 3614 || [istarget "x86_64-*-*"] 3615 || [istarget "ia64-*-*"] 3616 || [istarget "arm*-*-*"] 3617 || [istarget "aarch64*-*-*"] 3618 || [istarget "powerpc*-*-linux*"] 3619 || [istarget "s390*-*-*"] } { 3620 return 0 3621 } 3622 3623 return 1 3624} 3625 3626# Return a 1 if we should skip tests that require *multiple* hardware 3627# watchpoints to be active at the same time 3628 3629proc skip_hw_watchpoint_multi_tests {} { 3630 if { [skip_hw_watchpoint_tests] } { 3631 return 1 3632 } 3633 3634 # These targets support just a single hardware watchpoint 3635 if { [istarget "arm*-*-*"] 3636 || [istarget "powerpc*-*-linux*"] } { 3637 return 1 3638 } 3639 3640 return 0 3641} 3642 3643# Return a 1 if we should skip tests that require read/access watchpoints 3644 3645proc skip_hw_watchpoint_access_tests {} { 3646 if { [skip_hw_watchpoint_tests] } { 3647 return 1 3648 } 3649 3650 # These targets support just write watchpoints 3651 if { [istarget "s390*-*-*"] } { 3652 return 1 3653 } 3654 3655 return 0 3656} 3657 3658# Return 1 if we should skip tests that require the runtime unwinder 3659# hook. This must be invoked while gdb is running, after shared 3660# libraries have been loaded. This is needed because otherwise a 3661# shared libgcc won't be visible. 3662 3663proc skip_unwinder_tests {} { 3664 global gdb_prompt 3665 3666 set ok 0 3667 gdb_test_multiple "print _Unwind_DebugHook" "check for unwinder hook" { 3668 -re "= .*no debug info.*_Unwind_DebugHook.*\r\n$gdb_prompt $" { 3669 } 3670 -re "= .*_Unwind_DebugHook.*\r\n$gdb_prompt $" { 3671 set ok 1 3672 } 3673 -re "No symbol .* in current context.\r\n$gdb_prompt $" { 3674 } 3675 } 3676 if {!$ok} { 3677 gdb_test_multiple "info probe" "check for stap probe in unwinder" { 3678 -re ".*libgcc.*unwind.*\r\n$gdb_prompt $" { 3679 set ok 1 3680 } 3681 -re "\r\n$gdb_prompt $" { 3682 } 3683 } 3684 } 3685 return $ok 3686} 3687 3688# Return 1 if we should skip tests that require the libstdc++ stap 3689# probes. This must be invoked while gdb is running, after shared 3690# libraries have been loaded. PROMPT_REGEXP is the expected prompt. 3691 3692proc skip_libstdcxx_probe_tests_prompt { prompt_regexp } { 3693 set supported 0 3694 gdb_test_multiple "info probe" "check for stap probe in libstdc++" \ 3695 -prompt "$prompt_regexp" { 3696 -re ".*libstdcxx.*catch.*\r\n$prompt_regexp" { 3697 set supported 1 3698 } 3699 -re "\r\n$prompt_regexp" { 3700 } 3701 } 3702 set skip [expr !$supported] 3703 return $skip 3704} 3705 3706# As skip_libstdcxx_probe_tests_prompt, with gdb_prompt. 3707 3708proc skip_libstdcxx_probe_tests {} { 3709 global gdb_prompt 3710 return [skip_libstdcxx_probe_tests_prompt "$gdb_prompt $"] 3711} 3712 3713# Return 1 if we should skip tests of the "compile" feature. 3714# This must be invoked after the inferior has been started. 3715 3716proc skip_compile_feature_tests {} { 3717 global gdb_prompt 3718 3719 set result 0 3720 gdb_test_multiple "compile code -- ;" "check for working compile command" { 3721 "Could not load libcc1.*\r\n$gdb_prompt $" { 3722 set result 1 3723 } 3724 -re "Command not supported on this host\\..*\r\n$gdb_prompt $" { 3725 set result 1 3726 } 3727 -re "\r\n$gdb_prompt $" { 3728 } 3729 } 3730 return $result 3731} 3732 3733# Helper for gdb_is_target_* procs. TARGET_NAME is the name of the target 3734# we're looking for (used to build the test name). TARGET_STACK_REGEXP 3735# is a regexp that will match the output of "maint print target-stack" if 3736# the target in question is currently pushed. PROMPT_REGEXP is a regexp 3737# matching the expected prompt after the command output. 3738 3739proc gdb_is_target_1 { target_name target_stack_regexp prompt_regexp } { 3740 set test "probe for target ${target_name}" 3741 gdb_test_multiple "maint print target-stack" $test \ 3742 -prompt "$prompt_regexp" { 3743 -re "${target_stack_regexp}${prompt_regexp}" { 3744 pass $test 3745 return 1 3746 } 3747 -re "$prompt_regexp" { 3748 pass $test 3749 } 3750 } 3751 return 0 3752} 3753 3754# Helper for gdb_is_target_remote where the expected prompt is variable. 3755 3756proc gdb_is_target_remote_prompt { prompt_regexp } { 3757 return [gdb_is_target_1 "remote" ".*emote serial target in gdb-specific protocol.*" $prompt_regexp] 3758} 3759 3760# Check whether we're testing with the remote or extended-remote 3761# targets. 3762 3763proc gdb_is_target_remote { } { 3764 global gdb_prompt 3765 3766 return [gdb_is_target_remote_prompt "$gdb_prompt $"] 3767} 3768 3769# Check whether we're testing with the native target. 3770 3771proc gdb_is_target_native { } { 3772 global gdb_prompt 3773 3774 return [gdb_is_target_1 "native" ".*native \\(Native process\\).*" "$gdb_prompt $"] 3775} 3776 3777# Return the effective value of use_gdb_stub. 3778# 3779# If the use_gdb_stub global has been set (it is set when the gdb process is 3780# spawned), return that. Otherwise, return the value of the use_gdb_stub 3781# property from the board file. 3782# 3783# This is the preferred way of checking use_gdb_stub, since it allows to check 3784# the value before the gdb has been spawned and it will return the correct value 3785# even when it was overriden by the test. 3786# 3787# Note that stub targets are not able to spawn new inferiors. Use this 3788# check for skipping respective tests. 3789 3790proc use_gdb_stub {} { 3791 global use_gdb_stub 3792 3793 if [info exists use_gdb_stub] { 3794 return $use_gdb_stub 3795 } 3796 3797 return [target_info exists use_gdb_stub] 3798} 3799 3800# Return 1 if the current remote target is an instance of our GDBserver, 0 3801# otherwise. Return -1 if there was an error and we can't tell. 3802 3803gdb_caching_proc target_is_gdbserver { 3804 global gdb_prompt 3805 3806 set is_gdbserver -1 3807 set test "probing for GDBserver" 3808 3809 gdb_test_multiple "monitor help" $test { 3810 -re "The following monitor commands are supported.*Quit GDBserver.*$gdb_prompt $" { 3811 set is_gdbserver 1 3812 } 3813 -re "$gdb_prompt $" { 3814 set is_gdbserver 0 3815 } 3816 } 3817 3818 if { $is_gdbserver == -1 } { 3819 verbose -log "Unable to tell whether we are using GDBserver or not." 3820 } 3821 3822 return $is_gdbserver 3823} 3824 3825# N.B. compiler_info is intended to be local to this file. 3826# Call test_compiler_info with no arguments to fetch its value. 3827# Yes, this is counterintuitive when there's get_compiler_info, 3828# but that's the current API. 3829if [info exists compiler_info] { 3830 unset compiler_info 3831} 3832 3833set gcc_compiled 0 3834 3835# Figure out what compiler I am using. 3836# The result is cached so only the first invocation runs the compiler. 3837# 3838# ARG can be empty or "C++". If empty, "C" is assumed. 3839# 3840# There are several ways to do this, with various problems. 3841# 3842# [ gdb_compile -E $ifile -o $binfile.ci ] 3843# source $binfile.ci 3844# 3845# Single Unix Spec v3 says that "-E -o ..." together are not 3846# specified. And in fact, the native compiler on hp-ux 11 (among 3847# others) does not work with "-E -o ...". Most targets used to do 3848# this, and it mostly worked, because it works with gcc. 3849# 3850# [ catch "exec $compiler -E $ifile > $binfile.ci" exec_output ] 3851# source $binfile.ci 3852# 3853# This avoids the problem with -E and -o together. This almost works 3854# if the build machine is the same as the host machine, which is 3855# usually true of the targets which are not gcc. But this code does 3856# not figure which compiler to call, and it always ends up using the C 3857# compiler. Not good for setting hp_aCC_compiler. Target 3858# hppa*-*-hpux* used to do this. 3859# 3860# [ gdb_compile -E $ifile > $binfile.ci ] 3861# source $binfile.ci 3862# 3863# dejagnu target_compile says that it supports output redirection, 3864# but the code is completely different from the normal path and I 3865# don't want to sweep the mines from that path. So I didn't even try 3866# this. 3867# 3868# set cppout [ gdb_compile $ifile "" preprocess $args quiet ] 3869# eval $cppout 3870# 3871# I actually do this for all targets now. gdb_compile runs the right 3872# compiler, and TCL captures the output, and I eval the output. 3873# 3874# Unfortunately, expect logs the output of the command as it goes by, 3875# and dejagnu helpfully prints a second copy of it right afterwards. 3876# So I turn off expect logging for a moment. 3877# 3878# [ gdb_compile $ifile $ciexe_file executable $args ] 3879# [ remote_exec $ciexe_file ] 3880# [ source $ci_file.out ] 3881# 3882# I could give up on -E and just do this. 3883# I didn't get desperate enough to try this. 3884# 3885# -- chastain 2004-01-06 3886 3887proc get_compiler_info {{arg ""}} { 3888 # For compiler.c and compiler.cc 3889 global srcdir 3890 3891 # I am going to play with the log to keep noise out. 3892 global outdir 3893 global tool 3894 3895 # These come from compiler.c or compiler.cc 3896 global compiler_info 3897 3898 # Legacy global data symbols. 3899 global gcc_compiled 3900 3901 if [info exists compiler_info] { 3902 # Already computed. 3903 return 0 3904 } 3905 3906 # Choose which file to preprocess. 3907 set ifile "${srcdir}/lib/compiler.c" 3908 if { $arg == "c++" } { 3909 set ifile "${srcdir}/lib/compiler.cc" 3910 } 3911 3912 # Run $ifile through the right preprocessor. 3913 # Toggle gdb.log to keep the compiler output out of the log. 3914 set saved_log [log_file -info] 3915 log_file 3916 if [is_remote host] { 3917 # We have to use -E and -o together, despite the comments 3918 # above, because of how DejaGnu handles remote host testing. 3919 set ppout "$outdir/compiler.i" 3920 gdb_compile "${ifile}" "$ppout" preprocess [list "$arg" quiet getting_compiler_info] 3921 set file [open $ppout r] 3922 set cppout [read $file] 3923 close $file 3924 } else { 3925 set cppout [ gdb_compile "${ifile}" "" preprocess [list "$arg" quiet getting_compiler_info] ] 3926 } 3927 eval log_file $saved_log 3928 3929 # Eval the output. 3930 set unknown 0 3931 foreach cppline [ split "$cppout" "\n" ] { 3932 if { [ regexp "^#" "$cppline" ] } { 3933 # line marker 3934 } elseif { [ regexp "^\[\n\r\t \]*$" "$cppline" ] } { 3935 # blank line 3936 } elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } { 3937 # eval this line 3938 verbose "get_compiler_info: $cppline" 2 3939 eval "$cppline" 3940 } else { 3941 # unknown line 3942 verbose -log "get_compiler_info: $cppline" 3943 set unknown 1 3944 } 3945 } 3946 3947 # Set to unknown if for some reason compiler_info didn't get defined. 3948 if ![info exists compiler_info] { 3949 verbose -log "get_compiler_info: compiler_info not provided" 3950 set compiler_info "unknown" 3951 } 3952 # Also set to unknown compiler if any diagnostics happened. 3953 if { $unknown } { 3954 verbose -log "get_compiler_info: got unexpected diagnostics" 3955 set compiler_info "unknown" 3956 } 3957 3958 # Set the legacy symbols. 3959 set gcc_compiled 0 3960 regexp "^gcc-(\[0-9\]+)-" "$compiler_info" matchall gcc_compiled 3961 3962 # Log what happened. 3963 verbose -log "get_compiler_info: $compiler_info" 3964 3965 # Most compilers will evaluate comparisons and other boolean 3966 # operations to 0 or 1. 3967 uplevel \#0 { set true 1 } 3968 uplevel \#0 { set false 0 } 3969 3970 return 0 3971} 3972 3973# Return the compiler_info string if no arg is provided. 3974# Otherwise the argument is a glob-style expression to match against 3975# compiler_info. 3976 3977proc test_compiler_info { {compiler ""} } { 3978 global compiler_info 3979 get_compiler_info 3980 3981 # If no arg, return the compiler_info string. 3982 if [string match "" $compiler] { 3983 return $compiler_info 3984 } 3985 3986 return [string match $compiler $compiler_info] 3987} 3988 3989# Return the gcc major version, or -1. 3990# For gcc 4.8.5, the major version is 4.8. 3991# For gcc 7.5.0, the major version 7. 3992 3993proc gcc_major_version { } { 3994 global compiler_info 3995 global decimal 3996 if { ![test_compiler_info "gcc-*"] } { 3997 return -1 3998 } 3999 set res [regexp gcc-($decimal)-($decimal)- $compiler_info \ 4000 dummy_var major minor] 4001 if { $res != 1 } { 4002 return -1 4003 } 4004 if { $major >= 5} { 4005 return $major 4006 } 4007 return $major.$minor 4008} 4009 4010proc current_target_name { } { 4011 global target_info 4012 if [info exists target_info(target,name)] { 4013 set answer $target_info(target,name) 4014 } else { 4015 set answer "" 4016 } 4017 return $answer 4018} 4019 4020set gdb_wrapper_initialized 0 4021set gdb_wrapper_target "" 4022set gdb_wrapper_file "" 4023set gdb_wrapper_flags "" 4024 4025proc gdb_wrapper_init { args } { 4026 global gdb_wrapper_initialized 4027 global gdb_wrapper_file 4028 global gdb_wrapper_flags 4029 global gdb_wrapper_target 4030 4031 if { $gdb_wrapper_initialized == 1 } { return; } 4032 4033 if {[target_info exists needs_status_wrapper] && \ 4034 [target_info needs_status_wrapper] != "0"} { 4035 set result [build_wrapper "testglue.o"] 4036 if { $result != "" } { 4037 set gdb_wrapper_file [lindex $result 0] 4038 if ![is_remote host] { 4039 set gdb_wrapper_file [file join [pwd] $gdb_wrapper_file] 4040 } 4041 set gdb_wrapper_flags [lindex $result 1] 4042 } else { 4043 warning "Status wrapper failed to build." 4044 } 4045 } else { 4046 set gdb_wrapper_file "" 4047 set gdb_wrapper_flags "" 4048 } 4049 verbose "set gdb_wrapper_file = $gdb_wrapper_file" 4050 set gdb_wrapper_initialized 1 4051 set gdb_wrapper_target [current_target_name] 4052} 4053 4054# Determine options that we always want to pass to the compiler. 4055gdb_caching_proc universal_compile_options { 4056 set me "universal_compile_options" 4057 set options {} 4058 4059 set src [standard_temp_file ccopts[pid].c] 4060 set obj [standard_temp_file ccopts[pid].o] 4061 4062 gdb_produce_source $src { 4063 int foo(void) { return 0; } 4064 } 4065 4066 # Try an option for disabling colored diagnostics. Some compilers 4067 # yield colored diagnostics by default (when run from a tty) unless 4068 # such an option is specified. 4069 set opt "additional_flags=-fdiagnostics-color=never" 4070 set lines [target_compile $src $obj object [list "quiet" $opt]] 4071 if [string match "" $lines] then { 4072 # Seems to have worked; use the option. 4073 lappend options $opt 4074 } 4075 file delete $src 4076 file delete $obj 4077 4078 verbose "$me: returning $options" 2 4079 return $options 4080} 4081 4082# Compile the code in $code to a file based on $name, using the flags 4083# $compile_flag as well as debug, nowarning and quiet. 4084# Return 1 if code can be compiled 4085# Leave the file name of the resulting object in the upvar object. 4086 4087proc gdb_simple_compile {name code {type object} {compile_flags {}} {object obj}} { 4088 upvar $object obj 4089 4090 switch -regexp -- $type { 4091 "executable" { 4092 set postfix "x" 4093 } 4094 "object" { 4095 set postfix "o" 4096 } 4097 "preprocess" { 4098 set postfix "i" 4099 } 4100 "assembly" { 4101 set postfix "s" 4102 } 4103 } 4104 set ext "c" 4105 foreach flag $compile_flags { 4106 if { "$flag" == "go" } { 4107 set ext "go" 4108 break 4109 } 4110 } 4111 set src [standard_temp_file $name-[pid].$ext] 4112 set obj [standard_temp_file $name-[pid].$postfix] 4113 set compile_flags [concat $compile_flags {debug nowarnings quiet}] 4114 4115 gdb_produce_source $src $code 4116 4117 verbose "$name: compiling testfile $src" 2 4118 set lines [gdb_compile $src $obj $type $compile_flags] 4119 4120 file delete $src 4121 4122 if ![string match "" $lines] then { 4123 verbose "$name: compilation failed, returning 0" 2 4124 return 0 4125 } 4126 return 1 4127} 4128 4129# Compile the code in $code to a file based on $name, using the flags 4130# $compile_flag as well as debug, nowarning and quiet. 4131# Return 1 if code can be compiled 4132# Delete all created files and objects. 4133 4134proc gdb_can_simple_compile {name code {type object} {compile_flags ""}} { 4135 set ret [gdb_simple_compile $name $code $type $compile_flags temp_obj] 4136 file delete $temp_obj 4137 return $ret 4138} 4139 4140# Some targets need to always link a special object in. Save its path here. 4141global gdb_saved_set_unbuffered_mode_obj 4142set gdb_saved_set_unbuffered_mode_obj "" 4143 4144# Compile source files specified by SOURCE into a binary of type TYPE at path 4145# DEST. gdb_compile is implemented using DejaGnu's target_compile, so the type 4146# parameter and most options are passed directly to it. 4147# 4148# The type can be one of the following: 4149# 4150# - object: Compile into an object file. 4151# - executable: Compile and link into an executable. 4152# - preprocess: Preprocess the source files. 4153# - assembly: Generate assembly listing. 4154# 4155# The following options are understood and processed by gdb_compile: 4156# 4157# - shlib=so_path: Add SO_PATH to the sources, and enable some target-specific 4158# quirks to be able to use shared libraries. 4159# - shlib_load: Link with appropriate libraries to allow the test to 4160# dynamically load libraries at runtime. For example, on Linux, this adds 4161# -ldl so that the test can use dlopen. 4162# - nowarnings: Inhibit all compiler warnings. 4163# - pie: Force creation of PIE executables. 4164# - nopie: Prevent creation of PIE executables. 4165# 4166# And here are some of the not too obscure options understood by DejaGnu that 4167# influence the compilation: 4168# 4169# - additional_flags=flag: Add FLAG to the compiler flags. 4170# - libs=library: Add LIBRARY to the libraries passed to the linker. The 4171# argument can be a file, in which case it's added to the sources, or a 4172# linker flag. 4173# - ldflags=flag: Add FLAG to the linker flags. 4174# - incdir=path: Add PATH to the searched include directories. 4175# - libdir=path: Add PATH to the linker searched directories. 4176# - ada, c++, f77, f90, go, rust: Compile the file as Ada, C++, 4177# Fortran 77, Fortran 90, Go or Rust. 4178# - debug: Build with debug information. 4179# - optimize: Build with optimization. 4180 4181proc gdb_compile {source dest type options} { 4182 global GDB_TESTCASE_OPTIONS 4183 global gdb_wrapper_file 4184 global gdb_wrapper_flags 4185 global srcdir 4186 global objdir 4187 global gdb_saved_set_unbuffered_mode_obj 4188 4189 set outdir [file dirname $dest] 4190 4191 # Add platform-specific options if a shared library was specified using 4192 # "shlib=librarypath" in OPTIONS. 4193 set new_options {} 4194 if {[lsearch -exact $options rust] != -1} { 4195 # -fdiagnostics-color is not a rustcc option. 4196 } else { 4197 set new_options [universal_compile_options] 4198 } 4199 4200 # Some C/C++ testcases unconditionally pass -Wno-foo as additional 4201 # options to disable some warning. That is OK with GCC, because 4202 # by design, GCC accepts any -Wno-foo option, even if it doesn't 4203 # support -Wfoo. Clang however warns about unknown -Wno-foo by 4204 # default, unless you pass -Wno-unknown-warning-option as well. 4205 # We do that here, so that individual testcases don't have to 4206 # worry about it. 4207 if {[lsearch -exact $options getting_compiler_info] == -1 4208 && [lsearch -exact $options rust] == -1 4209 && [lsearch -exact $options ada] == -1 4210 && [lsearch -exact $options f77] == -1 4211 && [lsearch -exact $options f90] == -1 4212 && [lsearch -exact $options go] == -1 4213 && [test_compiler_info "clang-*"]} { 4214 lappend new_options "additional_flags=-Wno-unknown-warning-option" 4215 } 4216 4217 # Treating .c input files as C++ is deprecated in Clang, so 4218 # explicitly force C++ language. 4219 if { [lsearch -exact $options getting_compiler_info] == -1 4220 && [lsearch -exact $options c++] != -1 4221 && [string match *.c $source] != 0 } { 4222 4223 # gdb_compile cannot handle this combination of options, the 4224 # result is a command like "clang -x c++ foo.c bar.so -o baz" 4225 # which tells Clang to treat bar.so as C++. The solution is 4226 # to call gdb_compile twice--once to compile, once to link-- 4227 # either directly, or via build_executable_from_specs. 4228 if { [lsearch $options shlib=*] != -1 } { 4229 error "incompatible gdb_compile options" 4230 } 4231 4232 if {[test_compiler_info "clang-*"]} { 4233 lappend new_options early_flags=-x\ c++ 4234 } 4235 } 4236 4237 # Place (and look for) Fortran `.mod` files in the output 4238 # directory for this specific test. 4239 if {[lsearch -exact $options f77] != -1 \ 4240 || [lsearch -exact $options f90] != -1 } { 4241 # Fortran compile. 4242 set mod_path [standard_output_file ""] 4243 if [test_compiler_info "gcc-*"] { 4244 lappend new_options "additional_flags=-J${mod_path}" 4245 } 4246 } 4247 4248 set shlib_found 0 4249 set shlib_load 0 4250 set getting_compiler_info 0 4251 foreach opt $options { 4252 if {[regexp {^shlib=(.*)} $opt dummy_var shlib_name] 4253 && $type == "executable"} { 4254 if [test_compiler_info "xlc-*"] { 4255 # IBM xlc compiler doesn't accept shared library named other 4256 # than .so: use "-Wl," to bypass this 4257 lappend source "-Wl,$shlib_name" 4258 } elseif { ([istarget "*-*-mingw*"] 4259 || [istarget *-*-cygwin*] 4260 || [istarget *-*-pe*])} { 4261 lappend source "${shlib_name}.a" 4262 } else { 4263 lappend source $shlib_name 4264 } 4265 if { $shlib_found == 0 } { 4266 set shlib_found 1 4267 if { ([istarget "*-*-mingw*"] 4268 || [istarget *-*-cygwin*]) } { 4269 lappend new_options "additional_flags=-Wl,--enable-auto-import" 4270 } 4271 if { [test_compiler_info "gcc-*"] || [test_compiler_info "clang-*"] } { 4272 # Undo debian's change in the default. 4273 # Put it at the front to not override any user-provided 4274 # value, and to make sure it appears in front of all the 4275 # shlibs! 4276 lappend new_options "early_flags=-Wl,--no-as-needed" 4277 } 4278 } 4279 } elseif { $opt == "shlib_load" && $type == "executable" } { 4280 set shlib_load 1 4281 } elseif { $opt == "getting_compiler_info" } { 4282 # If this is set, calling test_compiler_info will cause recursion. 4283 set getting_compiler_info 1 4284 } else { 4285 lappend new_options $opt 4286 } 4287 } 4288 4289 # Ensure stack protector is disabled for GCC, as this causes problems with 4290 # DWARF line numbering. 4291 # See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88432 4292 # This option defaults to on for Debian/Ubuntu. 4293 if { $getting_compiler_info == 0 4294 && [test_compiler_info {gcc-*-*}] 4295 && !([test_compiler_info {gcc-[0-3]-*}] 4296 || [test_compiler_info {gcc-4-0-*}]) 4297 && [lsearch -exact $options rust] == -1} { 4298 # Put it at the front to not override any user-provided value. 4299 lappend new_options "early_flags=-fno-stack-protector" 4300 } 4301 4302 # Because we link with libraries using their basename, we may need 4303 # (depending on the platform) to set a special rpath value, to allow 4304 # the executable to find the libraries it depends on. 4305 if { $shlib_load || $shlib_found } { 4306 if { ([istarget "*-*-mingw*"] 4307 || [istarget *-*-cygwin*] 4308 || [istarget *-*-pe*]) } { 4309 # Do not need anything. 4310 } elseif { [istarget *-*-freebsd*] || [istarget *-*-openbsd*] } { 4311 lappend new_options "ldflags=-Wl,-rpath,${outdir}" 4312 } else { 4313 if { $shlib_load } { 4314 lappend new_options "libs=-ldl" 4315 } 4316 lappend new_options "ldflags=-Wl,-rpath,\\\$ORIGIN" 4317 } 4318 } 4319 set options $new_options 4320 4321 if [info exists GDB_TESTCASE_OPTIONS] { 4322 lappend options "additional_flags=$GDB_TESTCASE_OPTIONS" 4323 } 4324 verbose "options are $options" 4325 verbose "source is $source $dest $type $options" 4326 4327 gdb_wrapper_init 4328 4329 if {[target_info exists needs_status_wrapper] && \ 4330 [target_info needs_status_wrapper] != "0" && \ 4331 $gdb_wrapper_file != "" } { 4332 lappend options "libs=${gdb_wrapper_file}" 4333 lappend options "ldflags=${gdb_wrapper_flags}" 4334 } 4335 4336 # Replace the "nowarnings" option with the appropriate additional_flags 4337 # to disable compiler warnings. 4338 set nowarnings [lsearch -exact $options nowarnings] 4339 if {$nowarnings != -1} { 4340 if [target_info exists gdb,nowarnings_flag] { 4341 set flag "additional_flags=[target_info gdb,nowarnings_flag]" 4342 } else { 4343 set flag "additional_flags=-w" 4344 } 4345 set options [lreplace $options $nowarnings $nowarnings $flag] 4346 } 4347 4348 # Replace the "pie" option with the appropriate compiler and linker flags 4349 # to enable PIE executables. 4350 set pie [lsearch -exact $options pie] 4351 if {$pie != -1} { 4352 if [target_info exists gdb,pie_flag] { 4353 set flag "additional_flags=[target_info gdb,pie_flag]" 4354 } else { 4355 # For safety, use fPIE rather than fpie. On AArch64, m68k, PowerPC 4356 # and SPARC, fpie can cause compile errors due to the GOT exceeding 4357 # a maximum size. On other architectures the two flags are 4358 # identical (see the GCC manual). Note Debian9 and Ubuntu16.10 4359 # onwards default GCC to using fPIE. If you do require fpie, then 4360 # it can be set using the pie_flag. 4361 set flag "additional_flags=-fPIE" 4362 } 4363 set options [lreplace $options $pie $pie $flag] 4364 4365 if [target_info exists gdb,pie_ldflag] { 4366 set flag "ldflags=[target_info gdb,pie_ldflag]" 4367 } else { 4368 set flag "ldflags=-pie" 4369 } 4370 lappend options "$flag" 4371 } 4372 4373 # Replace the "nopie" option with the appropriate compiler and linker 4374 # flags to disable PIE executables. 4375 set nopie [lsearch -exact $options nopie] 4376 if {$nopie != -1} { 4377 if [target_info exists gdb,nopie_flag] { 4378 set flag "additional_flags=[target_info gdb,nopie_flag]" 4379 } else { 4380 set flag "additional_flags=-fno-pie" 4381 } 4382 set options [lreplace $options $nopie $nopie $flag] 4383 4384 if [target_info exists gdb,nopie_ldflag] { 4385 set flag "ldflags=[target_info gdb,nopie_ldflag]" 4386 } else { 4387 set flag "ldflags=-no-pie" 4388 } 4389 lappend options "$flag" 4390 } 4391 4392 if { $type == "executable" } { 4393 if { ([istarget "*-*-mingw*"] 4394 || [istarget "*-*-*djgpp"] 4395 || [istarget "*-*-cygwin*"])} { 4396 # Force output to unbuffered mode, by linking in an object file 4397 # with a global contructor that calls setvbuf. 4398 # 4399 # Compile the special object separately for two reasons: 4400 # 1) Insulate it from $options. 4401 # 2) Avoid compiling it for every gdb_compile invocation, 4402 # which is time consuming, especially if we're remote 4403 # host testing. 4404 # 4405 if { $gdb_saved_set_unbuffered_mode_obj == "" } { 4406 verbose "compiling gdb_saved_set_unbuffered_obj" 4407 set unbuf_src ${srcdir}/lib/set_unbuffered_mode.c 4408 set unbuf_obj ${objdir}/set_unbuffered_mode.o 4409 4410 set result [gdb_compile "${unbuf_src}" "${unbuf_obj}" object {nowarnings}] 4411 if { $result != "" } { 4412 return $result 4413 } 4414 if {[is_remote host]} { 4415 set gdb_saved_set_unbuffered_mode_obj set_unbuffered_mode_saved.o 4416 } else { 4417 set gdb_saved_set_unbuffered_mode_obj ${objdir}/set_unbuffered_mode_saved.o 4418 } 4419 # Link a copy of the output object, because the 4420 # original may be automatically deleted. 4421 remote_download host $unbuf_obj $gdb_saved_set_unbuffered_mode_obj 4422 } else { 4423 verbose "gdb_saved_set_unbuffered_obj already compiled" 4424 } 4425 4426 # Rely on the internal knowledge that the global ctors are ran in 4427 # reverse link order. In that case, we can use ldflags to 4428 # avoid copying the object file to the host multiple 4429 # times. 4430 # This object can only be added if standard libraries are 4431 # used. Thus, we need to disable it if -nostdlib option is used 4432 if {[lsearch -regexp $options "-nostdlib"] < 0 } { 4433 lappend options "ldflags=$gdb_saved_set_unbuffered_mode_obj" 4434 } 4435 } 4436 } 4437 4438 set result [target_compile $source $dest $type $options] 4439 4440 # Prune uninteresting compiler (and linker) output. 4441 regsub "Creating library file: \[^\r\n\]*\[\r\n\]+" $result "" result 4442 4443 regsub "\[\r\n\]*$" "$result" "" result 4444 regsub "^\[\r\n\]*" "$result" "" result 4445 4446 if { $type == "executable" && $result == "" \ 4447 && ($nopie != -1 || $pie != -1) } { 4448 set is_pie [exec_is_pie "$dest"] 4449 if { $nopie != -1 && $is_pie == 1 } { 4450 set result "nopie failed to prevent PIE executable" 4451 } elseif { $pie != -1 && $is_pie == 0 } { 4452 set result "pie failed to generate PIE executable" 4453 } 4454 } 4455 4456 if {[lsearch $options quiet] < 0} { 4457 # We shall update this on a per language basis, to avoid 4458 # changing the entire testsuite in one go. 4459 if {[lsearch $options f77] >= 0} { 4460 gdb_compile_test $source $result 4461 } elseif { $result != "" } { 4462 clone_output "gdb compile failed, $result" 4463 } 4464 } 4465 return $result 4466} 4467 4468 4469# This is just like gdb_compile, above, except that it tries compiling 4470# against several different thread libraries, to see which one this 4471# system has. 4472proc gdb_compile_pthreads {source dest type options} { 4473 if {$type != "executable"} { 4474 return [gdb_compile $source $dest $type $options] 4475 } 4476 set built_binfile 0 4477 set why_msg "unrecognized error" 4478 foreach lib {-lpthreads -lpthread -lthread ""} { 4479 # This kind of wipes out whatever libs the caller may have 4480 # set. Or maybe theirs will override ours. How infelicitous. 4481 set options_with_lib [concat $options [list libs=$lib quiet]] 4482 set ccout [gdb_compile $source $dest $type $options_with_lib] 4483 switch -regexp -- $ccout { 4484 ".*no posix threads support.*" { 4485 set why_msg "missing threads include file" 4486 break 4487 } 4488 ".*cannot open -lpthread.*" { 4489 set why_msg "missing runtime threads library" 4490 } 4491 ".*Can't find library for -lpthread.*" { 4492 set why_msg "missing runtime threads library" 4493 } 4494 {^$} { 4495 pass "successfully compiled posix threads test case" 4496 set built_binfile 1 4497 break 4498 } 4499 } 4500 } 4501 if {!$built_binfile} { 4502 unsupported "couldn't compile [file tail $source]: ${why_msg}" 4503 return -1 4504 } 4505} 4506 4507# Build a shared library from SOURCES. 4508 4509proc gdb_compile_shlib_1 {sources dest options} { 4510 set obj_options $options 4511 4512 set ada 0 4513 if { [lsearch -exact $options "ada"] >= 0 } { 4514 set ada 1 4515 } 4516 4517 set info_options "" 4518 if { [lsearch -exact $options "c++"] >= 0 } { 4519 set info_options "c++" 4520 } 4521 if [get_compiler_info ${info_options}] { 4522 return -1 4523 } 4524 4525 switch -glob [test_compiler_info] { 4526 "xlc-*" { 4527 lappend obj_options "additional_flags=-qpic" 4528 } 4529 "clang-*" { 4530 if { [istarget "*-*-cygwin*"] 4531 || [istarget "*-*-mingw*"] } { 4532 lappend obj_options "additional_flags=-fPIC" 4533 } else { 4534 lappend obj_options "additional_flags=-fpic" 4535 } 4536 } 4537 "gcc-*" { 4538 if { [istarget "powerpc*-*-aix*"] 4539 || [istarget "rs6000*-*-aix*"] 4540 || [istarget "*-*-cygwin*"] 4541 || [istarget "*-*-mingw*"] 4542 || [istarget "*-*-pe*"] } { 4543 lappend obj_options "additional_flags=-fPIC" 4544 } else { 4545 lappend obj_options "additional_flags=-fpic" 4546 } 4547 } 4548 "icc-*" { 4549 lappend obj_options "additional_flags=-fpic" 4550 } 4551 default { 4552 # don't know what the compiler is... 4553 lappend obj_options "additional_flags=-fPIC" 4554 } 4555 } 4556 4557 set outdir [file dirname $dest] 4558 set objects "" 4559 foreach source $sources { 4560 if {[file extension $source] == ".o"} { 4561 # Already a .o file. 4562 lappend objects $source 4563 continue 4564 } 4565 4566 set sourcebase [file tail $source] 4567 4568 if { $ada } { 4569 # Gnatmake doesn't like object name foo.adb.o, use foo.o. 4570 set sourcebase [file rootname $sourcebase] 4571 } 4572 set object ${outdir}/${sourcebase}.o 4573 4574 if { $ada } { 4575 # Use gdb_compile_ada_1 instead of gdb_compile_ada to avoid the 4576 # PASS message. 4577 if {[gdb_compile_ada_1 $source $object object \ 4578 $obj_options] != ""} { 4579 return -1 4580 } 4581 } else { 4582 if {[gdb_compile $source $object object \ 4583 $obj_options] != ""} { 4584 return -1 4585 } 4586 } 4587 4588 lappend objects $object 4589 } 4590 4591 set link_options $options 4592 if { $ada } { 4593 # If we try to use gnatmake for the link, it will interpret the 4594 # object file as an .adb file. Remove ada from the options to 4595 # avoid it. 4596 set idx [lsearch $link_options "ada"] 4597 set link_options [lreplace $link_options $idx $idx] 4598 } 4599 if [test_compiler_info "xlc-*"] { 4600 lappend link_options "additional_flags=-qmkshrobj" 4601 } else { 4602 lappend link_options "additional_flags=-shared" 4603 4604 if { ([istarget "*-*-mingw*"] 4605 || [istarget *-*-cygwin*] 4606 || [istarget *-*-pe*]) } { 4607 if { [is_remote host] } { 4608 set name [file tail ${dest}] 4609 } else { 4610 set name ${dest} 4611 } 4612 lappend link_options "additional_flags=-Wl,--out-implib,${name}.a" 4613 } else { 4614 # Set the soname of the library. This causes the linker on ELF 4615 # systems to create the DT_NEEDED entry in the executable referring 4616 # to the soname of the library, and not its absolute path. This 4617 # (using the absolute path) would be problem when testing on a 4618 # remote target. 4619 # 4620 # In conjunction with setting the soname, we add the special 4621 # rpath=$ORIGIN value when building the executable, so that it's 4622 # able to find the library in its own directory. 4623 set destbase [file tail $dest] 4624 lappend link_options "additional_flags=-Wl,-soname,$destbase" 4625 } 4626 } 4627 if {[gdb_compile "${objects}" "${dest}" executable $link_options] != ""} { 4628 return -1 4629 } 4630 if { [is_remote host] 4631 && ([istarget "*-*-mingw*"] 4632 || [istarget *-*-cygwin*] 4633 || [istarget *-*-pe*]) } { 4634 set dest_tail_name [file tail ${dest}] 4635 remote_upload host $dest_tail_name.a ${dest}.a 4636 remote_file host delete $dest_tail_name.a 4637 } 4638 4639 return "" 4640} 4641 4642# Build a shared library from SOURCES. Ignore target boards PIE-related 4643# multilib_flags. 4644 4645proc gdb_compile_shlib {sources dest options} { 4646 global board 4647 4648 # Ignore PIE-related setting in multilib_flags. 4649 set board [target_info name] 4650 set multilib_flags_orig [board_info $board multilib_flags] 4651 set multilib_flags "" 4652 foreach op $multilib_flags_orig { 4653 if { $op == "-pie" || $op == "-no-pie" \ 4654 || $op == "-fPIE" || $op == "-fno-PIE"} { 4655 } else { 4656 append multilib_flags " $op" 4657 } 4658 } 4659 4660 save_target_board_info { multilib_flags } { 4661 unset_board_info multilib_flags 4662 set_board_info multilib_flags "$multilib_flags" 4663 set result [gdb_compile_shlib_1 $sources $dest $options] 4664 } 4665 4666 return $result 4667} 4668 4669# This is just like gdb_compile_shlib, above, except that it tries compiling 4670# against several different thread libraries, to see which one this 4671# system has. 4672proc gdb_compile_shlib_pthreads {sources dest options} { 4673 set built_binfile 0 4674 set why_msg "unrecognized error" 4675 foreach lib {-lpthreads -lpthread -lthread ""} { 4676 # This kind of wipes out whatever libs the caller may have 4677 # set. Or maybe theirs will override ours. How infelicitous. 4678 set options_with_lib [concat $options [list libs=$lib quiet]] 4679 set ccout [gdb_compile_shlib $sources $dest $options_with_lib] 4680 switch -regexp -- $ccout { 4681 ".*no posix threads support.*" { 4682 set why_msg "missing threads include file" 4683 break 4684 } 4685 ".*cannot open -lpthread.*" { 4686 set why_msg "missing runtime threads library" 4687 } 4688 ".*Can't find library for -lpthread.*" { 4689 set why_msg "missing runtime threads library" 4690 } 4691 {^$} { 4692 pass "successfully compiled posix threads shlib test case" 4693 set built_binfile 1 4694 break 4695 } 4696 } 4697 } 4698 if {!$built_binfile} { 4699 unsupported "couldn't compile $sources: ${why_msg}" 4700 return -1 4701 } 4702} 4703 4704# This is just like gdb_compile_pthreads, above, except that we always add the 4705# objc library for compiling Objective-C programs 4706proc gdb_compile_objc {source dest type options} { 4707 set built_binfile 0 4708 set why_msg "unrecognized error" 4709 foreach lib {-lobjc -lpthreads -lpthread -lthread solaris} { 4710 # This kind of wipes out whatever libs the caller may have 4711 # set. Or maybe theirs will override ours. How infelicitous. 4712 if { $lib == "solaris" } { 4713 set lib "-lpthread -lposix4" 4714 } 4715 if { $lib != "-lobjc" } { 4716 set lib "-lobjc $lib" 4717 } 4718 set options_with_lib [concat $options [list libs=$lib quiet]] 4719 set ccout [gdb_compile $source $dest $type $options_with_lib] 4720 switch -regexp -- $ccout { 4721 ".*no posix threads support.*" { 4722 set why_msg "missing threads include file" 4723 break 4724 } 4725 ".*cannot open -lpthread.*" { 4726 set why_msg "missing runtime threads library" 4727 } 4728 ".*Can't find library for -lpthread.*" { 4729 set why_msg "missing runtime threads library" 4730 } 4731 {^$} { 4732 pass "successfully compiled objc with posix threads test case" 4733 set built_binfile 1 4734 break 4735 } 4736 } 4737 } 4738 if {!$built_binfile} { 4739 unsupported "couldn't compile [file tail $source]: ${why_msg}" 4740 return -1 4741 } 4742} 4743 4744# Build an OpenMP program from SOURCE. See prefatory comment for 4745# gdb_compile, above, for discussion of the parameters to this proc. 4746 4747proc gdb_compile_openmp {source dest type options} { 4748 lappend options "additional_flags=-fopenmp" 4749 return [gdb_compile $source $dest $type $options] 4750} 4751 4752# Send a command to GDB. 4753# For options for TYPE see gdb_stdin_log_write 4754 4755proc send_gdb { string {type standard}} { 4756 gdb_stdin_log_write $string $type 4757 return [remote_send host "$string"] 4758} 4759 4760# Send STRING to the inferior's terminal. 4761 4762proc send_inferior { string } { 4763 global inferior_spawn_id 4764 4765 if {[catch "send -i $inferior_spawn_id -- \$string" errorInfo]} { 4766 return "$errorInfo" 4767 } else { 4768 return "" 4769 } 4770} 4771 4772# 4773# 4774 4775proc gdb_expect { args } { 4776 if { [llength $args] == 2 && [lindex $args 0] != "-re" } { 4777 set atimeout [lindex $args 0] 4778 set expcode [list [lindex $args 1]] 4779 } else { 4780 set expcode $args 4781 } 4782 4783 # A timeout argument takes precedence, otherwise of all the timeouts 4784 # select the largest. 4785 if [info exists atimeout] { 4786 set tmt $atimeout 4787 } else { 4788 set tmt [get_largest_timeout] 4789 } 4790 4791 set code [catch \ 4792 {uplevel remote_expect host $tmt $expcode} string] 4793 4794 if {$code == 1} { 4795 global errorInfo errorCode 4796 4797 return -code error -errorinfo $errorInfo -errorcode $errorCode $string 4798 } else { 4799 return -code $code $string 4800 } 4801} 4802 4803# gdb_expect_list TEST SENTINEL LIST -- expect a sequence of outputs 4804# 4805# Check for long sequence of output by parts. 4806# TEST: is the test message to be printed with the test success/fail. 4807# SENTINEL: Is the terminal pattern indicating that output has finished. 4808# LIST: is the sequence of outputs to match. 4809# If the sentinel is recognized early, it is considered an error. 4810# 4811# Returns: 4812# 1 if the test failed, 4813# 0 if the test passes, 4814# -1 if there was an internal error. 4815 4816proc gdb_expect_list {test sentinel list} { 4817 global gdb_prompt 4818 set index 0 4819 set ok 1 4820 4821 while { ${index} < [llength ${list}] } { 4822 set pattern [lindex ${list} ${index}] 4823 set index [expr ${index} + 1] 4824 verbose -log "gdb_expect_list pattern: /$pattern/" 2 4825 if { ${index} == [llength ${list}] } { 4826 if { ${ok} } { 4827 gdb_expect { 4828 -re "${pattern}${sentinel}" { 4829 # pass "${test}, pattern ${index} + sentinel" 4830 } 4831 -re "${sentinel}" { 4832 fail "${test} (pattern ${index} + sentinel)" 4833 set ok 0 4834 } 4835 -re ".*A problem internal to GDB has been detected" { 4836 fail "${test} (GDB internal error)" 4837 set ok 0 4838 gdb_internal_error_resync 4839 } 4840 timeout { 4841 fail "${test} (pattern ${index} + sentinel) (timeout)" 4842 set ok 0 4843 } 4844 } 4845 } else { 4846 # unresolved "${test}, pattern ${index} + sentinel" 4847 } 4848 } else { 4849 if { ${ok} } { 4850 gdb_expect { 4851 -re "${pattern}" { 4852 # pass "${test}, pattern ${index}" 4853 } 4854 -re "${sentinel}" { 4855 fail "${test} (pattern ${index})" 4856 set ok 0 4857 } 4858 -re ".*A problem internal to GDB has been detected" { 4859 fail "${test} (GDB internal error)" 4860 set ok 0 4861 gdb_internal_error_resync 4862 } 4863 timeout { 4864 fail "${test} (pattern ${index}) (timeout)" 4865 set ok 0 4866 } 4867 } 4868 } else { 4869 # unresolved "${test}, pattern ${index}" 4870 } 4871 } 4872 } 4873 if { ${ok} } { 4874 pass "${test}" 4875 return 0 4876 } else { 4877 return 1 4878 } 4879} 4880 4881# Spawn the gdb process. 4882# 4883# This doesn't expect any output or do any other initialization, 4884# leaving those to the caller. 4885# 4886# Overridable function -- you can override this function in your 4887# baseboard file. 4888 4889proc gdb_spawn { } { 4890 default_gdb_spawn 4891} 4892 4893# Spawn GDB with CMDLINE_FLAGS appended to the GDBFLAGS global. 4894 4895proc gdb_spawn_with_cmdline_opts { cmdline_flags } { 4896 global GDBFLAGS 4897 4898 set saved_gdbflags $GDBFLAGS 4899 4900 if {$GDBFLAGS != ""} { 4901 append GDBFLAGS " " 4902 } 4903 append GDBFLAGS $cmdline_flags 4904 4905 set res [gdb_spawn] 4906 4907 set GDBFLAGS $saved_gdbflags 4908 4909 return $res 4910} 4911 4912# Start gdb running, wait for prompt, and disable the pagers. 4913 4914# Overridable function -- you can override this function in your 4915# baseboard file. 4916 4917proc gdb_start { } { 4918 default_gdb_start 4919} 4920 4921proc gdb_exit { } { 4922 catch default_gdb_exit 4923} 4924 4925# Return true if we can spawn a program on the target and attach to 4926# it. 4927 4928proc can_spawn_for_attach { } { 4929 # We use exp_pid to get the inferior's pid, assuming that gives 4930 # back the pid of the program. On remote boards, that would give 4931 # us instead the PID of e.g., the ssh client, etc. 4932 if [is_remote target] then { 4933 return 0 4934 } 4935 4936 # The "attach" command doesn't make sense when the target is 4937 # stub-like, where GDB finds the program already started on 4938 # initial connection. 4939 if {[target_info exists use_gdb_stub]} { 4940 return 0 4941 } 4942 4943 # Assume yes. 4944 return 1 4945} 4946 4947# Kill a progress previously started with spawn_wait_for_attach, and 4948# reap its wait status. PROC_SPAWN_ID is the spawn id associated with 4949# the process. 4950 4951proc kill_wait_spawned_process { proc_spawn_id } { 4952 set pid [exp_pid -i $proc_spawn_id] 4953 4954 verbose -log "killing ${pid}" 4955 remote_exec build "kill -9 ${pid}" 4956 4957 verbose -log "closing ${proc_spawn_id}" 4958 catch "close -i $proc_spawn_id" 4959 verbose -log "waiting for ${proc_spawn_id}" 4960 4961 # If somehow GDB ends up still attached to the process here, a 4962 # blocking wait hangs until gdb is killed (or until gdb / the 4963 # ptracer reaps the exit status too, but that won't happen because 4964 # something went wrong.) Passing -nowait makes expect tell Tcl to 4965 # wait for the PID in the background. That's fine because we 4966 # don't care about the exit status. */ 4967 wait -nowait -i $proc_spawn_id 4968} 4969 4970# Returns the process id corresponding to the given spawn id. 4971 4972proc spawn_id_get_pid { spawn_id } { 4973 set testpid [exp_pid -i $spawn_id] 4974 4975 if { [istarget "*-*-cygwin*"] } { 4976 # testpid is the Cygwin PID, GDB uses the Windows PID, which 4977 # might be different due to the way fork/exec works. 4978 set testpid [ exec ps -e | gawk "{ if (\$1 == $testpid) print \$4; }" ] 4979 } 4980 4981 return $testpid 4982} 4983 4984# Start a set of programs running and then wait for a bit, to be sure 4985# that they can be attached to. Return a list of processes spawn IDs, 4986# one element for each process spawned. It's a test error to call 4987# this when [can_spawn_for_attach] is false. 4988 4989proc spawn_wait_for_attach { executable_list } { 4990 set spawn_id_list {} 4991 4992 if ![can_spawn_for_attach] { 4993 # The caller should have checked can_spawn_for_attach itself 4994 # before getting here. 4995 error "can't spawn for attach with this target/board" 4996 } 4997 4998 foreach {executable} $executable_list { 4999 # Note we use Expect's spawn, not Tcl's exec, because with 5000 # spawn we control when to wait for/reap the process. That 5001 # allows killing the process by PID without being subject to 5002 # pid-reuse races. 5003 lappend spawn_id_list [remote_spawn target $executable] 5004 } 5005 5006 sleep 2 5007 5008 return $spawn_id_list 5009} 5010 5011# 5012# gdb_load_cmd -- load a file into the debugger. 5013# ARGS - additional args to load command. 5014# return a -1 if anything goes wrong. 5015# 5016proc gdb_load_cmd { args } { 5017 global gdb_prompt 5018 5019 if [target_info exists gdb_load_timeout] { 5020 set loadtimeout [target_info gdb_load_timeout] 5021 } else { 5022 set loadtimeout 1600 5023 } 5024 send_gdb "load $args\n" 5025 verbose "Timeout is now $loadtimeout seconds" 2 5026 gdb_expect $loadtimeout { 5027 -re "Loading section\[^\r\]*\r\n" { 5028 exp_continue 5029 } 5030 -re "Start address\[\r\]*\r\n" { 5031 exp_continue 5032 } 5033 -re "Transfer rate\[\r\]*\r\n" { 5034 exp_continue 5035 } 5036 -re "Memory access error\[^\r\]*\r\n" { 5037 perror "Failed to load program" 5038 return -1 5039 } 5040 -re "$gdb_prompt $" { 5041 return 0 5042 } 5043 -re "(.*)\r\n$gdb_prompt " { 5044 perror "Unexpected reponse from 'load' -- $expect_out(1,string)" 5045 return -1 5046 } 5047 timeout { 5048 perror "Timed out trying to load $args." 5049 return -1 5050 } 5051 } 5052 return -1 5053} 5054 5055# Invoke "gcore". CORE is the name of the core file to write. TEST 5056# is the name of the test case. This will return 1 if the core file 5057# was created, 0 otherwise. If this fails to make a core file because 5058# this configuration of gdb does not support making core files, it 5059# will call "unsupported", not "fail". However, if this fails to make 5060# a core file for some other reason, then it will call "fail". 5061 5062proc gdb_gcore_cmd {core test} { 5063 global gdb_prompt 5064 5065 set result 0 5066 gdb_test_multiple "gcore $core" $test { 5067 -re "Saved corefile .*\[\r\n\]+$gdb_prompt $" { 5068 pass $test 5069 set result 1 5070 } 5071 -re "(?:Can't create a corefile|Target does not support core file generation\\.)\[\r\n\]+$gdb_prompt $" { 5072 unsupported $test 5073 } 5074 } 5075 5076 return $result 5077} 5078 5079# Load core file CORE. TEST is the name of the test case. 5080# This will record a pass/fail for loading the core file. 5081# Returns: 5082# 1 - core file is successfully loaded 5083# 0 - core file loaded but has a non fatal error 5084# -1 - core file failed to load 5085 5086proc gdb_core_cmd { core test } { 5087 global gdb_prompt 5088 5089 gdb_test_multiple "core $core" "$test" { 5090 -re "\\\[Thread debugging using \[^ \r\n\]* enabled\\\]\r\n" { 5091 exp_continue 5092 } 5093 -re " is not a core dump:.*\r\n$gdb_prompt $" { 5094 fail "$test (bad file format)" 5095 return -1 5096 } 5097 -re -wrap "[string_to_regexp $core]: No such file or directory.*" { 5098 fail "$test (file not found)" 5099 return -1 5100 } 5101 -re "Couldn't find .* registers in core file.*\r\n$gdb_prompt $" { 5102 fail "$test (incomplete note section)" 5103 return 0 5104 } 5105 -re "Core was generated by .*\r\n$gdb_prompt $" { 5106 pass "$test" 5107 return 1 5108 } 5109 -re ".*$gdb_prompt $" { 5110 fail "$test" 5111 return -1 5112 } 5113 timeout { 5114 fail "$test (timeout)" 5115 return -1 5116 } 5117 } 5118 fail "unsupported output from 'core' command" 5119 return -1 5120} 5121 5122# Return the filename to download to the target and load on the target 5123# for this shared library. Normally just LIBNAME, unless shared libraries 5124# for this target have separate link and load images. 5125 5126proc shlib_target_file { libname } { 5127 return $libname 5128} 5129 5130# Return the filename GDB will load symbols from when debugging this 5131# shared library. Normally just LIBNAME, unless shared libraries for 5132# this target have separate link and load images. 5133 5134proc shlib_symbol_file { libname } { 5135 return $libname 5136} 5137 5138# Return the filename to download to the target and load for this 5139# executable. Normally just BINFILE unless it is renamed to something 5140# else for this target. 5141 5142proc exec_target_file { binfile } { 5143 return $binfile 5144} 5145 5146# Return the filename GDB will load symbols from when debugging this 5147# executable. Normally just BINFILE unless executables for this target 5148# have separate files for symbols. 5149 5150proc exec_symbol_file { binfile } { 5151 return $binfile 5152} 5153 5154# Rename the executable file. Normally this is just BINFILE1 being renamed 5155# to BINFILE2, but some targets require multiple binary files. 5156proc gdb_rename_execfile { binfile1 binfile2 } { 5157 file rename -force [exec_target_file ${binfile1}] \ 5158 [exec_target_file ${binfile2}] 5159 if { [exec_target_file ${binfile1}] != [exec_symbol_file ${binfile1}] } { 5160 file rename -force [exec_symbol_file ${binfile1}] \ 5161 [exec_symbol_file ${binfile2}] 5162 } 5163} 5164 5165# "Touch" the executable file to update the date. Normally this is just 5166# BINFILE, but some targets require multiple files. 5167proc gdb_touch_execfile { binfile } { 5168 set time [clock seconds] 5169 file mtime [exec_target_file ${binfile}] $time 5170 if { [exec_target_file ${binfile}] != [exec_symbol_file ${binfile}] } { 5171 file mtime [exec_symbol_file ${binfile}] $time 5172 } 5173} 5174 5175# Like remote_download but provides a gdb-specific behavior. 5176# 5177# If the destination board is remote, the local file FROMFILE is transferred as 5178# usual with remote_download to TOFILE on the remote board. The destination 5179# filename is added to the CLEANFILES global, so it can be cleaned up at the 5180# end of the test. 5181# 5182# If the destination board is local, the destination path TOFILE is passed 5183# through standard_output_file, and FROMFILE is copied there. 5184# 5185# In both cases, if TOFILE is omitted, it defaults to the [file tail] of 5186# FROMFILE. 5187 5188proc gdb_remote_download {dest fromfile {tofile {}}} { 5189 # If TOFILE is not given, default to the same filename as FROMFILE. 5190 if {[string length $tofile] == 0} { 5191 set tofile [file tail $fromfile] 5192 } 5193 5194 if {[is_remote $dest]} { 5195 # When the DEST is remote, we simply send the file to DEST. 5196 global cleanfiles 5197 5198 set destname [remote_download $dest $fromfile $tofile] 5199 lappend cleanfiles $destname 5200 5201 return $destname 5202 } else { 5203 # When the DEST is local, we copy the file to the test directory (where 5204 # the executable is). 5205 # 5206 # Note that we pass TOFILE through standard_output_file, regardless of 5207 # whether it is absolute or relative, because we don't want the tests 5208 # to be able to write outside their standard output directory. 5209 5210 set tofile [standard_output_file $tofile] 5211 5212 file copy -force $fromfile $tofile 5213 5214 return $tofile 5215 } 5216} 5217 5218# gdb_load_shlib LIB... 5219# 5220# Copy the listed library to the target. 5221 5222proc gdb_load_shlib { file } { 5223 global gdb_spawn_id 5224 5225 if ![info exists gdb_spawn_id] { 5226 perror "gdb_load_shlib: GDB is not running" 5227 } 5228 5229 set dest [gdb_remote_download target [shlib_target_file $file]] 5230 5231 if {[is_remote target]} { 5232 # If the target is remote, we need to tell gdb where to find the 5233 # libraries. 5234 # 5235 # We could set this even when not testing remotely, but a user 5236 # generally won't set it unless necessary. In order to make the tests 5237 # more like the real-life scenarios, we don't set it for local testing. 5238 gdb_test "set solib-search-path [file dirname $file]" "" "" 5239 } 5240 5241 return $dest 5242} 5243 5244# 5245# gdb_load -- load a file into the debugger. Specifying no file 5246# defaults to the executable currently being debugged. 5247# The return value is 0 for success, -1 for failure. 5248# Many files in config/*.exp override this procedure. 5249# 5250proc gdb_load { arg } { 5251 if { $arg != "" } { 5252 return [gdb_file_cmd $arg] 5253 } 5254 return 0 5255} 5256 5257# 5258# with_complaints -- Execute BODY and set complaints temporary to N for the 5259# duration. 5260# 5261proc with_complaints { n body } { 5262 global decimal 5263 5264 # Save current setting of complaints. 5265 set save "" 5266 set show_complaints_re \ 5267 "Max number of complaints about incorrect symbols is ($decimal)\\." 5268 gdb_test_multiple "show complaints" "" { 5269 -re -wrap $show_complaints_re { 5270 set save $expect_out(1,string) 5271 } 5272 } 5273 5274 if { $save == "" } { 5275 perror "Did not manage to set complaints" 5276 } else { 5277 # Set complaints. 5278 gdb_test_no_output "set complaints $n" "" 5279 } 5280 5281 set code [catch {uplevel 1 $body} result] 5282 5283 # Restore saved setting of complaints. 5284 if { $save != "" } { 5285 gdb_test_no_output "set complaints $save" "" 5286 } 5287 5288 if {$code == 1} { 5289 global errorInfo errorCode 5290 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result 5291 } else { 5292 return -code $code $result 5293 } 5294} 5295 5296# 5297# gdb_load_no_complaints -- As gdb_load, but in addition verifies that 5298# loading caused no symbol reading complaints. 5299# 5300proc gdb_load_no_complaints { arg } { 5301 global gdb_prompt gdb_file_cmd_msg decimal 5302 5303 # Temporarily set complaint to a small non-zero number. 5304 with_complaints 5 { 5305 gdb_load $arg 5306 } 5307 5308 # Verify that there were no complaints. 5309 set re "^Reading symbols from \[^\r\n\]*\r\n$gdb_prompt $" 5310 gdb_assert {[regexp $re $gdb_file_cmd_msg]} "No complaints" 5311} 5312 5313# gdb_reload -- load a file into the target. Called before "running", 5314# either the first time or after already starting the program once, 5315# for remote targets. Most files that override gdb_load should now 5316# override this instead. 5317# 5318# INFERIOR_ARGS contains the arguments to pass to the inferiors, as a 5319# single string to get interpreted by a shell. If the target board 5320# overriding gdb_reload is a "stub", then it should arrange things such 5321# these arguments make their way to the inferior process. 5322 5323proc gdb_reload { {inferior_args {}} } { 5324 # For the benefit of existing configurations, default to gdb_load. 5325 # Specifying no file defaults to the executable currently being 5326 # debugged. 5327 return [gdb_load ""] 5328} 5329 5330proc gdb_continue { function } { 5331 global decimal 5332 5333 return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"] 5334} 5335 5336# Default implementation of gdb_init. 5337proc default_gdb_init { test_file_name } { 5338 global gdb_wrapper_initialized 5339 global gdb_wrapper_target 5340 global gdb_test_file_name 5341 global cleanfiles 5342 global pf_prefix 5343 5344 # Reset the timeout value to the default. This way, any testcase 5345 # that changes the timeout value without resetting it cannot affect 5346 # the timeout used in subsequent testcases. 5347 global gdb_test_timeout 5348 global timeout 5349 set timeout $gdb_test_timeout 5350 5351 if { [regexp ".*gdb\.reverse\/.*" $test_file_name] 5352 && [target_info exists gdb_reverse_timeout] } { 5353 set timeout [target_info gdb_reverse_timeout] 5354 } 5355 5356 # If GDB_INOTIFY is given, check for writes to '.'. This is a 5357 # debugging tool to help confirm that the test suite is 5358 # parallel-safe. You need "inotifywait" from the 5359 # inotify-tools package to use this. 5360 global GDB_INOTIFY inotify_pid 5361 if {[info exists GDB_INOTIFY] && ![info exists inotify_pid]} { 5362 global outdir tool inotify_log_file 5363 5364 set exclusions {outputs temp gdb[.](log|sum) cache} 5365 set exclusion_re ([join $exclusions |]) 5366 5367 set inotify_log_file [standard_temp_file inotify.out] 5368 set inotify_pid [exec inotifywait -r -m -e move,create,delete . \ 5369 --exclude $exclusion_re \ 5370 |& tee -a $outdir/$tool.log $inotify_log_file &] 5371 5372 # Wait for the watches; hopefully this is long enough. 5373 sleep 2 5374 5375 # Clear the log so that we don't emit a warning the first time 5376 # we check it. 5377 set fd [open $inotify_log_file w] 5378 close $fd 5379 } 5380 5381 # Block writes to all banned variables, and invocation of all 5382 # banned procedures... 5383 global banned_variables 5384 global banned_procedures 5385 global banned_traced 5386 if (!$banned_traced) { 5387 foreach banned_var $banned_variables { 5388 global "$banned_var" 5389 trace add variable "$banned_var" write error 5390 } 5391 foreach banned_proc $banned_procedures { 5392 global "$banned_proc" 5393 trace add execution "$banned_proc" enter error 5394 } 5395 set banned_traced 1 5396 } 5397 5398 # We set LC_ALL, LC_CTYPE, and LANG to C so that we get the same 5399 # messages as expected. 5400 setenv LC_ALL C 5401 setenv LC_CTYPE C 5402 setenv LANG C 5403 5404 # Don't let a .inputrc file or an existing setting of INPUTRC mess 5405 # up the test results. Certain tests (style tests and TUI tests) 5406 # want to set the terminal to a non-"dumb" value, and for those we 5407 # want to disable bracketed paste mode. Versions of Readline 5408 # before 8.0 will not understand this and will issue a warning. 5409 # We tried using a $if to guard it, but Readline 8.1 had a bug in 5410 # its version-comparison code that prevented this for working. 5411 setenv INPUTRC [cached_file inputrc "set enable-bracketed-paste off"] 5412 5413 # This disables style output, which would interfere with many 5414 # tests. 5415 setenv TERM "dumb" 5416 5417 # If DEBUGINFOD_URLS is set, gdb will try to download sources and 5418 # debug info for f.i. system libraries. Prevent this. 5419 unset -nocomplain ::env(DEBUGINFOD_URLS) 5420 5421 # Ensure that GDBHISTFILE and GDBHISTSIZE are removed from the 5422 # environment, we don't want these modifications to the history 5423 # settings. 5424 unset -nocomplain ::env(GDBHISTFILE) 5425 unset -nocomplain ::env(GDBHISTSIZE) 5426 5427 # Ensure that XDG_CONFIG_HOME is not set. Some tests setup a fake 5428 # home directory in order to test loading settings from gdbinit. 5429 # If XDG_CONFIG_HOME is set then GDB will load a gdbinit from 5430 # there (if one is present) rather than the home directory setup 5431 # in the test. 5432 unset -nocomplain ::env(XDG_CONFIG_HOME) 5433 5434 # Initialize GDB's pty with a fixed size, to make sure we avoid pagination 5435 # during startup. See "man expect" for details about stty_init. 5436 global stty_init 5437 set stty_init "rows 25 cols 80" 5438 5439 # Some tests (for example gdb.base/maint.exp) shell out from gdb to use 5440 # grep. Clear GREP_OPTIONS to make the behavior predictable, 5441 # especially having color output turned on can cause tests to fail. 5442 setenv GREP_OPTIONS "" 5443 5444 # Clear $gdbserver_reconnect_p. 5445 global gdbserver_reconnect_p 5446 set gdbserver_reconnect_p 1 5447 unset gdbserver_reconnect_p 5448 5449 # Clear $last_loaded_file 5450 global last_loaded_file 5451 unset -nocomplain last_loaded_file 5452 5453 # Reset GDB number of instances 5454 global gdb_instances 5455 set gdb_instances 0 5456 5457 set cleanfiles {} 5458 5459 set gdb_test_file_name [file rootname [file tail $test_file_name]] 5460 5461 # Make sure that the wrapper is rebuilt 5462 # with the appropriate multilib option. 5463 if { $gdb_wrapper_target != [current_target_name] } { 5464 set gdb_wrapper_initialized 0 5465 } 5466 5467 # Unlike most tests, we have a small number of tests that generate 5468 # a very large amount of output. We therefore increase the expect 5469 # buffer size to be able to contain the entire test output. This 5470 # is especially needed by gdb.base/info-macros.exp. 5471 match_max -d 65536 5472 # Also set this value for the currently running GDB. 5473 match_max [match_max -d] 5474 5475 # We want to add the name of the TCL testcase to the PASS/FAIL messages. 5476 set pf_prefix "[file tail [file dirname $test_file_name]]/[file tail $test_file_name]:" 5477 5478 global gdb_prompt 5479 if [target_info exists gdb_prompt] { 5480 set gdb_prompt [target_info gdb_prompt] 5481 } else { 5482 set gdb_prompt "\\(gdb\\)" 5483 } 5484 global use_gdb_stub 5485 if [info exists use_gdb_stub] { 5486 unset use_gdb_stub 5487 } 5488 5489 gdb_setup_known_globals 5490 5491 if { [info procs ::gdb_tcl_unknown] != "" } { 5492 # Dejagnu overrides proc unknown. The dejagnu version may trigger in a 5493 # test-case but abort the entire test run. To fix this, we install a 5494 # local version here, which reverts dejagnu's override, and restore 5495 # dejagnu's version in gdb_finish. 5496 rename ::unknown ::dejagnu_unknown 5497 proc unknown { args } { 5498 # Use tcl's unknown. 5499 set cmd [lindex $args 0] 5500 unresolved "testcase aborted due to invalid command name: $cmd" 5501 return [uplevel 1 ::gdb_tcl_unknown $args] 5502 } 5503 } 5504} 5505 5506# Return a path using GDB_PARALLEL. 5507# ARGS is a list of path elements to append to "$objdir/$GDB_PARALLEL". 5508# GDB_PARALLEL must be defined, the caller must check. 5509# 5510# The default value for GDB_PARALLEL is, canonically, ".". 5511# The catch is that tests don't expect an additional "./" in file paths so 5512# omit any directory for the default case. 5513# GDB_PARALLEL is written as "yes" for the default case in Makefile.in to mark 5514# its special handling. 5515 5516proc make_gdb_parallel_path { args } { 5517 global GDB_PARALLEL objdir 5518 set joiner [list "file" "join" $objdir] 5519 if { [info exists GDB_PARALLEL] && $GDB_PARALLEL != "yes" } { 5520 lappend joiner $GDB_PARALLEL 5521 } 5522 set joiner [concat $joiner $args] 5523 return [eval $joiner] 5524} 5525 5526# Turn BASENAME into a full file name in the standard output 5527# directory. It is ok if BASENAME is the empty string; in this case 5528# the directory is returned. 5529 5530proc standard_output_file {basename} { 5531 global objdir subdir gdb_test_file_name 5532 5533 set dir [make_gdb_parallel_path outputs $subdir $gdb_test_file_name] 5534 file mkdir $dir 5535 # If running on MinGW, replace /c/foo with c:/foo 5536 if { [ishost *-*-mingw*] } { 5537 set dir [exec sh -c "cd ${dir} && pwd -W"] 5538 } 5539 return [file join $dir $basename] 5540} 5541 5542# Turn BASENAME into a full file name in the standard output directory. If 5543# GDB has been launched more than once then append the count, starting with 5544# a ".1" postfix. 5545 5546proc standard_output_file_with_gdb_instance {basename} { 5547 global gdb_instances 5548 set count $gdb_instances 5549 5550 if {$count == 0} { 5551 return [standard_output_file $basename] 5552 } 5553 return [standard_output_file ${basename}.${count}] 5554} 5555 5556# Return the name of a file in our standard temporary directory. 5557 5558proc standard_temp_file {basename} { 5559 # Since a particular runtest invocation is only executing a single test 5560 # file at any given time, we can use the runtest pid to build the 5561 # path of the temp directory. 5562 set dir [make_gdb_parallel_path temp [pid]] 5563 file mkdir $dir 5564 return [file join $dir $basename] 5565} 5566 5567# Rename file A to file B, if B does not already exists. Otherwise, leave B 5568# as is and delete A. Return 1 if rename happened. 5569 5570proc tentative_rename { a b } { 5571 global errorInfo errorCode 5572 set code [catch {file rename -- $a $b} result] 5573 if { $code == 1 && [lindex $errorCode 0] == "POSIX" \ 5574 && [lindex $errorCode 1] == "EEXIST" } { 5575 file delete $a 5576 return 0 5577 } 5578 if {$code == 1} { 5579 return -code error -errorinfo $errorInfo -errorcode $errorCode $result 5580 } elseif {$code > 1} { 5581 return -code $code $result 5582 } 5583 return 1 5584} 5585 5586# Create a file with name FILENAME and contents TXT in the cache directory. 5587# If EXECUTABLE, mark the new file for execution. 5588 5589proc cached_file { filename txt {executable 0}} { 5590 set filename [make_gdb_parallel_path cache $filename] 5591 5592 if { [file exists $filename] } { 5593 return $filename 5594 } 5595 5596 set dir [file dirname $filename] 5597 file mkdir $dir 5598 5599 set tmp_filename $filename.[pid] 5600 set fd [open $tmp_filename w] 5601 puts $fd $txt 5602 close $fd 5603 5604 if { $executable } { 5605 exec chmod +x $tmp_filename 5606 } 5607 tentative_rename $tmp_filename $filename 5608 5609 return $filename 5610} 5611 5612# Set 'testfile', 'srcfile', and 'binfile'. 5613# 5614# ARGS is a list of source file specifications. 5615# Without any arguments, the .exp file's base name is used to 5616# compute the source file name. The ".c" extension is added in this case. 5617# If ARGS is not empty, each entry is a source file specification. 5618# If the specification starts with a "." or "-", it is treated as a suffix 5619# to append to the .exp file's base name. 5620# If the specification is the empty string, it is treated as if it 5621# were ".c". 5622# Otherwise it is a file name. 5623# The first file in the list is used to set the 'srcfile' global. 5624# Each subsequent name is used to set 'srcfile2', 'srcfile3', etc. 5625# 5626# Most tests should call this without arguments. 5627# 5628# If a completely different binary file name is needed, then it 5629# should be handled in the .exp file with a suitable comment. 5630 5631proc standard_testfile {args} { 5632 global gdb_test_file_name 5633 global subdir 5634 global gdb_test_file_last_vars 5635 5636 # Outputs. 5637 global testfile binfile 5638 5639 set testfile $gdb_test_file_name 5640 set binfile [standard_output_file ${testfile}] 5641 5642 if {[llength $args] == 0} { 5643 set args .c 5644 } 5645 5646 # Unset our previous output variables. 5647 # This can help catch hidden bugs. 5648 if {[info exists gdb_test_file_last_vars]} { 5649 foreach varname $gdb_test_file_last_vars { 5650 global $varname 5651 catch {unset $varname} 5652 } 5653 } 5654 # 'executable' is often set by tests. 5655 set gdb_test_file_last_vars {executable} 5656 5657 set suffix "" 5658 foreach arg $args { 5659 set varname srcfile$suffix 5660 global $varname 5661 5662 # Handle an extension. 5663 if {$arg == ""} { 5664 set arg $testfile.c 5665 } else { 5666 set first [string range $arg 0 0] 5667 if { $first == "." || $first == "-" } { 5668 set arg $testfile$arg 5669 } 5670 } 5671 5672 set $varname $arg 5673 lappend gdb_test_file_last_vars $varname 5674 5675 if {$suffix == ""} { 5676 set suffix 2 5677 } else { 5678 incr suffix 5679 } 5680 } 5681} 5682 5683# The default timeout used when testing GDB commands. We want to use 5684# the same timeout as the default dejagnu timeout, unless the user has 5685# already provided a specific value (probably through a site.exp file). 5686global gdb_test_timeout 5687if ![info exists gdb_test_timeout] { 5688 set gdb_test_timeout $timeout 5689} 5690 5691# A list of global variables that GDB testcases should not use. 5692# We try to prevent their use by monitoring write accesses and raising 5693# an error when that happens. 5694set banned_variables { bug_id prms_id } 5695 5696# A list of procedures that GDB testcases should not use. 5697# We try to prevent their use by monitoring invocations and raising 5698# an error when that happens. 5699set banned_procedures { strace } 5700 5701# gdb_init is called by runtest at start, but also by several 5702# tests directly; gdb_finish is only called from within runtest after 5703# each test source execution. 5704# Placing several traces by repetitive calls to gdb_init leads 5705# to problems, as only one trace is removed in gdb_finish. 5706# To overcome this possible problem, we add a variable that records 5707# if the banned variables and procedures are already traced. 5708set banned_traced 0 5709 5710# Global array that holds the name of all global variables at the time 5711# a test script is started. After the test script has completed any 5712# global not in this list is deleted. 5713array set gdb_known_globals {} 5714 5715# Setup the GDB_KNOWN_GLOBALS array with the names of all current 5716# global variables. 5717proc gdb_setup_known_globals {} { 5718 global gdb_known_globals 5719 5720 array set gdb_known_globals {} 5721 foreach varname [info globals] { 5722 set gdb_known_globals($varname) 1 5723 } 5724} 5725 5726# Cleanup the global namespace. Any global not in the 5727# GDB_KNOWN_GLOBALS array is unset, this ensures we don't "leak" 5728# globals from one test script to another. 5729proc gdb_cleanup_globals {} { 5730 global gdb_known_globals gdb_persistent_globals 5731 5732 foreach varname [info globals] { 5733 if {![info exists gdb_known_globals($varname)]} { 5734 if { [info exists gdb_persistent_globals($varname)] } { 5735 continue 5736 } 5737 uplevel #0 unset $varname 5738 } 5739 } 5740} 5741 5742# Create gdb_tcl_unknown, a copy tcl's ::unknown, provided it's present as a 5743# proc. 5744set temp [interp create] 5745if { [interp eval $temp "info procs ::unknown"] != "" } { 5746 set old_args [interp eval $temp "info args ::unknown"] 5747 set old_body [interp eval $temp "info body ::unknown"] 5748 eval proc gdb_tcl_unknown {$old_args} {$old_body} 5749} 5750interp delete $temp 5751unset temp 5752 5753# GDB implementation of ${tool}_init. Called right before executing the 5754# test-case. 5755# Overridable function -- you can override this function in your 5756# baseboard file. 5757proc gdb_init { args } { 5758 # A baseboard file overriding this proc and calling the default version 5759 # should behave the same as this proc. So, don't add code here, but to 5760 # the default version instead. 5761 return [default_gdb_init {*}$args] 5762} 5763 5764# GDB implementation of ${tool}_finish. Called right after executing the 5765# test-case. 5766proc gdb_finish { } { 5767 global gdbserver_reconnect_p 5768 global gdb_prompt 5769 global cleanfiles 5770 global known_globals 5771 5772 if { [info procs ::gdb_tcl_unknown] != "" } { 5773 # Restore dejagnu's version of proc unknown. 5774 rename ::unknown "" 5775 rename ::dejagnu_unknown ::unknown 5776 } 5777 5778 # Exit first, so that the files are no longer in use. 5779 gdb_exit 5780 5781 if { [llength $cleanfiles] > 0 } { 5782 eval remote_file target delete $cleanfiles 5783 set cleanfiles {} 5784 } 5785 5786 # Unblock write access to the banned variables. Dejagnu typically 5787 # resets some of them between testcases. 5788 global banned_variables 5789 global banned_procedures 5790 global banned_traced 5791 if ($banned_traced) { 5792 foreach banned_var $banned_variables { 5793 global "$banned_var" 5794 trace remove variable "$banned_var" write error 5795 } 5796 foreach banned_proc $banned_procedures { 5797 global "$banned_proc" 5798 trace remove execution "$banned_proc" enter error 5799 } 5800 set banned_traced 0 5801 } 5802 5803 global gdb_finish_hooks 5804 foreach gdb_finish_hook $gdb_finish_hooks { 5805 $gdb_finish_hook 5806 } 5807 set gdb_finish_hooks [list] 5808 5809 gdb_cleanup_globals 5810} 5811 5812global debug_format 5813set debug_format "unknown" 5814 5815# Run the gdb command "info source" and extract the debugging format 5816# information from the output and save it in debug_format. 5817 5818proc get_debug_format { } { 5819 global gdb_prompt 5820 global expect_out 5821 global debug_format 5822 5823 set debug_format "unknown" 5824 send_gdb "info source\n" 5825 gdb_expect 10 { 5826 -re "Compiled with (.*) debugging format.\r\n.*$gdb_prompt $" { 5827 set debug_format $expect_out(1,string) 5828 verbose "debug format is $debug_format" 5829 return 1 5830 } 5831 -re "No current source file.\r\n$gdb_prompt $" { 5832 perror "get_debug_format used when no current source file" 5833 return 0 5834 } 5835 -re "$gdb_prompt $" { 5836 warning "couldn't check debug format (no valid response)." 5837 return 1 5838 } 5839 timeout { 5840 warning "couldn't check debug format (timeout)." 5841 return 1 5842 } 5843 } 5844} 5845 5846# Return true if FORMAT matches the debug format the current test was 5847# compiled with. FORMAT is a shell-style globbing pattern; it can use 5848# `*', `[...]', and so on. 5849# 5850# This function depends on variables set by `get_debug_format', above. 5851 5852proc test_debug_format {format} { 5853 global debug_format 5854 5855 return [expr [string match $format $debug_format] != 0] 5856} 5857 5858# Like setup_xfail, but takes the name of a debug format (DWARF 1, 5859# COFF, stabs, etc). If that format matches the format that the 5860# current test was compiled with, then the next test is expected to 5861# fail for any target. Returns 1 if the next test or set of tests is 5862# expected to fail, 0 otherwise (or if it is unknown). Must have 5863# previously called get_debug_format. 5864proc setup_xfail_format { format } { 5865 set ret [test_debug_format $format] 5866 5867 if {$ret} then { 5868 setup_xfail "*-*-*" 5869 } 5870 return $ret 5871} 5872 5873# gdb_get_line_number TEXT [FILE] 5874# 5875# Search the source file FILE, and return the line number of the 5876# first line containing TEXT. If no match is found, an error is thrown. 5877# 5878# TEXT is a string literal, not a regular expression. 5879# 5880# The default value of FILE is "$srcdir/$subdir/$srcfile". If FILE is 5881# specified, and does not start with "/", then it is assumed to be in 5882# "$srcdir/$subdir". This is awkward, and can be fixed in the future, 5883# by changing the callers and the interface at the same time. 5884# In particular: gdb.base/break.exp, gdb.base/condbreak.exp, 5885# gdb.base/ena-dis-br.exp. 5886# 5887# Use this function to keep your test scripts independent of the 5888# exact line numbering of the source file. Don't write: 5889# 5890# send_gdb "break 20" 5891# 5892# This means that if anyone ever edits your test's source file, 5893# your test could break. Instead, put a comment like this on the 5894# source file line you want to break at: 5895# 5896# /* breakpoint spot: frotz.exp: test name */ 5897# 5898# and then write, in your test script (which we assume is named 5899# frotz.exp): 5900# 5901# send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n" 5902# 5903# (Yes, Tcl knows how to handle the nested quotes and brackets. 5904# Try this: 5905# $ tclsh 5906# % puts "foo [lindex "bar baz" 1]" 5907# foo baz 5908# % 5909# Tcl is quite clever, for a little stringy language.) 5910# 5911# === 5912# 5913# The previous implementation of this procedure used the gdb search command. 5914# This version is different: 5915# 5916# . It works with MI, and it also works when gdb is not running. 5917# 5918# . It operates on the build machine, not the host machine. 5919# 5920# . For now, this implementation fakes a current directory of 5921# $srcdir/$subdir to be compatible with the old implementation. 5922# This will go away eventually and some callers will need to 5923# be changed. 5924# 5925# . The TEXT argument is literal text and matches literally, 5926# not a regular expression as it was before. 5927# 5928# . State changes in gdb, such as changing the current file 5929# and setting $_, no longer happen. 5930# 5931# After a bit of time we can forget about the differences from the 5932# old implementation. 5933# 5934# --chastain 2004-08-05 5935 5936proc gdb_get_line_number { text { file "" } } { 5937 global srcdir 5938 global subdir 5939 global srcfile 5940 5941 if { "$file" == "" } then { 5942 set file "$srcfile" 5943 } 5944 if { ! [regexp "^/" "$file"] } then { 5945 set file "$srcdir/$subdir/$file" 5946 } 5947 5948 if { [ catch { set fd [open "$file"] } message ] } then { 5949 error "$message" 5950 } 5951 5952 set found -1 5953 for { set line 1 } { 1 } { incr line } { 5954 if { [ catch { set nchar [gets "$fd" body] } message ] } then { 5955 error "$message" 5956 } 5957 if { $nchar < 0 } then { 5958 break 5959 } 5960 if { [string first "$text" "$body"] >= 0 } then { 5961 set found $line 5962 break 5963 } 5964 } 5965 5966 if { [ catch { close "$fd" } message ] } then { 5967 error "$message" 5968 } 5969 5970 if {$found == -1} { 5971 error "undefined tag \"$text\"" 5972 } 5973 5974 return $found 5975} 5976 5977# Continue the program until it ends. 5978# 5979# MSSG is the error message that gets printed. If not given, a 5980# default is used. 5981# COMMAND is the command to invoke. If not given, "continue" is 5982# used. 5983# ALLOW_EXTRA is a flag indicating whether the test should expect 5984# extra output between the "Continuing." line and the program 5985# exiting. By default it is zero; if nonzero, any extra output 5986# is accepted. 5987 5988proc gdb_continue_to_end {{mssg ""} {command continue} {allow_extra 0}} { 5989 global inferior_exited_re use_gdb_stub 5990 5991 if {$mssg == ""} { 5992 set text "continue until exit" 5993 } else { 5994 set text "continue until exit at $mssg" 5995 } 5996 if {$allow_extra} { 5997 set extra ".*" 5998 } else { 5999 set extra "" 6000 } 6001 6002 # By default, we don't rely on exit() behavior of remote stubs -- 6003 # it's common for exit() to be implemented as a simple infinite 6004 # loop, or a forced crash/reset. For native targets, by default, we 6005 # assume process exit is reported as such. If a non-reliable target 6006 # is used, we set a breakpoint at exit, and continue to that. 6007 if { [target_info exists exit_is_reliable] } { 6008 set exit_is_reliable [target_info exit_is_reliable] 6009 } else { 6010 set exit_is_reliable [expr ! $use_gdb_stub] 6011 } 6012 6013 if { ! $exit_is_reliable } { 6014 if {![gdb_breakpoint "exit"]} { 6015 return 0 6016 } 6017 gdb_test $command "Continuing..*Breakpoint .*exit.*" \ 6018 $text 6019 } else { 6020 # Continue until we exit. Should not stop again. 6021 # Don't bother to check the output of the program, that may be 6022 # extremely tough for some remote systems. 6023 gdb_test $command \ 6024 "Continuing.\[\r\n0-9\]+${extra}(... EXIT code 0\[\r\n\]+|$inferior_exited_re normally).*"\ 6025 $text 6026 } 6027} 6028 6029proc rerun_to_main {} { 6030 global gdb_prompt use_gdb_stub 6031 6032 if $use_gdb_stub { 6033 gdb_run_cmd 6034 gdb_expect { 6035 -re ".*Breakpoint .*main .*$gdb_prompt $"\ 6036 {pass "rerun to main" ; return 0} 6037 -re "$gdb_prompt $"\ 6038 {fail "rerun to main" ; return 0} 6039 timeout {fail "(timeout) rerun to main" ; return 0} 6040 } 6041 } else { 6042 send_gdb "run\n" 6043 gdb_expect { 6044 -re "The program .* has been started already.*y or n. $" { 6045 send_gdb "y\n" answer 6046 exp_continue 6047 } 6048 -re "Starting program.*$gdb_prompt $"\ 6049 {pass "rerun to main" ; return 0} 6050 -re "$gdb_prompt $"\ 6051 {fail "rerun to main" ; return 0} 6052 timeout {fail "(timeout) rerun to main" ; return 0} 6053 } 6054 } 6055} 6056 6057# Return true if EXECUTABLE contains a .gdb_index or .debug_names index section. 6058 6059proc exec_has_index_section { executable } { 6060 set readelf_program [gdb_find_readelf] 6061 set res [catch {exec $readelf_program -S $executable \ 6062 | grep -E "\.gdb_index|\.debug_names" }] 6063 if { $res == 0 } { 6064 return 1 6065 } 6066 return 0 6067} 6068 6069# Return list with major and minor version of readelf, or an empty list. 6070gdb_caching_proc readelf_version { 6071 set readelf_program [gdb_find_readelf] 6072 set res [catch {exec $readelf_program --version} output] 6073 if { $res != 0 } { 6074 return [list] 6075 } 6076 set lines [split $output \n] 6077 set line [lindex $lines 0] 6078 set res [regexp {[ \t]+([0-9]+)[.]([0-9]+)[^ \t]*$} \ 6079 $line dummy major minor] 6080 if { $res != 1 } { 6081 return [list] 6082 } 6083 return [list $major $minor] 6084} 6085 6086# Return 1 if readelf prints the PIE flag, 0 if is doesn't, and -1 if unknown. 6087proc readelf_prints_pie { } { 6088 set version [readelf_version] 6089 if { [llength $version] == 0 } { 6090 return -1 6091 } 6092 set major [lindex $version 0] 6093 set minor [lindex $version 1] 6094 # It would be better to construct a PIE executable and test if the PIE 6095 # flag is printed by readelf, but we cannot reliably construct a PIE 6096 # executable if the multilib_flags dictate otherwise 6097 # (--target_board=unix/-no-pie/-fno-PIE). 6098 return [version_at_least $major $minor 2 26] 6099} 6100 6101# Return 1 if EXECUTABLE is a Position Independent Executable, 0 if it is not, 6102# and -1 if unknown. 6103 6104proc exec_is_pie { executable } { 6105 set res [readelf_prints_pie] 6106 if { $res != 1 } { 6107 return -1 6108 } 6109 set readelf_program [gdb_find_readelf] 6110 # We're not testing readelf -d | grep "FLAGS_1.*Flags:.*PIE" 6111 # because the PIE flag is not set by all versions of gold, see PR 6112 # binutils/26039. 6113 set res [catch {exec $readelf_program -h $executable} output] 6114 if { $res != 0 } { 6115 return -1 6116 } 6117 set res [regexp -line {^[ \t]*Type:[ \t]*DYN \((Position-Independent Executable|Shared object) file\)$} \ 6118 $output] 6119 if { $res == 1 } { 6120 return 1 6121 } 6122 return 0 6123} 6124 6125# Return true if a test should be skipped due to lack of floating 6126# point support or GDB can't fetch the contents from floating point 6127# registers. 6128 6129gdb_caching_proc gdb_skip_float_test { 6130 if [target_info exists gdb,skip_float_tests] { 6131 return 1 6132 } 6133 6134 # There is an ARM kernel ptrace bug that hardware VFP registers 6135 # are not updated after GDB ptrace set VFP registers. The bug 6136 # was introduced by kernel commit 8130b9d7b9d858aa04ce67805e8951e3cb6e9b2f 6137 # in 2012 and is fixed in e2dfb4b880146bfd4b6aa8e138c0205407cebbaf 6138 # in May 2016. In other words, kernels older than 4.6.3, 4.4.14, 6139 # 4.1.27, 3.18.36, and 3.14.73 have this bug. 6140 # This kernel bug is detected by check how does GDB change the 6141 # program result by changing one VFP register. 6142 if { [istarget "arm*-*-linux*"] } { 6143 6144 set compile_flags {debug nowarnings } 6145 6146 # Set up, compile, and execute a test program having VFP 6147 # operations. 6148 set src [standard_temp_file arm_vfp[pid].c] 6149 set exe [standard_temp_file arm_vfp[pid].x] 6150 6151 gdb_produce_source $src { 6152 int main() { 6153 double d = 4.0; 6154 int ret; 6155 6156 asm ("vldr d0, [%0]" : : "r" (&d)); 6157 asm ("vldr d1, [%0]" : : "r" (&d)); 6158 asm (".global break_here\n" 6159 "break_here:"); 6160 asm ("vcmp.f64 d0, d1\n" 6161 "vmrs APSR_nzcv, fpscr\n" 6162 "bne L_value_different\n" 6163 "movs %0, #0\n" 6164 "b L_end\n" 6165 "L_value_different:\n" 6166 "movs %0, #1\n" 6167 "L_end:\n" : "=r" (ret) :); 6168 6169 /* Return $d0 != $d1. */ 6170 return ret; 6171 } 6172 } 6173 6174 verbose "compiling testfile $src" 2 6175 set lines [gdb_compile $src $exe executable $compile_flags] 6176 file delete $src 6177 6178 if ![string match "" $lines] then { 6179 verbose "testfile compilation failed, returning 1" 2 6180 return 0 6181 } 6182 6183 # No error message, compilation succeeded so now run it via gdb. 6184 # Run the test up to 5 times to detect whether ptrace can 6185 # correctly update VFP registers or not. 6186 set skip_vfp_test 0 6187 for {set i 0} {$i < 5} {incr i} { 6188 global gdb_prompt srcdir subdir 6189 6190 gdb_exit 6191 gdb_start 6192 gdb_reinitialize_dir $srcdir/$subdir 6193 gdb_load "$exe" 6194 6195 runto_main 6196 gdb_test "break *break_here" 6197 gdb_continue_to_breakpoint "break_here" 6198 6199 # Modify $d0 to a different value, so the exit code should 6200 # be 1. 6201 gdb_test "set \$d0 = 5.0" 6202 6203 set test "continue to exit" 6204 gdb_test_multiple "continue" "$test" { 6205 -re "exited with code 01.*$gdb_prompt $" { 6206 } 6207 -re "exited normally.*$gdb_prompt $" { 6208 # However, the exit code is 0. That means something 6209 # wrong in setting VFP registers. 6210 set skip_vfp_test 1 6211 break 6212 } 6213 } 6214 } 6215 6216 gdb_exit 6217 remote_file build delete $exe 6218 6219 return $skip_vfp_test 6220 } 6221 return 0 6222} 6223 6224# Print a message and return true if a test should be skipped 6225# due to lack of stdio support. 6226 6227proc gdb_skip_stdio_test { msg } { 6228 if [target_info exists gdb,noinferiorio] { 6229 verbose "Skipping test '$msg': no inferior i/o." 6230 return 1 6231 } 6232 return 0 6233} 6234 6235proc gdb_skip_bogus_test { msg } { 6236 return 0 6237} 6238 6239# Return true if a test should be skipped due to lack of XML support 6240# in the host GDB. 6241# NOTE: This must be called while gdb is *not* running. 6242 6243gdb_caching_proc gdb_skip_xml_test { 6244 global gdb_spawn_id 6245 global gdb_prompt 6246 global srcdir 6247 6248 if { [info exists gdb_spawn_id] } { 6249 error "GDB must not be running in gdb_skip_xml_tests." 6250 } 6251 6252 set xml_file [gdb_remote_download host "${srcdir}/gdb.xml/trivial.xml"] 6253 6254 gdb_start 6255 set xml_missing 0 6256 gdb_test_multiple "set tdesc filename $xml_file" "" { 6257 -re ".*XML support was disabled at compile time.*$gdb_prompt $" { 6258 set xml_missing 1 6259 } 6260 -re ".*$gdb_prompt $" { } 6261 } 6262 gdb_exit 6263 return $xml_missing 6264} 6265 6266# Return true if argv[0] is available. 6267 6268gdb_caching_proc gdb_has_argv0 { 6269 set result 0 6270 6271 # Compile and execute a test program to check whether argv[0] is available. 6272 gdb_simple_compile has_argv0 { 6273 int main (int argc, char **argv) { 6274 return 0; 6275 } 6276 } executable 6277 6278 6279 # Helper proc. 6280 proc gdb_has_argv0_1 { exe } { 6281 global srcdir subdir 6282 global gdb_prompt hex 6283 6284 gdb_exit 6285 gdb_start 6286 gdb_reinitialize_dir $srcdir/$subdir 6287 gdb_load "$exe" 6288 6289 # Set breakpoint on main. 6290 gdb_test_multiple "break -q main" "break -q main" { 6291 -re "Breakpoint.*${gdb_prompt} $" { 6292 } 6293 -re "${gdb_prompt} $" { 6294 return 0 6295 } 6296 } 6297 6298 # Run to main. 6299 gdb_run_cmd 6300 gdb_test_multiple "" "run to main" { 6301 -re "Breakpoint.*${gdb_prompt} $" { 6302 } 6303 -re "${gdb_prompt} $" { 6304 return 0 6305 } 6306 } 6307 6308 set old_elements "200" 6309 set test "show print elements" 6310 gdb_test_multiple $test $test { 6311 -re "Limit on string chars or array elements to print is (\[^\r\n\]+)\\.\r\n$gdb_prompt $" { 6312 set old_elements $expect_out(1,string) 6313 } 6314 } 6315 set old_repeats "200" 6316 set test "show print repeats" 6317 gdb_test_multiple $test $test { 6318 -re "Threshold for repeated print elements is (\[^\r\n\]+)\\.\r\n$gdb_prompt $" { 6319 set old_repeats $expect_out(1,string) 6320 } 6321 } 6322 gdb_test_no_output "set print elements unlimited" "" 6323 gdb_test_no_output "set print repeats unlimited" "" 6324 6325 set retval 0 6326 # Check whether argc is 1. 6327 gdb_test_multiple "p argc" "p argc" { 6328 -re " = 1\r\n${gdb_prompt} $" { 6329 6330 gdb_test_multiple "p argv\[0\]" "p argv\[0\]" { 6331 -re " = $hex \".*[file tail $exe]\"\r\n${gdb_prompt} $" { 6332 set retval 1 6333 } 6334 -re "${gdb_prompt} $" { 6335 } 6336 } 6337 } 6338 -re "${gdb_prompt} $" { 6339 } 6340 } 6341 6342 gdb_test_no_output "set print elements $old_elements" "" 6343 gdb_test_no_output "set print repeats $old_repeats" "" 6344 6345 return $retval 6346 } 6347 6348 set result [gdb_has_argv0_1 $obj] 6349 6350 gdb_exit 6351 file delete $obj 6352 6353 if { !$result 6354 && ([istarget *-*-linux*] 6355 || [istarget *-*-freebsd*] || [istarget *-*-kfreebsd*] 6356 || [istarget *-*-netbsd*] || [istarget *-*-knetbsd*] 6357 || [istarget *-*-openbsd*] 6358 || [istarget *-*-darwin*] 6359 || [istarget *-*-solaris*] 6360 || [istarget *-*-aix*] 6361 || [istarget *-*-gnu*] 6362 || [istarget *-*-cygwin*] || [istarget *-*-mingw32*] 6363 || [istarget *-*-*djgpp*] || [istarget *-*-go32*] 6364 || [istarget *-wince-pe] || [istarget *-*-mingw32ce*] 6365 || [istarget *-*-osf*] 6366 || [istarget *-*-dicos*] 6367 || [istarget *-*-nto*] 6368 || [istarget *-*-*vms*] 6369 || [istarget *-*-lynx*178]) } { 6370 fail "argv\[0\] should be available on this target" 6371 } 6372 6373 return $result 6374} 6375 6376# Note: the procedure gdb_gnu_strip_debug will produce an executable called 6377# ${binfile}.dbglnk, which is just like the executable ($binfile) but without 6378# the debuginfo. Instead $binfile has a .gnu_debuglink section which contains 6379# the name of a debuginfo only file. This file will be stored in the same 6380# subdirectory. 6381 6382# Functions for separate debug info testing 6383 6384# starting with an executable: 6385# foo --> original executable 6386 6387# at the end of the process we have: 6388# foo.stripped --> foo w/o debug info 6389# foo.debug --> foo's debug info 6390# foo --> like foo, but with a new .gnu_debuglink section pointing to foo.debug. 6391 6392# Fetch the build id from the file. 6393# Returns "" if there is none. 6394 6395proc get_build_id { filename } { 6396 if { ([istarget "*-*-mingw*"] 6397 || [istarget *-*-cygwin*]) } { 6398 set objdump_program [gdb_find_objdump] 6399 set result [catch {set data [exec $objdump_program -p $filename | grep signature | cut "-d " -f4]} output] 6400 verbose "result is $result" 6401 verbose "output is $output" 6402 if {$result == 1} { 6403 return "" 6404 } 6405 return $data 6406 } else { 6407 set tmp [standard_output_file "${filename}-tmp"] 6408 set objcopy_program [gdb_find_objcopy] 6409 set result [catch "exec $objcopy_program -j .note.gnu.build-id -O binary $filename $tmp" output] 6410 verbose "result is $result" 6411 verbose "output is $output" 6412 if {$result == 1} { 6413 return "" 6414 } 6415 set fi [open $tmp] 6416 fconfigure $fi -translation binary 6417 # Skip the NOTE header. 6418 read $fi 16 6419 set data [read $fi] 6420 close $fi 6421 file delete $tmp 6422 if ![string compare $data ""] then { 6423 return "" 6424 } 6425 # Convert it to hex. 6426 binary scan $data H* data 6427 return $data 6428 } 6429} 6430 6431# Return the build-id hex string (usually 160 bits as 40 hex characters) 6432# converted to the form: .build-id/ab/cdef1234...89.debug 6433# Return "" if no build-id found. 6434proc build_id_debug_filename_get { filename } { 6435 set data [get_build_id $filename] 6436 if { $data == "" } { 6437 return "" 6438 } 6439 regsub {^..} $data {\0/} data 6440 return ".build-id/${data}.debug" 6441} 6442 6443# Create stripped files for DEST, replacing it. If ARGS is passed, it is a 6444# list of optional flags. The only currently supported flag is no-main, 6445# which removes the symbol entry for main from the separate debug file. 6446# 6447# Function returns zero on success. Function will return non-zero failure code 6448# on some targets not supporting separate debug info (such as i386-msdos). 6449 6450proc gdb_gnu_strip_debug { dest args } { 6451 6452 # Use the first separate debug info file location searched by GDB so the 6453 # run cannot be broken by some stale file searched with higher precedence. 6454 set debug_file "${dest}.debug" 6455 6456 set strip_to_file_program [transform strip] 6457 set objcopy_program [gdb_find_objcopy] 6458 6459 set debug_link [file tail $debug_file] 6460 set stripped_file "${dest}.stripped" 6461 6462 # Get rid of the debug info, and store result in stripped_file 6463 # something like gdb/testsuite/gdb.base/blah.stripped. 6464 set result [catch "exec $strip_to_file_program --strip-debug ${dest} -o ${stripped_file}" output] 6465 verbose "result is $result" 6466 verbose "output is $output" 6467 if {$result == 1} { 6468 return 1 6469 } 6470 6471 # Workaround PR binutils/10802: 6472 # Preserve the 'x' bit also for PIEs (Position Independent Executables). 6473 set perm [file attributes ${dest} -permissions] 6474 file attributes ${stripped_file} -permissions $perm 6475 6476 # Get rid of everything but the debug info, and store result in debug_file 6477 # This will be in the .debug subdirectory, see above. 6478 set result [catch "exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}" output] 6479 verbose "result is $result" 6480 verbose "output is $output" 6481 if {$result == 1} { 6482 return 1 6483 } 6484 6485 # If no-main is passed, strip the symbol for main from the separate 6486 # file. This is to simulate the behavior of elfutils's eu-strip, which 6487 # leaves the symtab in the original file only. There's no way to get 6488 # objcopy or strip to remove the symbol table without also removing the 6489 # debugging sections, so this is as close as we can get. 6490 if { [llength $args] == 1 && [lindex $args 0] == "no-main" } { 6491 set result [catch "exec $objcopy_program -N main ${debug_file} ${debug_file}-tmp" output] 6492 verbose "result is $result" 6493 verbose "output is $output" 6494 if {$result == 1} { 6495 return 1 6496 } 6497 file delete "${debug_file}" 6498 file rename "${debug_file}-tmp" "${debug_file}" 6499 } 6500 6501 # Link the two previous output files together, adding the .gnu_debuglink 6502 # section to the stripped_file, containing a pointer to the debug_file, 6503 # save the new file in dest. 6504 # This will be the regular executable filename, in the usual location. 6505 set result [catch "exec $objcopy_program --add-gnu-debuglink=${debug_file} ${stripped_file} ${dest}" output] 6506 verbose "result is $result" 6507 verbose "output is $output" 6508 if {$result == 1} { 6509 return 1 6510 } 6511 6512 # Workaround PR binutils/10802: 6513 # Preserve the 'x' bit also for PIEs (Position Independent Executables). 6514 set perm [file attributes ${stripped_file} -permissions] 6515 file attributes ${dest} -permissions $perm 6516 6517 return 0 6518} 6519 6520# Test the output of GDB_COMMAND matches the pattern obtained 6521# by concatenating all elements of EXPECTED_LINES. This makes 6522# it possible to split otherwise very long string into pieces. 6523# If third argument TESTNAME is not empty, it's used as the name of the 6524# test to be printed on pass/fail. 6525proc help_test_raw { gdb_command expected_lines {testname {}} } { 6526 set expected_output [join $expected_lines ""] 6527 if {$testname != {}} { 6528 gdb_test "${gdb_command}" "${expected_output}" $testname 6529 return 6530 } 6531 6532 gdb_test "${gdb_command}" "${expected_output}" 6533} 6534 6535# A regexp that matches the end of help CLASS|PREFIX_COMMAND 6536set help_list_trailer { 6537 "Type \"apropos word\" to search for commands related to \"word\"\.[\r\n]+" 6538 "Type \"apropos -v word\" for full documentation of commands related to \"word\"\.[\r\n]+" 6539 "Command name abbreviations are allowed if unambiguous\." 6540} 6541 6542# Test the output of "help COMMAND_CLASS". EXPECTED_INITIAL_LINES 6543# are regular expressions that should match the beginning of output, 6544# before the list of commands in that class. 6545# LIST_OF_COMMANDS are regular expressions that should match the 6546# list of commands in that class. If empty, the command list will be 6547# matched automatically. The presence of standard epilogue will be tested 6548# automatically. 6549# If last argument TESTNAME is not empty, it's used as the name of the 6550# test to be printed on pass/fail. 6551# Notice that the '[' and ']' characters don't need to be escaped for strings 6552# wrapped in {} braces. 6553proc test_class_help { command_class expected_initial_lines {list_of_commands {}} {testname {}} } { 6554 global help_list_trailer 6555 if {[llength $list_of_commands]>0} { 6556 set l_list_of_commands {"List of commands:[\r\n]+[\r\n]+"} 6557 set l_list_of_commands [concat $l_list_of_commands $list_of_commands] 6558 set l_list_of_commands [concat $l_list_of_commands {"[\r\n]+[\r\n]+"}] 6559 } else { 6560 set l_list_of_commands {"List of commands\:.*[\r\n]+"} 6561 } 6562 set l_stock_body { 6563 "Type \"help\" followed by command name for full documentation\.[\r\n]+" 6564 } 6565 set l_entire_body [concat $expected_initial_lines $l_list_of_commands \ 6566 $l_stock_body $help_list_trailer] 6567 6568 help_test_raw "help ${command_class}" $l_entire_body $testname 6569} 6570 6571# Like test_class_help but specialised to test "help user-defined". 6572proc test_user_defined_class_help { {list_of_commands {}} {testname {}} } { 6573 test_class_help "user-defined" { 6574 "User-defined commands\.[\r\n]+" 6575 "The commands in this class are those defined by the user\.[\r\n]+" 6576 "Use the \"define\" command to define a command\.[\r\n]+" 6577 } $list_of_commands $testname 6578} 6579 6580 6581# COMMAND_LIST should have either one element -- command to test, or 6582# two elements -- abbreviated command to test, and full command the first 6583# element is abbreviation of. 6584# The command must be a prefix command. EXPECTED_INITIAL_LINES 6585# are regular expressions that should match the beginning of output, 6586# before the list of subcommands. The presence of 6587# subcommand list and standard epilogue will be tested automatically. 6588proc test_prefix_command_help { command_list expected_initial_lines args } { 6589 global help_list_trailer 6590 set command [lindex $command_list 0] 6591 if {[llength $command_list]>1} { 6592 set full_command [lindex $command_list 1] 6593 } else { 6594 set full_command $command 6595 } 6596 # Use 'list' and not just {} because we want variables to 6597 # be expanded in this list. 6598 set l_stock_body [list\ 6599 "List of $full_command subcommands\:.*\[\r\n\]+"\ 6600 "Type \"help $full_command\" followed by $full_command subcommand name for full documentation\.\[\r\n\]+"] 6601 set l_entire_body [concat $expected_initial_lines $l_stock_body $help_list_trailer] 6602 if {[llength $args]>0} { 6603 help_test_raw "help ${command}" $l_entire_body [lindex $args 0] 6604 } else { 6605 help_test_raw "help ${command}" $l_entire_body 6606 } 6607} 6608 6609# Build executable named EXECUTABLE from specifications that allow 6610# different options to be passed to different sub-compilations. 6611# TESTNAME is the name of the test; this is passed to 'untested' if 6612# something fails. 6613# OPTIONS is passed to the final link, using gdb_compile. If OPTIONS 6614# contains the option "pthreads", then gdb_compile_pthreads is used. 6615# ARGS is a flat list of source specifications, of the form: 6616# { SOURCE1 OPTIONS1 [ SOURCE2 OPTIONS2 ]... } 6617# Each SOURCE is compiled to an object file using its OPTIONS, 6618# using gdb_compile. 6619# Returns 0 on success, -1 on failure. 6620proc build_executable_from_specs {testname executable options args} { 6621 global subdir 6622 global srcdir 6623 6624 set binfile [standard_output_file $executable] 6625 6626 set info_options "" 6627 if { [lsearch -exact $options "c++"] >= 0 } { 6628 set info_options "c++" 6629 } 6630 if [get_compiler_info ${info_options}] { 6631 return -1 6632 } 6633 6634 set func gdb_compile 6635 set func_index [lsearch -regexp $options {^(pthreads|shlib|shlib_pthreads|openmp)$}] 6636 if {$func_index != -1} { 6637 set func "${func}_[lindex $options $func_index]" 6638 } 6639 6640 # gdb_compile_shlib and gdb_compile_shlib_pthreads do not use the 3rd 6641 # parameter. They also requires $sources while gdb_compile and 6642 # gdb_compile_pthreads require $objects. Moreover they ignore any options. 6643 if [string match gdb_compile_shlib* $func] { 6644 set sources_path {} 6645 foreach {s local_options} $args { 6646 if { [regexp "^/" "$s"] } then { 6647 lappend sources_path "$s" 6648 } else { 6649 lappend sources_path "$srcdir/$subdir/$s" 6650 } 6651 } 6652 set ret [$func $sources_path "${binfile}" $options] 6653 } elseif {[lsearch -exact $options rust] != -1} { 6654 set sources_path {} 6655 foreach {s local_options} $args { 6656 if { [regexp "^/" "$s"] } then { 6657 lappend sources_path "$s" 6658 } else { 6659 lappend sources_path "$srcdir/$subdir/$s" 6660 } 6661 } 6662 set ret [gdb_compile_rust $sources_path "${binfile}" $options] 6663 } else { 6664 set objects {} 6665 set i 0 6666 foreach {s local_options} $args { 6667 if { ! [regexp "^/" "$s"] } then { 6668 set s "$srcdir/$subdir/$s" 6669 } 6670 if { [$func "${s}" "${binfile}${i}.o" object $local_options] != "" } { 6671 untested $testname 6672 return -1 6673 } 6674 lappend objects "${binfile}${i}.o" 6675 incr i 6676 } 6677 set ret [$func $objects "${binfile}" executable $options] 6678 } 6679 if { $ret != "" } { 6680 untested $testname 6681 return -1 6682 } 6683 6684 return 0 6685} 6686 6687# Build executable named EXECUTABLE, from SOURCES. If SOURCES are not 6688# provided, uses $EXECUTABLE.c. The TESTNAME paramer is the name of test 6689# to pass to untested, if something is wrong. OPTIONS are passed 6690# to gdb_compile directly. 6691proc build_executable { testname executable {sources ""} {options {debug}} } { 6692 if {[llength $sources]==0} { 6693 set sources ${executable}.c 6694 } 6695 6696 set arglist [list $testname $executable $options] 6697 foreach source $sources { 6698 lappend arglist $source $options 6699 } 6700 6701 return [eval build_executable_from_specs $arglist] 6702} 6703 6704# Starts fresh GDB binary and loads an optional executable into GDB. 6705# Usage: clean_restart [executable] 6706# EXECUTABLE is the basename of the binary. 6707# Return -1 if starting gdb or loading the executable failed. 6708 6709proc clean_restart { args } { 6710 global srcdir 6711 global subdir 6712 global errcnt 6713 global warncnt 6714 6715 if { [llength $args] > 1 } { 6716 error "bad number of args: [llength $args]" 6717 } 6718 6719 gdb_exit 6720 6721 # This is a clean restart, so reset error and warning count. 6722 set errcnt 0 6723 set warncnt 0 6724 6725 # We'd like to do: 6726 # if { [gdb_start] == -1 } { 6727 # return -1 6728 # } 6729 # but gdb_start is a ${tool}_start proc, which doesn't have a defined 6730 # return value. So instead, we test for errcnt. 6731 gdb_start 6732 if { $errcnt > 0 } { 6733 return -1 6734 } 6735 6736 gdb_reinitialize_dir $srcdir/$subdir 6737 6738 if { [llength $args] >= 1 } { 6739 set executable [lindex $args 0] 6740 set binfile [standard_output_file ${executable}] 6741 return [gdb_load ${binfile}] 6742 } 6743 6744 return 0 6745} 6746 6747# Prepares for testing by calling build_executable_full, then 6748# clean_restart. 6749# TESTNAME is the name of the test. 6750# Each element in ARGS is a list of the form 6751# { EXECUTABLE OPTIONS SOURCE_SPEC... } 6752# These are passed to build_executable_from_specs, which see. 6753# The last EXECUTABLE is passed to clean_restart. 6754# Returns 0 on success, non-zero on failure. 6755proc prepare_for_testing_full {testname args} { 6756 foreach spec $args { 6757 if {[eval build_executable_from_specs [list $testname] $spec] == -1} { 6758 return -1 6759 } 6760 set executable [lindex $spec 0] 6761 } 6762 clean_restart $executable 6763 return 0 6764} 6765 6766# Prepares for testing, by calling build_executable, and then clean_restart. 6767# Please refer to build_executable for parameter description. 6768proc prepare_for_testing { testname executable {sources ""} {options {debug}}} { 6769 6770 if {[build_executable $testname $executable $sources $options] == -1} { 6771 return -1 6772 } 6773 clean_restart $executable 6774 6775 return 0 6776} 6777 6778# Retrieve the value of EXP in the inferior, represented in format 6779# specified in FMT (using "printFMT"). DEFAULT is used as fallback if 6780# print fails. TEST is the test message to use. It can be omitted, 6781# in which case a test message is built from EXP. 6782 6783proc get_valueof { fmt exp default {test ""} } { 6784 global gdb_prompt 6785 6786 if {$test == "" } { 6787 set test "get valueof \"${exp}\"" 6788 } 6789 6790 set val ${default} 6791 gdb_test_multiple "print${fmt} ${exp}" "$test" { 6792 -re "\\$\[0-9\]* = (\[^\r\n\]*)\[\r\n\]*$gdb_prompt $" { 6793 set val $expect_out(1,string) 6794 pass "$test" 6795 } 6796 timeout { 6797 fail "$test (timeout)" 6798 } 6799 } 6800 return ${val} 6801} 6802 6803# Retrieve the value of local var EXP in the inferior. DEFAULT is used as 6804# fallback if print fails. TEST is the test message to use. It can be 6805# omitted, in which case a test message is built from EXP. 6806 6807proc get_local_valueof { exp default {test ""} } { 6808 global gdb_prompt 6809 6810 if {$test == "" } { 6811 set test "get local valueof \"${exp}\"" 6812 } 6813 6814 set val ${default} 6815 gdb_test_multiple "info locals ${exp}" "$test" { 6816 -re "$exp = (\[^\r\n\]*)\[\r\n\]*$gdb_prompt $" { 6817 set val $expect_out(1,string) 6818 pass "$test" 6819 } 6820 timeout { 6821 fail "$test (timeout)" 6822 } 6823 } 6824 return ${val} 6825} 6826 6827# Retrieve the value of EXP in the inferior, as a signed decimal value 6828# (using "print /d"). DEFAULT is used as fallback if print fails. 6829# TEST is the test message to use. It can be omitted, in which case 6830# a test message is built from EXP. 6831 6832proc get_integer_valueof { exp default {test ""} } { 6833 global gdb_prompt 6834 6835 if {$test == ""} { 6836 set test "get integer valueof \"${exp}\"" 6837 } 6838 6839 set val ${default} 6840 gdb_test_multiple "print /d ${exp}" "$test" { 6841 -re "\\$\[0-9\]* = (\[-\]*\[0-9\]*).*$gdb_prompt $" { 6842 set val $expect_out(1,string) 6843 pass "$test" 6844 } 6845 timeout { 6846 fail "$test (timeout)" 6847 } 6848 } 6849 return ${val} 6850} 6851 6852# Retrieve the value of EXP in the inferior, as an hexadecimal value 6853# (using "print /x"). DEFAULT is used as fallback if print fails. 6854# TEST is the test message to use. It can be omitted, in which case 6855# a test message is built from EXP. 6856 6857proc get_hexadecimal_valueof { exp default {test ""} } { 6858 global gdb_prompt 6859 6860 if {$test == ""} { 6861 set test "get hexadecimal valueof \"${exp}\"" 6862 } 6863 6864 set val ${default} 6865 gdb_test_multiple "print /x ${exp}" $test { 6866 -re "\\$\[0-9\]* = (0x\[0-9a-zA-Z\]+).*$gdb_prompt $" { 6867 set val $expect_out(1,string) 6868 pass "$test" 6869 } 6870 } 6871 return ${val} 6872} 6873 6874# Retrieve the size of TYPE in the inferior, as a decimal value. DEFAULT 6875# is used as fallback if print fails. TEST is the test message to use. 6876# It can be omitted, in which case a test message is 'sizeof (TYPE)'. 6877 6878proc get_sizeof { type default {test ""} } { 6879 return [get_integer_valueof "sizeof (${type})" $default $test] 6880} 6881 6882proc get_target_charset { } { 6883 global gdb_prompt 6884 6885 gdb_test_multiple "show target-charset" "" { 6886 -re "The target character set is \"auto; currently (\[^\"\]*)\".*$gdb_prompt $" { 6887 return $expect_out(1,string) 6888 } 6889 -re "The target character set is \"(\[^\"\]*)\".*$gdb_prompt $" { 6890 return $expect_out(1,string) 6891 } 6892 } 6893 6894 # Pick a reasonable default. 6895 warning "Unable to read target-charset." 6896 return "UTF-8" 6897} 6898 6899# Get the address of VAR. 6900 6901proc get_var_address { var } { 6902 global gdb_prompt hex 6903 6904 # Match output like: 6905 # $1 = (int *) 0x0 6906 # $5 = (int (*)()) 0 6907 # $6 = (int (*)()) 0x24 <function_bar> 6908 6909 gdb_test_multiple "print &${var}" "get address of ${var}" { 6910 -re "\\\$\[0-9\]+ = \\(.*\\) (0|$hex)( <${var}>)?\[\r\n\]+${gdb_prompt} $" 6911 { 6912 pass "get address of ${var}" 6913 if { $expect_out(1,string) == "0" } { 6914 return "0x0" 6915 } else { 6916 return $expect_out(1,string) 6917 } 6918 } 6919 } 6920 return "" 6921} 6922 6923# Return the frame number for the currently selected frame 6924proc get_current_frame_number {{test_name ""}} { 6925 global gdb_prompt 6926 6927 if { $test_name == "" } { 6928 set test_name "get current frame number" 6929 } 6930 set frame_num -1 6931 gdb_test_multiple "frame" $test_name { 6932 -re "#(\[0-9\]+) .*$gdb_prompt $" { 6933 set frame_num $expect_out(1,string) 6934 } 6935 } 6936 return $frame_num 6937} 6938 6939# Get the current value for remotetimeout and return it. 6940proc get_remotetimeout { } { 6941 global gdb_prompt 6942 global decimal 6943 6944 gdb_test_multiple "show remotetimeout" "" { 6945 -re "Timeout limit to wait for target to respond is ($decimal).*$gdb_prompt $" { 6946 return $expect_out(1,string) 6947 } 6948 } 6949 6950 # Pick the default that gdb uses 6951 warning "Unable to read remotetimeout" 6952 return 300 6953} 6954 6955# Set the remotetimeout to the specified timeout. Nothing is returned. 6956proc set_remotetimeout { timeout } { 6957 global gdb_prompt 6958 6959 gdb_test_multiple "set remotetimeout $timeout" "" { 6960 -re "$gdb_prompt $" { 6961 verbose "Set remotetimeout to $timeout\n" 6962 } 6963 } 6964} 6965 6966# Get the target's current endianness and return it. 6967proc get_endianness { } { 6968 global gdb_prompt 6969 6970 gdb_test_multiple "show endian" "determine endianness" { 6971 -re ".* (little|big) endian.*\r\n$gdb_prompt $" { 6972 # Pass silently. 6973 return $expect_out(1,string) 6974 } 6975 } 6976 return "little" 6977} 6978 6979# ROOT and FULL are file names. Returns the relative path from ROOT 6980# to FULL. Note that FULL must be in a subdirectory of ROOT. 6981# For example, given ROOT = /usr/bin and FULL = /usr/bin/ls, this 6982# will return "ls". 6983 6984proc relative_filename {root full} { 6985 set root_split [file split $root] 6986 set full_split [file split $full] 6987 6988 set len [llength $root_split] 6989 6990 if {[eval file join $root_split] 6991 != [eval file join [lrange $full_split 0 [expr {$len - 1}]]]} { 6992 error "$full not a subdir of $root" 6993 } 6994 6995 return [eval file join [lrange $full_split $len end]] 6996} 6997 6998# If GDB_PARALLEL exists, then set up the parallel-mode directories. 6999if {[info exists GDB_PARALLEL]} { 7000 if {[is_remote host]} { 7001 unset GDB_PARALLEL 7002 } else { 7003 file mkdir \ 7004 [make_gdb_parallel_path outputs] \ 7005 [make_gdb_parallel_path temp] \ 7006 [make_gdb_parallel_path cache] 7007 } 7008} 7009 7010proc core_find {binfile {deletefiles {}} {arg ""}} { 7011 global objdir subdir 7012 7013 set destcore "$binfile.core" 7014 file delete $destcore 7015 7016 # Create a core file named "$destcore" rather than just "core", to 7017 # avoid problems with sys admin types that like to regularly prune all 7018 # files named "core" from the system. 7019 # 7020 # Arbitrarily try setting the core size limit to "unlimited" since 7021 # this does not hurt on systems where the command does not work and 7022 # allows us to generate a core on systems where it does. 7023 # 7024 # Some systems append "core" to the name of the program; others append 7025 # the name of the program to "core"; still others (like Linux, as of 7026 # May 2003) create cores named "core.PID". In the latter case, we 7027 # could have many core files lying around, and it may be difficult to 7028 # tell which one is ours, so let's run the program in a subdirectory. 7029 set found 0 7030 set coredir [standard_output_file coredir.[getpid]] 7031 file mkdir $coredir 7032 catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >/dev/null 2>&1\"" 7033 # remote_exec host "${binfile}" 7034 foreach i "${coredir}/core ${coredir}/core.coremaker.c ${binfile}.core" { 7035 if [remote_file build exists $i] { 7036 remote_exec build "mv $i $destcore" 7037 set found 1 7038 } 7039 } 7040 # Check for "core.PID". 7041 if { $found == 0 } { 7042 set names [glob -nocomplain -directory $coredir core.*] 7043 if {[llength $names] == 1} { 7044 set corefile [file join $coredir [lindex $names 0]] 7045 remote_exec build "mv $corefile $destcore" 7046 set found 1 7047 } 7048 } 7049 if { $found == 0 } { 7050 # The braindamaged HPUX shell quits after the ulimit -c above 7051 # without executing ${binfile}. So we try again without the 7052 # ulimit here if we didn't find a core file above. 7053 # Oh, I should mention that any "braindamaged" non-Unix system has 7054 # the same problem. I like the cd bit too, it's really neat'n stuff. 7055 catch "system \"(cd ${objdir}/${subdir}; ${binfile}; true) >/dev/null 2>&1\"" 7056 foreach i "${objdir}/${subdir}/core ${objdir}/${subdir}/core.coremaker.c ${binfile}.core" { 7057 if [remote_file build exists $i] { 7058 remote_exec build "mv $i $destcore" 7059 set found 1 7060 } 7061 } 7062 } 7063 7064 # Try to clean up after ourselves. 7065 foreach deletefile $deletefiles { 7066 remote_file build delete [file join $coredir $deletefile] 7067 } 7068 remote_exec build "rmdir $coredir" 7069 7070 if { $found == 0 } { 7071 warning "can't generate a core file - core tests suppressed - check ulimit -c" 7072 return "" 7073 } 7074 return $destcore 7075} 7076 7077# gdb_target_symbol_prefix compiles a test program and then examines 7078# the output from objdump to determine the prefix (such as underscore) 7079# for linker symbol prefixes. 7080 7081gdb_caching_proc gdb_target_symbol_prefix { 7082 # Compile a simple test program... 7083 set src { int main() { return 0; } } 7084 if {![gdb_simple_compile target_symbol_prefix $src executable]} { 7085 return 0 7086 } 7087 7088 set prefix "" 7089 7090 set objdump_program [gdb_find_objdump] 7091 set result [catch "exec $objdump_program --syms $obj" output] 7092 7093 if { $result == 0 \ 7094 && ![regexp -lineanchor \ 7095 { ([^ a-zA-Z0-9]*)main$} $output dummy prefix] } { 7096 verbose "gdb_target_symbol_prefix: Could not find main in objdump output; returning null prefix" 2 7097 } 7098 7099 file delete $obj 7100 7101 return $prefix 7102} 7103 7104# Return 1 if target supports scheduler locking, otherwise return 0. 7105 7106gdb_caching_proc target_supports_scheduler_locking { 7107 global gdb_prompt 7108 7109 set me "gdb_target_supports_scheduler_locking" 7110 7111 set src { int main() { return 0; } } 7112 if {![gdb_simple_compile $me $src executable]} { 7113 return 0 7114 } 7115 7116 clean_restart $obj 7117 if ![runto_main] { 7118 return 0 7119 } 7120 7121 set supports_schedule_locking -1 7122 set current_schedule_locking_mode "" 7123 7124 set test "reading current scheduler-locking mode" 7125 gdb_test_multiple "show scheduler-locking" $test { 7126 -re "Mode for locking scheduler during execution is \"(\[\^\"\]*)\".*$gdb_prompt" { 7127 set current_schedule_locking_mode $expect_out(1,string) 7128 } 7129 -re "$gdb_prompt $" { 7130 set supports_schedule_locking 0 7131 } 7132 timeout { 7133 set supports_schedule_locking 0 7134 } 7135 } 7136 7137 if { $supports_schedule_locking == -1 } { 7138 set test "checking for scheduler-locking support" 7139 gdb_test_multiple "set scheduler-locking $current_schedule_locking_mode" $test { 7140 -re "Target '\[^'\]+' cannot support this command\..*$gdb_prompt $" { 7141 set supports_schedule_locking 0 7142 } 7143 -re "$gdb_prompt $" { 7144 set supports_schedule_locking 1 7145 } 7146 timeout { 7147 set supports_schedule_locking 0 7148 } 7149 } 7150 } 7151 7152 if { $supports_schedule_locking == -1 } { 7153 set supports_schedule_locking 0 7154 } 7155 7156 gdb_exit 7157 remote_file build delete $obj 7158 verbose "$me: returning $supports_schedule_locking" 2 7159 return $supports_schedule_locking 7160} 7161 7162# Return 1 if compiler supports use of nested functions. Otherwise, 7163# return 0. 7164 7165gdb_caching_proc support_nested_function_tests { 7166 # Compile a test program containing a nested function 7167 return [gdb_can_simple_compile nested_func { 7168 int main () { 7169 int foo () { 7170 return 0; 7171 } 7172 return foo (); 7173 } 7174 } executable] 7175} 7176 7177# gdb_target_symbol returns the provided symbol with the correct prefix 7178# prepended. (See gdb_target_symbol_prefix, above.) 7179 7180proc gdb_target_symbol { symbol } { 7181 set prefix [gdb_target_symbol_prefix] 7182 return "${prefix}${symbol}" 7183} 7184 7185# gdb_target_symbol_prefix_flags_asm returns a string that can be 7186# added to gdb_compile options to define the C-preprocessor macro 7187# SYMBOL_PREFIX with a value that can be prepended to symbols 7188# for targets which require a prefix, such as underscore. 7189# 7190# This version (_asm) defines the prefix without double quotes 7191# surrounding the prefix. It is used to define the macro 7192# SYMBOL_PREFIX for assembly language files. Another version, below, 7193# is used for symbols in inline assembler in C/C++ files. 7194# 7195# The lack of quotes in this version (_asm) makes it possible to 7196# define supporting macros in the .S file. (The version which 7197# uses quotes for the prefix won't work for such files since it's 7198# impossible to define a quote-stripping macro in C.) 7199# 7200# It's possible to use this version (_asm) for C/C++ source files too, 7201# but a string is usually required in such files; providing a version 7202# (no _asm) which encloses the prefix with double quotes makes it 7203# somewhat easier to define the supporting macros in the test case. 7204 7205proc gdb_target_symbol_prefix_flags_asm {} { 7206 set prefix [gdb_target_symbol_prefix] 7207 if {$prefix ne ""} { 7208 return "additional_flags=-DSYMBOL_PREFIX=$prefix" 7209 } else { 7210 return ""; 7211 } 7212} 7213 7214# gdb_target_symbol_prefix_flags returns the same string as 7215# gdb_target_symbol_prefix_flags_asm, above, but with the prefix 7216# enclosed in double quotes if there is a prefix. 7217# 7218# See the comment for gdb_target_symbol_prefix_flags_asm for an 7219# extended discussion. 7220 7221proc gdb_target_symbol_prefix_flags {} { 7222 set prefix [gdb_target_symbol_prefix] 7223 if {$prefix ne ""} { 7224 return "additional_flags=-DSYMBOL_PREFIX=\"$prefix\"" 7225 } else { 7226 return ""; 7227 } 7228} 7229 7230# A wrapper for 'remote_exec host' that passes or fails a test. 7231# Returns 0 if all went well, nonzero on failure. 7232# TEST is the name of the test, other arguments are as for remote_exec. 7233 7234proc run_on_host { test program args } { 7235 verbose -log "run_on_host: $program $args" 7236 # remote_exec doesn't work properly if the output is set but the 7237 # input is the empty string -- so replace an empty input with 7238 # /dev/null. 7239 if {[llength $args] > 1 && [lindex $args 1] == ""} { 7240 set args [lreplace $args 1 1 "/dev/null"] 7241 } 7242 set result [eval remote_exec host [list $program] $args] 7243 verbose "result is $result" 7244 set status [lindex $result 0] 7245 set output [lindex $result 1] 7246 if {$status == 0} { 7247 pass $test 7248 return 0 7249 } else { 7250 verbose -log "run_on_host failed: $output" 7251 if { $output == "spawn failed" } { 7252 unsupported $test 7253 } else { 7254 fail $test 7255 } 7256 return -1 7257 } 7258} 7259 7260# Return non-zero if "board_info debug_flags" mentions Fission. 7261# http://gcc.gnu.org/wiki/DebugFission 7262# Fission doesn't support everything yet. 7263# This supports working around bug 15954. 7264 7265proc using_fission { } { 7266 set debug_flags [board_info [target_info name] debug_flags] 7267 return [regexp -- "-gsplit-dwarf" $debug_flags] 7268} 7269 7270# Search the caller's ARGS list and set variables according to the list of 7271# valid options described by ARGSET. 7272# 7273# The first member of each one- or two-element list in ARGSET defines the 7274# name of a variable that will be added to the caller's scope. 7275# 7276# If only one element is given to describe an option, it the value is 7277# 0 if the option is not present in (the caller's) ARGS or 1 if 7278# it is. 7279# 7280# If two elements are given, the second element is the default value of 7281# the variable. This is then overwritten if the option exists in ARGS. 7282# 7283# Any parse_args elements in (the caller's) ARGS will be removed, leaving 7284# any optional components. 7285 7286# Example: 7287# proc myproc {foo args} { 7288# parse_args {{bar} {baz "abc"} {qux}} 7289# # ... 7290# } 7291# myproc ABC -bar -baz DEF peanut butter 7292# will define the following variables in myproc: 7293# foo (=ABC), bar (=1), baz (=DEF), and qux (=0) 7294# args will be the list {peanut butter} 7295 7296proc parse_args { argset } { 7297 upvar args args 7298 7299 foreach argument $argset { 7300 if {[llength $argument] == 1} { 7301 # No default specified, so we assume that we should set 7302 # the value to 1 if the arg is present and 0 if it's not. 7303 # It is assumed that no value is given with the argument. 7304 set result [lsearch -exact $args "-$argument"] 7305 if {$result != -1} then { 7306 uplevel 1 [list set $argument 1] 7307 set args [lreplace $args $result $result] 7308 } else { 7309 uplevel 1 [list set $argument 0] 7310 } 7311 } elseif {[llength $argument] == 2} { 7312 # There are two items in the argument. The second is a 7313 # default value to use if the item is not present. 7314 # Otherwise, the variable is set to whatever is provided 7315 # after the item in the args. 7316 set arg [lindex $argument 0] 7317 set result [lsearch -exact $args "-[lindex $arg 0]"] 7318 if {$result != -1} then { 7319 uplevel 1 [list set $arg [lindex $args [expr $result+1]]] 7320 set args [lreplace $args $result [expr $result+1]] 7321 } else { 7322 uplevel 1 [list set $arg [lindex $argument 1]] 7323 } 7324 } else { 7325 error "Badly formatted argument \"$argument\" in argument set" 7326 } 7327 } 7328 7329 # The remaining args should be checked to see that they match the 7330 # number of items expected to be passed into the procedure... 7331} 7332 7333# Capture the output of COMMAND in a string ignoring PREFIX (a regexp); 7334# return that string. 7335 7336proc capture_command_output { command prefix } { 7337 global gdb_prompt 7338 global expect_out 7339 7340 set output_string "" 7341 gdb_test_multiple "$command" "capture_command_output for $command" { 7342 -re "[string_to_regexp ${command}]\[\r\n\]+${prefix}(.*)\[\r\n\]+$gdb_prompt $" { 7343 set output_string $expect_out(1,string) 7344 } 7345 } 7346 return $output_string 7347} 7348 7349# A convenience function that joins all the arguments together, with a 7350# regexp that matches exactly one end of line in between each argument. 7351# This function is ideal to write the expected output of a GDB command 7352# that generates more than a couple of lines, as this allows us to write 7353# each line as a separate string, which is easier to read by a human 7354# being. 7355 7356proc multi_line { args } { 7357 if { [llength $args] == 1 } { 7358 set hint "forgot {*} before list argument?" 7359 error "multi_line called with one argument ($hint)" 7360 } 7361 return [join $args "\r\n"] 7362} 7363 7364# Similar to the above, but while multi_line is meant to be used to 7365# match GDB output, this one is meant to be used to build strings to 7366# send as GDB input. 7367 7368proc multi_line_input { args } { 7369 return [join $args "\n"] 7370} 7371 7372# Return the version of the DejaGnu framework. 7373# 7374# The return value is a list containing the major, minor and patch version 7375# numbers. If the version does not contain a minor or patch number, they will 7376# be set to 0. For example: 7377# 7378# 1.6 -> {1 6 0} 7379# 1.6.1 -> {1 6 1} 7380# 2 -> {2 0 0} 7381 7382proc dejagnu_version { } { 7383 # The frame_version variable is defined by DejaGnu, in runtest.exp. 7384 global frame_version 7385 7386 verbose -log "DejaGnu version: $frame_version" 7387 verbose -log "Expect version: [exp_version]" 7388 verbose -log "Tcl version: [info tclversion]" 7389 7390 set dg_ver [split $frame_version .] 7391 7392 while { [llength $dg_ver] < 3 } { 7393 lappend dg_ver 0 7394 } 7395 7396 return $dg_ver 7397} 7398 7399# Define user-defined command COMMAND using the COMMAND_LIST as the 7400# command's definition. The terminating "end" is added automatically. 7401 7402proc gdb_define_cmd {command command_list} { 7403 global gdb_prompt 7404 7405 set input [multi_line_input {*}$command_list "end"] 7406 set test "define $command" 7407 7408 gdb_test_multiple "define $command" $test { 7409 -re "End with" { 7410 gdb_test_multiple $input $test { 7411 -re "\r\n$gdb_prompt " { 7412 } 7413 } 7414 } 7415 } 7416} 7417 7418# Override the 'cd' builtin with a version that ensures that the 7419# log file keeps pointing at the same file. We need this because 7420# unfortunately the path to the log file is recorded using an 7421# relative path name, and, we sometimes need to close/reopen the log 7422# after changing the current directory. See get_compiler_info. 7423 7424rename cd builtin_cd 7425 7426proc cd { dir } { 7427 7428 # Get the existing log file flags. 7429 set log_file_info [log_file -info] 7430 7431 # Split the flags into args and file name. 7432 set log_file_flags "" 7433 set log_file_file "" 7434 foreach arg [ split "$log_file_info" " "] { 7435 if [string match "-*" $arg] { 7436 lappend log_file_flags $arg 7437 } else { 7438 lappend log_file_file $arg 7439 } 7440 } 7441 7442 # If there was an existing file, ensure it is an absolute path, and then 7443 # reset logging. 7444 if { $log_file_file != "" } { 7445 set log_file_file [file normalize $log_file_file] 7446 log_file 7447 log_file $log_file_flags "$log_file_file" 7448 } 7449 7450 # Call the builtin version of cd. 7451 builtin_cd $dir 7452} 7453 7454# Return a list of all languages supported by GDB, suitable for use in 7455# 'set language NAME'. This doesn't include either the 'local' or 7456# 'auto' keywords. 7457proc gdb_supported_languages {} { 7458 return [list c objective-c c++ d go fortran modula-2 asm pascal \ 7459 opencl rust minimal ada] 7460} 7461 7462# Check if debugging is enabled for gdb. 7463 7464proc gdb_debug_enabled { } { 7465 global gdbdebug 7466 7467 # If not already read, get the debug setting from environment or board setting. 7468 if {![info exists gdbdebug]} { 7469 global env 7470 if [info exists env(GDB_DEBUG)] { 7471 set gdbdebug $env(GDB_DEBUG) 7472 } elseif [target_info exists gdb,debug] { 7473 set gdbdebug [target_info gdb,debug] 7474 } else { 7475 return 0 7476 } 7477 } 7478 7479 # Ensure it not empty. 7480 return [expr { $gdbdebug != "" }] 7481} 7482 7483# Turn on debugging if enabled, or reset if already on. 7484 7485proc gdb_debug_init { } { 7486 7487 global gdb_prompt 7488 7489 if ![gdb_debug_enabled] { 7490 return; 7491 } 7492 7493 # First ensure logging is off. 7494 send_gdb "set logging off\n" 7495 7496 set debugfile [standard_output_file gdb.debug] 7497 send_gdb "set logging file $debugfile\n" 7498 7499 send_gdb "set logging debugredirect\n" 7500 7501 global gdbdebug 7502 foreach entry [split $gdbdebug ,] { 7503 send_gdb "set debug $entry 1\n" 7504 } 7505 7506 # Now that everything is set, enable logging. 7507 send_gdb "set logging on\n" 7508 gdb_expect 10 { 7509 -re "Copying output to $debugfile.*Redirecting debug output to $debugfile.*$gdb_prompt $" {} 7510 timeout { warning "Couldn't set logging file" } 7511 } 7512} 7513 7514# Check if debugging is enabled for gdbserver. 7515 7516proc gdbserver_debug_enabled { } { 7517 # Always disabled for GDB only setups. 7518 return 0 7519} 7520 7521# Open the file for logging gdb input 7522 7523proc gdb_stdin_log_init { } { 7524 gdb_persistent_global in_file 7525 7526 if {[info exists in_file]} { 7527 # Close existing file. 7528 catch "close $in_file" 7529 } 7530 7531 set logfile [standard_output_file_with_gdb_instance gdb.in] 7532 set in_file [open $logfile w] 7533} 7534 7535# Write to the file for logging gdb input. 7536# TYPE can be one of the following: 7537# "standard" : Default. Standard message written to the log 7538# "answer" : Answer to a question (eg "Y"). Not written the log. 7539# "optional" : Optional message. Not written to the log. 7540 7541proc gdb_stdin_log_write { message {type standard} } { 7542 7543 global in_file 7544 if {![info exists in_file]} { 7545 return 7546 } 7547 7548 # Check message types. 7549 switch -regexp -- $type { 7550 "answer" { 7551 return 7552 } 7553 "optional" { 7554 return 7555 } 7556 } 7557 7558 # Write to the log and make sure the output is there, even in case 7559 # of crash. 7560 puts -nonewline $in_file "$message" 7561 flush $in_file 7562} 7563 7564# Write the command line used to invocate gdb to the cmd file. 7565 7566proc gdb_write_cmd_file { cmdline } { 7567 set logfile [standard_output_file_with_gdb_instance gdb.cmd] 7568 set cmd_file [open $logfile w] 7569 puts $cmd_file $cmdline 7570 catch "close $cmd_file" 7571} 7572 7573# Compare contents of FILE to string STR. Pass with MSG if equal, otherwise 7574# fail with MSG. 7575 7576proc cmp_file_string { file str msg } { 7577 if { ![file exists $file]} { 7578 fail "$msg" 7579 return 7580 } 7581 7582 set caught_error [catch { 7583 set fp [open "$file" r] 7584 set file_contents [read $fp] 7585 close $fp 7586 } error_message] 7587 if { $caught_error } then { 7588 error "$error_message" 7589 fail "$msg" 7590 return 7591 } 7592 7593 if { $file_contents == $str } { 7594 pass "$msg" 7595 } else { 7596 fail "$msg" 7597 } 7598} 7599 7600# Does the compiler support CTF debug output using '-gt' compiler 7601# flag? If not then we should skip these tests. We should also 7602# skip them if libctf was explicitly disabled. 7603 7604gdb_caching_proc skip_ctf_tests { 7605 global enable_libctf 7606 7607 if {$enable_libctf eq "no"} { 7608 return 1 7609 } 7610 7611 set can_ctf [gdb_can_simple_compile ctfdebug { 7612 int main () { 7613 return 0; 7614 } 7615 } executable "additional_flags=-gt"] 7616 7617 return [expr {!$can_ctf}] 7618} 7619 7620# Return 1 if compiler supports -gstatement-frontiers. Otherwise, 7621# return 0. 7622 7623gdb_caching_proc supports_statement_frontiers { 7624 return [gdb_can_simple_compile supports_statement_frontiers { 7625 int main () { 7626 return 0; 7627 } 7628 } executable "additional_flags=-gstatement-frontiers"] 7629} 7630 7631# Return 1 if compiler supports -mmpx -fcheck-pointer-bounds. Otherwise, 7632# return 0. 7633 7634gdb_caching_proc supports_mpx_check_pointer_bounds { 7635 set flags "additional_flags=-mmpx additional_flags=-fcheck-pointer-bounds" 7636 return [gdb_can_simple_compile supports_mpx_check_pointer_bounds { 7637 int main () { 7638 return 0; 7639 } 7640 } executable $flags] 7641} 7642 7643# Return 1 if compiler supports -fcf-protection=. Otherwise, 7644# return 0. 7645 7646gdb_caching_proc supports_fcf_protection { 7647 return [gdb_can_simple_compile supports_fcf_protection { 7648 int main () { 7649 return 0; 7650 } 7651 } executable "additional_flags=-fcf-protection=full"] 7652} 7653 7654# Return 1 if symbols were read in using -readnow. Otherwise, return 0. 7655 7656proc readnow { args } { 7657 if { [llength $args] == 1 } { 7658 set re [lindex $args 0] 7659 } else { 7660 set re "" 7661 } 7662 7663 set readnow_p 0 7664 # Given the listing from the following command can be very verbose, match 7665 # the patterns line-by-line. This prevents timeouts from waiting for 7666 # too much data to come at once. 7667 set cmd "maint print objfiles $re" 7668 gdb_test_multiple $cmd "" -lbl { 7669 -re "\r\n.gdb_index: faked for \"readnow\"" { 7670 # Record the we've seen the above pattern. 7671 set readnow_p 1 7672 exp_continue 7673 } 7674 -re -wrap "" { 7675 # We don't care about any other input. 7676 } 7677 } 7678 7679 return $readnow_p 7680} 7681 7682# Return index name if symbols were read in using an index. 7683# Otherwise, return "". 7684 7685proc have_index { objfile } { 7686 7687 set res "" 7688 set cmd "maint print objfiles $objfile" 7689 gdb_test_multiple $cmd "" -lbl { 7690 -re "\r\n.gdb_index: faked for \"readnow\"" { 7691 set res "" 7692 exp_continue 7693 } 7694 -re "\r\n.gdb_index:" { 7695 set res "gdb_index" 7696 exp_continue 7697 } 7698 -re "\r\n.debug_names:" { 7699 set res "debug_names" 7700 exp_continue 7701 } 7702 -re -wrap "" { 7703 # We don't care about any other input. 7704 } 7705 } 7706 7707 return $res 7708} 7709 7710# Return 1 if partial symbols are available. Otherwise, return 0. 7711 7712proc psymtabs_p { } { 7713 global gdb_prompt 7714 7715 set cmd "maint info psymtab" 7716 gdb_test_multiple $cmd "" { 7717 -re "$cmd\r\n$gdb_prompt $" { 7718 return 0 7719 } 7720 -re -wrap "" { 7721 return 1 7722 } 7723 } 7724 7725 return 0 7726} 7727 7728# Verify that partial symtab expansion for $filename has state $readin. 7729 7730proc verify_psymtab_expanded { filename readin } { 7731 global gdb_prompt 7732 7733 set cmd "maint info psymtab" 7734 set test "$cmd: $filename: $readin" 7735 set re [multi_line \ 7736 " \{ psymtab \[^\r\n\]*$filename\[^\r\n\]*" \ 7737 " readin $readin" \ 7738 ".*"] 7739 7740 gdb_test_multiple $cmd $test { 7741 -re "$cmd\r\n$gdb_prompt $" { 7742 unsupported $gdb_test_name 7743 } 7744 -re -wrap $re { 7745 pass $gdb_test_name 7746 } 7747 } 7748} 7749 7750# Add a .gdb_index section to PROGRAM. 7751# PROGRAM is assumed to be the output of standard_output_file. 7752# Returns the 0 if there is a failure, otherwise 1. 7753# 7754# STYLE controls which style of index to add, if needed. The empty 7755# string (the default) means .gdb_index; "-dwarf-5" means .debug_names. 7756 7757proc add_gdb_index { program {style ""} } { 7758 global srcdir GDB env BUILD_DATA_DIRECTORY 7759 set contrib_dir "$srcdir/../contrib" 7760 set env(GDB) "$GDB --data-directory=$BUILD_DATA_DIRECTORY" 7761 set result [catch "exec $contrib_dir/gdb-add-index.sh $style $program" output] 7762 if { $result != 0 } { 7763 verbose -log "result is $result" 7764 verbose -log "output is $output" 7765 return 0 7766 } 7767 7768 return 1 7769} 7770 7771# Add a .gdb_index section to PROGRAM, unless it alread has an index 7772# (.gdb_index/.debug_names). Gdb doesn't support building an index from a 7773# program already using one. Return 1 if a .gdb_index was added, return 0 7774# if it already contained an index, and -1 if an error occurred. 7775# 7776# STYLE controls which style of index to add, if needed. The empty 7777# string (the default) means .gdb_index; "-dwarf-5" means .debug_names. 7778 7779proc ensure_gdb_index { binfile {style ""} } { 7780 set testfile [file tail $binfile] 7781 set test "check if index present" 7782 gdb_test_multiple "mt print objfiles ${testfile}" $test { 7783 -re -wrap "gdb_index.*" { 7784 return 0 7785 } 7786 -re -wrap "debug_names.*" { 7787 return 0 7788 } 7789 -re -wrap "Psymtabs.*" { 7790 if { [add_gdb_index $binfile $style] != "1" } { 7791 return -1 7792 } 7793 return 1 7794 } 7795 } 7796 return -1 7797} 7798 7799# Return 1 if executable contains .debug_types section. Otherwise, return 0. 7800 7801proc debug_types { } { 7802 global hex 7803 7804 set cmd "maint info sections" 7805 gdb_test_multiple $cmd "" { 7806 -re -wrap "at $hex: .debug_types.*" { 7807 return 1 7808 } 7809 -re -wrap "" { 7810 return 0 7811 } 7812 } 7813 7814 return 0 7815} 7816 7817# Return the addresses in the line table for FILE for which is_stmt is true. 7818 7819proc is_stmt_addresses { file } { 7820 global decimal 7821 global hex 7822 7823 set is_stmt [list] 7824 7825 gdb_test_multiple "maint info line-table $file" "" { 7826 -re "\r\n$decimal\[ \t\]+$decimal\[ \t\]+($hex)\[ \t\]+Y\[^\r\n\]*" { 7827 lappend is_stmt $expect_out(1,string) 7828 exp_continue 7829 } 7830 -re -wrap "" { 7831 } 7832 } 7833 7834 return $is_stmt 7835} 7836 7837# Return 1 if hex number VAL is an element of HEXLIST. 7838 7839proc hex_in_list { val hexlist } { 7840 # Normalize val by removing 0x prefix, and leading zeros. 7841 set val [regsub ^0x $val ""] 7842 set val [regsub ^0+ $val "0"] 7843 7844 set re 0x0*$val 7845 set index [lsearch -regexp $hexlist $re] 7846 return [expr $index != -1] 7847} 7848 7849# Override proc NAME to proc OVERRIDE for the duration of the execution of 7850# BODY. 7851 7852proc with_override { name override body } { 7853 # Implementation note: It's possible to implement the override using 7854 # rename, like this: 7855 # rename $name save_$name 7856 # rename $override $name 7857 # set code [catch {uplevel 1 $body} result] 7858 # rename $name $override 7859 # rename save_$name $name 7860 # but there are two issues here: 7861 # - the save_$name might clash with an existing proc 7862 # - the override is no longer available under its original name during 7863 # the override 7864 # So, we use this more elaborate but cleaner mechanism. 7865 7866 # Save the old proc. 7867 set old_args [info args $name] 7868 set old_body [info body $name] 7869 7870 # Install the override. 7871 set new_args [info args $override] 7872 set new_body [info body $override] 7873 eval proc $name {$new_args} {$new_body} 7874 7875 # Execute body. 7876 set code [catch {uplevel 1 $body} result] 7877 7878 # Restore old proc. 7879 eval proc $name {$old_args} {$old_body} 7880 7881 # Return as appropriate. 7882 if { $code == 1 } { 7883 global errorInfo errorCode 7884 return -code error -errorinfo $errorInfo -errorcode $errorCode $result 7885 } elseif { $code > 1 } { 7886 return -code $code $result 7887 } 7888 7889 return $result 7890} 7891 7892# Setup tuiterm.exp environment. To be used in test-cases instead of 7893# "load_lib tuiterm.exp". Calls initialization function and schedules 7894# finalization function. 7895proc tuiterm_env { } { 7896 load_lib tuiterm.exp 7897} 7898 7899# Dejagnu has a version of note, but usage is not allowed outside of dejagnu. 7900# Define a local version. 7901proc gdb_note { message } { 7902 verbose -- "NOTE: $message" 0 7903} 7904 7905# Return 1 if compiler supports -fuse-ld=gold, otherwise return 0. 7906gdb_caching_proc have_fuse_ld_gold { 7907 set me "have_fuse_ld_gold" 7908 set flags "additional_flags=-fuse-ld=gold" 7909 set src { int main() { return 0; } } 7910 return [gdb_simple_compile $me $src executable $flags] 7911} 7912 7913# Return 1 if compiler supports scalar_storage_order attribute, otherwise 7914# return 0. 7915gdb_caching_proc supports_scalar_storage_order_attribute { 7916 set me "supports_scalar_storage_order_attribute" 7917 set src { 7918 #include <string.h> 7919 struct sle { 7920 int v; 7921 } __attribute__((scalar_storage_order("little-endian"))); 7922 struct sbe { 7923 int v; 7924 } __attribute__((scalar_storage_order("big-endian"))); 7925 struct sle sle; 7926 struct sbe sbe; 7927 int main () { 7928 sle.v = sbe.v = 0x11223344; 7929 int same = memcmp (&sle, &sbe, sizeof (int)) == 0; 7930 int sso = !same; 7931 return sso; 7932 } 7933 } 7934 if { ![gdb_simple_compile $me $src executable ""] } { 7935 return 0 7936 } 7937 7938 set result [remote_exec target $obj] 7939 set status [lindex $result 0] 7940 set output [lindex $result 1] 7941 if { $output != "" } { 7942 return 0 7943 } 7944 7945 return $status 7946} 7947 7948# Return 1 if compiler supports __GNUC__, otherwise return 0. 7949gdb_caching_proc supports_gnuc { 7950 set me "supports_gnuc" 7951 set src { 7952 #ifndef __GNUC__ 7953 #error "No gnuc" 7954 #endif 7955 } 7956 return [gdb_simple_compile $me $src object ""] 7957} 7958 7959# Return 1 if target supports mpx, otherwise return 0. 7960gdb_caching_proc have_mpx { 7961 global srcdir 7962 7963 set me "have_mpx" 7964 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 7965 verbose "$me: target does not support mpx, returning 0" 2 7966 return 0 7967 } 7968 7969 # Compile a test program. 7970 set src { 7971 #include "nat/x86-cpuid.h" 7972 7973 int main() { 7974 unsigned int eax, ebx, ecx, edx; 7975 7976 if (!__get_cpuid (1, &eax, &ebx, &ecx, &edx)) 7977 return 0; 7978 7979 if ((ecx & bit_OSXSAVE) == bit_OSXSAVE) 7980 { 7981 if (__get_cpuid_max (0, (void *)0) < 7) 7982 return 0; 7983 7984 __cpuid_count (7, 0, eax, ebx, ecx, edx); 7985 7986 if ((ebx & bit_MPX) == bit_MPX) 7987 return 1; 7988 7989 } 7990 return 0; 7991 } 7992 } 7993 set compile_flags "incdir=${srcdir}/.." 7994 if {![gdb_simple_compile $me $src executable $compile_flags]} { 7995 return 0 7996 } 7997 7998 set result [remote_exec target $obj] 7999 set status [lindex $result 0] 8000 set output [lindex $result 1] 8001 if { $output != "" } { 8002 set status 0 8003 } 8004 8005 remote_file build delete $obj 8006 8007 verbose "$me: returning $status" 2 8008 return $status 8009} 8010 8011# Return 1 if target supports avx, otherwise return 0. 8012gdb_caching_proc have_avx { 8013 global srcdir 8014 8015 set me "have_avx" 8016 if { ![istarget "i?86-*-*"] && ![istarget "x86_64-*-*"] } { 8017 verbose "$me: target does not support avx, returning 0" 2 8018 return 0 8019 } 8020 8021 # Compile a test program. 8022 set src { 8023 #include "nat/x86-cpuid.h" 8024 8025 int main() { 8026 unsigned int eax, ebx, ecx, edx; 8027 8028 if (!x86_cpuid (1, &eax, &ebx, &ecx, &edx)) 8029 return 0; 8030 8031 if ((ecx & (bit_AVX | bit_OSXSAVE)) == (bit_AVX | bit_OSXSAVE)) 8032 return 1; 8033 else 8034 return 0; 8035 } 8036 } 8037 set compile_flags "incdir=${srcdir}/.." 8038 if {![gdb_simple_compile $me $src executable $compile_flags]} { 8039 return 0 8040 } 8041 8042 set result [remote_exec target $obj] 8043 set status [lindex $result 0] 8044 set output [lindex $result 1] 8045 if { $output != "" } { 8046 set status 0 8047 } 8048 8049 remote_file build delete $obj 8050 8051 verbose "$me: returning $status" 2 8052 return $status 8053} 8054 8055# Always load compatibility stuff. 8056load_lib future.exp 8057