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