1# Copyright (C) 1997-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 GCC; see the file COPYING3. If not see 15# <http://www.gnu.org/licenses/>. 16 17load_lib dg.exp 18load_lib file-format.exp 19load_lib target-supports.exp 20load_lib target-supports-dg.exp 21load_lib scanasm.exp 22load_lib scanrtl.exp 23load_lib scantree.exp 24load_lib scanltranstree.exp 25load_lib scanipa.exp 26load_lib scanwpaipa.exp 27load_lib scanlang.exp 28load_lib timeout.exp 29load_lib timeout-dg.exp 30load_lib prune.exp 31load_lib libgloss.exp 32load_lib target-libpath.exp 33load_lib torture-options.exp 34load_lib fortran-modules.exp 35load_lib multiline.exp 36 37# We set LC_ALL and LANG to C so that we get the same error messages as expected. 38setenv LC_ALL C 39setenv LANG C 40 41# Many hosts now default to a non-ASCII C locale, however, so 42# they can set a charset encoding here if they need. 43if { [ishost "*-*-cygwin*"] } { 44 setenv LC_ALL C.ASCII 45 setenv LANG C.ASCII 46} 47 48# Avoid sporadic data-losses with expect 49match_max -d 10000 50 51# Ensure GCC_COLORS is unset, for the rare testcases that verify 52# how output is colorized. 53if [info exists ::env(GCC_COLORS) ] { 54 unsetenv GCC_COLORS 55} 56 57global GCC_UNDER_TEST 58if ![info exists GCC_UNDER_TEST] { 59 set GCC_UNDER_TEST "[find_gcc]" 60} 61 62# This file may be sourced, so don't override environment settings 63# that have been previously setup. 64if { $orig_environment_saved == 0 } { 65 append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] 66 set_ld_library_path_env_vars 67} 68 69# Some torture-options cause intermediate code output, unusable for 70# testing using e.g. scan-assembler. In this variable are the options 71# how to force it, when needed. 72global gcc_force_conventional_output 73set gcc_force_conventional_output "" 74 75set LTO_TORTURE_OPTIONS "" 76if [info exists TORTURE_OPTIONS] { 77 set DG_TORTURE_OPTIONS $TORTURE_OPTIONS 78} else { 79 # It is theoretically beneficial to group all of the O2/O3 options together, 80 # as in many cases the compiler will generate identical executables for 81 # all of them--and the c-torture testsuite will skip testing identical 82 # executables multiple times. 83 # Also note that -finline-functions is explicitly included in one of the 84 # items below, even though -O3 is also specified, because some ports may 85 # choose to disable inlining functions by default, even when optimizing. 86 set DG_TORTURE_OPTIONS [list \ 87 { -O0 } \ 88 { -O1 } \ 89 { -O2 } \ 90 { -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions } \ 91 { -O3 -g } \ 92 { -Os } ] 93 94 if [check_effective_target_lto] { 95 # When having plugin test both slim and fat LTO and plugin/nonplugin 96 # path. 97 if [check_linker_plugin_available] { 98 set LTO_TORTURE_OPTIONS [list \ 99 { -O2 -flto -fno-use-linker-plugin -flto-partition=none } \ 100 { -O2 -flto -fuse-linker-plugin -fno-fat-lto-objects } 101 ] 102 } else { 103 set LTO_TORTURE_OPTIONS [list \ 104 { -O2 -flto -flto-partition=none } \ 105 { -O2 -flto } 106 ] 107 } 108 set gcc_force_conventional_output "-ffat-lto-objects" 109 } 110} 111 112if [info exists ADDITIONAL_TORTURE_OPTIONS] { 113 set DG_TORTURE_OPTIONS \ 114 [concat $DG_TORTURE_OPTIONS $ADDITIONAL_TORTURE_OPTIONS] 115} 116 117proc dg-final { args } { 118 upvar dg-final-code final-code 119 120 if { [llength $args] > 2 } { 121 error "[lindex $args 0]: too many arguments" 122 } 123 set line [lindex $args 0] 124 set code [lindex $args 1] 125 set directive [lindex $code 0] 126 switch $directive { 127 gdb-test { 128 set code [linsert $code 1 $line] 129 } 130 } 131 append final-code "$code\n" 132} 133 134global orig_environment_saved 135 136# Deduce generated files from tool flags, return finalcode string 137proc schedule-cleanups { opts } { 138 global additional_sources 139 set finalcode "" 140 set testcases {} 141 lappend testcases [lindex [testname-for-summary] 0] 142 verbose "Cleanup testcases: $testcases" 4 143 if { [info exists additional_sources] && $additional_sources != "" } { 144 lappend testcases $additional_sources 145 verbose "Cleanup testcases, additional: $additional_sources" 4 146 } 147 verbose "Cleanup all options: $opts" 4 148 149 # First some fixups to transform stuff to something manageable .. 150 # --dump= should translate to -d with joined operand. 151 if [regexp -- {(^|\s+)--dump=[^\s]+(\s+|$)} $opts] { 152 regsub -all -- {--dump=} $opts {-d} opts 153 } 154 # -da and -dx are treated as shorthand for -fdump-rtl-all here 155 if [regexp -- {(^|\s+)-d[ax](\s+|$)} $opts] { 156 verbose "Cleanup -d seen" 4 157 lappend opts "-fdump-rtl-all" 158 } 159 # .. and don't question why there is --dump=? and -d? 160 161 # Then handle options that generate non-dump files 162 # TODO 163 # -fprofile-generate -> cleanup-coverage-files() 164 # -fstack-usage -> cleanup-stack-usage() 165 if [regexp -- {(^|\s+)-fstack-usage(\s+|$)} $opts] { 166 verbose "Cleanup -fstack-usage seen" 4 167# append finalcode "cleanup-stack-usage\n" 168 } 169 global keep_saved_temps_suffixes 170 if [info exists keep_saved_temps_suffixes ] { 171 verbose "dg-keep-saved-temps ${keep_saved_temps_suffixes}" 2 172 } 173 # -save-temps -> cleanup-saved-temps() 174 if [regexp -- {(^|\s+)-?-save-temps(\s+|$)} $opts] { 175 verbose "Cleanup -save-temps seen" 4 176 if [info exists keep_saved_temps_suffixes] { 177 append finalcode "cleanup-saved-temps ${keep_saved_temps_suffixes}\n" 178 } else { 179 append finalcode "cleanup-saved-temps\n" 180 } 181 } else { 182 if [info exists keep_saved_temps_suffixes ] { 183 error "dg-keep-saved-temps specified but testcase does not -save-temps" 184 return 185 } 186 } 187 # Finally see if there are any dumps in opts, otherwise we are done 188 if [regexp -- {(?=(?:^|[ \t]+)?)-fdump-[^ \t]+(?=(?:$|[ \t]+)?)} $opts] { 189 # Lang, Ipa, Rtl, Tree for simplicity 190 set ptn "{l,i,r,t}" 191 } else { 192 return $finalcode 193 } 194 # stem.ext.<passnum><fam>.<passname><pass-instances> 195 # (tree)passes can have multiple instances, thus optional trailing * 196 set ptn "\[0-9\]\[0-9\]\[0-9\]$ptn.*" 197 # Handle ltrans files around -flto 198 if [regexp -- {(^|\s+)-flto(\s+|$)} $opts] { 199 verbose "Cleanup -flto seen" 4 200 set ltrans "{ltrans\[0-9\]*.,}" 201 } else { 202 set ltrans "" 203 } 204 set ptn "$ltrans$ptn" 205 verbose "Cleanup final ptn: $ptn" 4 206 set tfiles {} 207 foreach src $testcases { 208 set basename [file tail $src] 209 if { $ltrans != "" } { 210 # ??? should we use upvar 1 output_file instead of this (dup ?) 211 set stem [file rootname $basename] 212 set basename_ext [file extension $basename] 213 if {$basename_ext != ""} { 214 regsub -- {^.*\.} $basename_ext {} basename_ext 215 } 216 lappend tfiles "$stem.{$basename_ext,exe}" 217 unset basename_ext 218 } else { 219 lappend tfiles $basename 220 } 221 } 222 if { [llength $tfiles] > 1 } { 223 set tfiles [join $tfiles ","] 224 set tfiles "{$tfiles}" 225 } 226 verbose "Cleanup final testcases: $tfiles" 4 227 # We have to quote the regex 228 regsub -all {([][$^?+*()|\\{}])} "$tfiles.$ptn" {\\\1} ptn 229 set final "" 230 append final {remove-build-file } 231 append final "\"$ptn\"" 232 verbose "Cleanup final: $final" 4 233 append finalcode "$final\n" 234 235 return $finalcode 236} 237 238# Define gcc callbacks for dg.exp. 239 240proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } { 241 # Set up the compiler flags, based on what we're going to do. 242 243 set options [list] 244 245 switch $do_what { 246 "preprocess" { 247 set compile_type "preprocess" 248 set output_file "[file rootname [file tail $prog]].i" 249 } 250 "compile" { 251 set compile_type "assembly" 252 set output_file "[file rootname [file tail $prog]].s" 253 } 254 "assemble" { 255 set compile_type "object" 256 set output_file "[file rootname [file tail $prog]].o" 257 } 258 "precompile" { 259 set compile_type "precompiled_header" 260 set output_file "[file tail $prog].gch" 261 } 262 "link" { 263 set compile_type "executable" 264 set output_file "[file rootname [file tail $prog]].exe" 265 # The following line is needed for targets like the i960 where 266 # the default output file is b.out. Sigh. 267 } 268 "repo" { 269 set compile_type "object" 270 set output_file "[file rootname [file tail $prog]].o" 271 } 272 "run" { 273 set compile_type "executable" 274 # FIXME: "./" is to cope with "." not being in $PATH. 275 # Should this be handled elsewhere? 276 # YES. 277 set output_file "./[file rootname [file tail $prog]].exe" 278 # This is the only place where we care if an executable was 279 # created or not. If it was, dg.exp will try to run it. 280 catch { remote_file build delete $output_file } 281 } 282 default { 283 perror "$do_what: not a valid dg-do keyword" 284 return "" 285 } 286 } 287 288 # Let { dg-final { action } } force options as returned by an 289 # optional proc ${action}_required_options. 290 upvar 2 dg-final-code finalcode 291 foreach x [split $finalcode "\n"] { 292 set finalcmd [lindex $x 0] 293 if { [info procs ${finalcmd}_required_options] != "" } { 294 foreach req [${finalcmd}_required_options] { 295 if { $req != "" 296 && [lsearch -exact $extra_tool_flags $req] == -1 } { 297 lappend extra_tool_flags $req 298 } 299 } 300 } 301 } 302 303 append finalcode [schedule-cleanups "$options $extra_tool_flags"] 304 if { $extra_tool_flags != "" } { 305 lappend options "additional_flags=$extra_tool_flags" 306 } 307 308 verbose "$target_compile $prog $output_file $compile_type $options" 4 309 set comp_output [$target_compile "$prog" "$output_file" "$compile_type" $options] 310 311 # Look for an internal compiler error, which sometimes masks the fact 312 # that we didn't get an expected error message. XFAIL an ICE via 313 # dg-xfail-if and use { dg-prune-output ".*internal compiler error.*" } 314 # to avoid a second failure for excess errors. 315 if [string match "*internal compiler error*" $comp_output] { 316 upvar 2 name name 317 fail "$name (internal compiler error)" 318 } 319 320 if { $do_what == "repo" } { 321 set object_file "$output_file" 322 set output_file "[file rootname [file tail $prog]].exe" 323 set comp_output \ 324 [ concat $comp_output \ 325 [$target_compile "$object_file" "$output_file" \ 326 "executable" $options] ] 327 } 328 329 return [list $comp_output $output_file] 330} 331 332proc gcc-dg-test { prog do_what extra_tool_flags } { 333 return [gcc-dg-test-1 gcc_target_compile $prog $do_what $extra_tool_flags] 334} 335 336# Global: should blank lines be allowed in the output? 337# By default, they should not be. (PR other/69006) 338# However, there are some ways for them to validly occur. 339# If this variable is 0, blank lines are not allowed in output, 340# if it is 1, they are allowed for a single testcase only and gcc-dg-prune 341# will clear it again after checking it, if it is 2, they are disabled 342# for all tests. 343set allow_blank_lines 0 344 345if { [check_effective_target_llvm_binutils] } { 346 set allow_blank_lines 2 347} 348 349# A command for use by testcases to mark themselves as expecting 350# blank lines in the output. 351 352proc dg-allow-blank-lines-in-output { args } { 353 global allow_blank_lines 354 if { !$allow_blank_lines } { 355 set allow_blank_lines 1 356 } 357} 358 359proc gcc-dg-prune { system text } { 360 global additional_prunes 361 362 # Extra prune rules that will apply to tests defined in a .exp file. 363 # Always remember to clear it in .exp file after executed all tests. 364 global dg_runtest_extra_prunes 365 366 # Complain about blank lines in the output (PR other/69006) 367 global allow_blank_lines 368 if { !$allow_blank_lines } { 369 set num_blank_lines [llength [regexp -all -inline "\n\n" $text]] 370 if { $num_blank_lines } { 371 global testname_with_flags 372 fail "$testname_with_flags $num_blank_lines blank line(s) in output" 373 } 374 } 375 if { $allow_blank_lines == 1 } { 376 set allow_blank_lines 0 377 } 378 379 set text [prune_gcc_output $text] 380 381 foreach p "$additional_prunes $dg_runtest_extra_prunes" { 382 if { [string length $p] > 0 } { 383 # Following regexp matches a complete line containing $p. 384 regsub -all "(^|\n)\[^\n\]*$p\[^\n\]*" $text "" text 385 } 386 } 387 388 # If we see "region xxx is full" then the testcase is too big for ram. 389 # This is tricky to deal with in a large testsuite like c-torture so 390 # deal with it here. Just mark the testcase as unsupported. 391 if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] { 392 # The format here is important. See dg.exp. 393 return "::unsupported::memory full" 394 } 395 396 if { [regexp "(^|\n)\[^\n\]*: relocation truncated to fit" $text] 397 && [check_effective_target_tiny] } { 398 return "::unsupported::memory full" 399 } 400 401 if [regexp "(^|\n)\[^\n\]* section.*will not fit in region" $text] { 402 return "::unsupported::memory full" 403 } 404 405 if [regexp "(^|\n)\[^\n\]* region.*overflowed by" $text] { 406 return "::unsupported::memory full" 407 } 408 409 if { [string match "*error: function pointers not supported*" $text] 410 && ![check_effective_target_function_pointers] } { 411 # The format here is important. See dg.exp. 412 return "::unsupported::funcptr" 413 } 414 if { [string match "*error: large return values not supported*" $text] 415 && ![check_effective_target_large_return_values] } { 416 # The format here is important. See dg.exp. 417 return "::unsupported::large return values" 418 } 419 420 # If exceptions are disabled, mark tests expecting exceptions to be enabled 421 # as unsupported. 422 if { ![check_effective_target_exceptions_enabled] } { 423 if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] { 424 return "::unsupported::exception handling disabled" 425 } 426 427 if [regexp "(^|\n)\[^\n\]*: error: #error .__cpp_exceptions." $text] { 428 return "::unsupported::exception handling disabled" 429 } 430 } 431 432 return $text 433} 434 435# Replace ${tool}_load with a wrapper to provide for an expected nonzero 436# exit status. Multiple languages include this file so this handles them 437# all, not just gcc. 438if { [info procs ${tool}_load] != [list] \ 439 && [info procs saved_${tool}_load] == [list] } { 440 rename ${tool}_load saved_${tool}_load 441 442 proc ${tool}_load { program args } { 443 global tool 444 global shouldfail 445 global set_target_env_var 446 447 set saved_target_env_var [list] 448 if { [info exists set_target_env_var] \ 449 && [llength $set_target_env_var] != 0 } { 450 if { [is_remote target] } { 451 return [list "unsupported" ""] 452 } 453 set-target-env-var 454 } 455 set result [eval [list saved_${tool}_load $program] $args] 456 if { [info exists set_target_env_var] \ 457 && [llength $set_target_env_var] != 0 } { 458 restore-target-env-var 459 } 460 if { $shouldfail != 0 } { 461 switch [lindex $result 0] { 462 "pass" { set status "fail" } 463 "fail" { set status "pass" } 464 default { set status [lindex $result 0] } 465 } 466 set result [list $status [lindex $result 1]] 467 } 468 469 set result [list [lindex $result 0] [prune_file_path [lindex $result 1]]] 470 return $result 471 } 472} 473 474proc dg-set-target-env-var { args } { 475 global set_target_env_var 476 if { [llength $args] != 3 } { 477 error "dg-set-target-env-var: need two arguments" 478 return 479 } 480 set var [lindex $args 1] 481 set value [lindex $args 2] 482 verbose "dg-set-target-env-var $var $value" 2 483 lappend set_target_env_var [list $var $value] 484} 485 486proc set-target-env-var { } { 487 global set_target_env_var 488 upvar 1 saved_target_env_var saved_target_env_var 489 foreach env_var $set_target_env_var { 490 set var [lindex $env_var 0] 491 set value [lindex $env_var 1] 492 if [info exists ::env($var)] { 493 lappend saved_target_env_var [list $var 1 $::env($var)] 494 } else { 495 lappend saved_target_env_var [list $var 0] 496 } 497 setenv $var $value 498 } 499} 500 501proc restore-target-env-var { } { 502 upvar 1 saved_target_env_var saved_target_env_var 503 for { set env_vari [llength $saved_target_env_var] } { 504 [incr env_vari -1] >= 0 } {} { 505 set env_var [lindex $saved_target_env_var $env_vari] 506 set var [lindex $env_var 0] 507 if [lindex $env_var 1] { 508 setenv $var [lindex $env_var 2] 509 } else { 510 unsetenv $var 511 } 512 } 513} 514 515proc dg-set-compiler-env-var { args } { 516 global set_compiler_env_var 517 global saved_compiler_env_var 518 if { [llength $args] != 3 } { 519 error "dg-set-compiler-env-var: need two arguments" 520 return 521 } 522 set var [lindex $args 1] 523 set value [lindex $args 2] 524 verbose "dg-set-compiler-env-var $var $value" 2 525 if [info exists ::env($var)] { 526 lappend saved_compiler_env_var [list $var 1 $::env($var)] 527 } else { 528 lappend saved_compiler_env_var [list $var 0] 529 } 530 setenv $var $value 531 lappend set_compiler_env_var [list $var $value] 532} 533 534proc restore-compiler-env-var { } { 535 global saved_compiler_env_var 536 for { set env_vari [llength $saved_compiler_env_var] } { 537 [incr env_vari -1] >= 0 } {} { 538 set env_var [lindex $saved_compiler_env_var $env_vari] 539 set var [lindex $env_var 0] 540 if [lindex $env_var 1] { 541 setenv $var [lindex $env_var 2] 542 } else { 543 unsetenv $var 544 } 545 } 546} 547 548# Utility routines. 549 550# 551# search_for -- looks for a string match in a file 552# 553proc search_for { file pattern } { 554 set fd [open $file r] 555 while { [gets $fd cur_line]>=0 } { 556 if [string match "*$pattern*" $cur_line] then { 557 close $fd 558 return 1 559 } 560 } 561 close $fd 562 return 0 563} 564 565# Modified dg-runtest that can cycle through a list of optimization options 566# as c-torture does. 567proc gcc-dg-runtest { testcases flags default-extra-flags } { 568 global runtests 569 570 # Some callers set torture options themselves; don't override those. 571 set existing_torture_options [torture-options-exist] 572 if { $existing_torture_options == 0 } { 573 global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS 574 torture-init 575 set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS 576 } 577 dump-torture-options 578 579 foreach test $testcases { 580 global torture_with_loops torture_without_loops 581 # If we're only testing specific files and this isn't one of 582 # them, skip it. 583 if ![runtest_file_p $runtests $test] { 584 continue 585 } 586 587 # Look for a loop within the source code - if we don't find one, 588 # don't pass -funroll[-all]-loops. 589 if [expr [search_for $test "for*("]+[search_for $test "while*("]] { 590 set option_list $torture_with_loops 591 } else { 592 set option_list $torture_without_loops 593 } 594 595 set nshort [file tail [file dirname $test]]/[file tail $test] 596 597 foreach flags_t $option_list { 598 global torture_current_flags 599 set torture_current_flags "$flags_t" 600 verbose "Testing $nshort, $flags $flags_t" 1 601 dg-test $test "$flags $flags_t" ${default-extra-flags} 602 } 603 } 604 605 if { $existing_torture_options == 0 } { 606 torture-finish 607 } 608} 609 610proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } { 611 global srcdir subdir 612 613 if ![info exists DEBUG_TORTURE_OPTIONS] { 614 set DEBUG_TORTURE_OPTIONS "" 615 foreach type {-gdwarf-2 -gstabs -gstabs+ -gxcoff -gxcoff+} { 616 set comp_output [$target_compile \ 617 "$srcdir/$subdir/$trivial" "trivial.S" assembly \ 618 "additional_flags=$type"] 619 if { ! [string match "*: target system does not support the * debug format*" \ 620 $comp_output] } { 621 remove-build-file "trivial.S" 622 foreach level {1 "" 3} { 623 if { ($type == "-gdwarf-2") && ($level != "") } { 624 lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"] 625 foreach opt $opt_opts { 626 lappend DEBUG_TORTURE_OPTIONS \ 627 [list "${type}" "-g${level}" "$opt" ] 628 } 629 } else { 630 lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"] 631 foreach opt $opt_opts { 632 lappend DEBUG_TORTURE_OPTIONS \ 633 [list "${type}${level}" "$opt" ] 634 } 635 } 636 } 637 } 638 } 639 } 640 641 verbose -log "Using options $DEBUG_TORTURE_OPTIONS" 642 643 global runtests 644 645 foreach test $testcases { 646 # If we're only testing specific files and this isn't one of 647 # them, skip it. 648 if ![runtest_file_p $runtests $test] { 649 continue 650 } 651 652 set nshort [file tail [file dirname $test]]/[file tail $test] 653 654 foreach flags $DEBUG_TORTURE_OPTIONS { 655 set doit 1 656 657 # These tests check for information which may be deliberately 658 # suppressed at -g1. 659 if { ([string match {*/debug-[126].c} "$nshort"] \ 660 || [string match {*/enum-1.c} "$nshort"] \ 661 || [string match {*/enum-[12].C} "$nshort"]) \ 662 && ([string match "*1" [lindex "$flags" 0] ] 663 || [lindex "$flags" 1] == "-g1") } { 664 set doit 0 665 } 666 667 # High optimization can remove the variable whose existence is tested. 668 # Dwarf debugging with commentary (-dA) preserves the symbol name in the 669 # assembler output, but stabs debugging does not. 670 # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html 671 if { [string match {*/debug-[12].c} "$nshort"] \ 672 && [string match "*O*" "$flags"] \ 673 && ( [string match "*coff*" "$flags"] \ 674 || [string match "*stabs*" "$flags"] ) } { 675 set doit 0 676 } 677 678 if { $doit } { 679 verbose -log "Testing $nshort, $flags" 1 680 dg-test $test $flags "" 681 } 682 } 683 } 684} 685 686# Prune any messages matching ARGS[1] (a regexp) from test output. 687proc dg-prune-output { args } { 688 global additional_prunes 689 690 if { [llength $args] != 2 } { 691 error "[lindex $args 1]: need one argument" 692 return 693 } 694 695 lappend additional_prunes [lindex $args 1] 696} 697 698# Remove files matching the pattern from the build machine. 699proc remove-build-file { pat } { 700 verbose "remove-build-file `$pat'" 2 701 set file_list "[glob -nocomplain $pat]" 702 verbose "remove-build-file `$file_list'" 2 703 foreach output_file $file_list { 704 if [is_remote host] { 705 # Ensure the host knows the file is gone by deleting there 706 # first. 707 remote_file host delete $output_file 708 } 709 remote_file build delete $output_file 710 } 711} 712 713# Remove runtime-generated profile file for the current test. 714proc cleanup-profile-file { } { 715 remove-build-file "mon.out" 716 remove-build-file "gmon.out" 717} 718 719# Remove compiler-generated coverage files for the current test. 720proc cleanup-coverage-files { } { 721 global additional_sources_used 722 set testcase [testname-for-summary] 723 # The name might include a list of options; extract the file name. 724 set testcase [lindex $testcase 0] 725 remove-build-file "[file rootname [file tail $testcase]].gc??" 726 727 # Clean up coverage files for additional source files. 728 if [info exists additional_sources_used] { 729 foreach srcfile $additional_sources_used { 730 remove-build-file "[file rootname [file tail $srcfile]].gc??" 731 } 732 } 733} 734 735# Remove a final insns dump file for the current test. 736proc cleanup-final-insns-dump { } { 737 set testcase [testname-for-summary] 738 # The name might include a list of options; extract the file name. 739 set testcase [lindex $testcase 0] 740 remove-build-file "[file rootname [file tail $testcase]].s.gkd" 741 742 # Clean up files for additional source files. 743 if [info exists additional_sources_used] { 744 foreach srcfile $additional_sources_used { 745 remove-build-file "[file rootname [file tail $srcfile]].s.gkd" 746 } 747 } 748} 749 750# Remove a stack usage file for the current test. 751proc cleanup-stack-usage { } { 752 set testcase [testname-for-summary] 753 # The name might include a list of options; extract the file name. 754 set testcase [lindex $testcase 0] 755 remove-build-file "[file rootname [file tail $testcase]].su" 756 757 # Clean up files for additional source files. 758 if [info exists additional_sources_used] { 759 foreach srcfile $additional_sources_used { 760 remove-build-file "[file rootname [file tail $srcfile]].su" 761 } 762 } 763} 764 765# Remove an Ada spec file for the current test. 766proc cleanup-ada-spec { } { 767 global additional_sources_used 768 set testcase [testname-for-summary] 769 remove-build-file "[get_ada_spec_filename $testcase]" 770 771 # Clean up files for additional source files. 772 if [info exists additional_sources_used] { 773 foreach srcfile $additional_sources_used { 774 remove-build-file "[get_ada_spec_filename $srcfile]" 775 } 776 } 777} 778 779# Remove files kept by --save-temps for the current test. 780# 781# Currently this is only .i, .ii, .s and .o files, but more can be added 782# if there are tests generating them. 783# ARGS is a list of suffixes to NOT delete. 784proc cleanup-saved-temps { args } { 785 global additional_sources_used 786 set suffixes {} 787 788 # add the to-be-kept suffixes 789 foreach suffix {".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} { 790 if {[lsearch $args $suffix] < 0} { 791 lappend suffixes $suffix 792 } 793 } 794 795 set testcase [testname-for-summary] 796 # The name might include a list of options; extract the file name. 797 set testcase [lindex $testcase 0] 798 foreach suffix $suffixes { 799 remove-build-file "[file rootname [file tail $testcase]]$suffix" 800 remove-build-file "[file rootname [file tail $testcase]].exe$suffix" 801 remove-build-file "[file rootname [file tail $testcase]].exe.ltrans\[0-9\]*$suffix" 802 # -fcompare-debug dumps 803 remove-build-file "[file rootname [file tail $testcase]].gk$suffix" 804 } 805 806 # Clean up saved temp files for additional source files. 807 if [info exists additional_sources_used] { 808 foreach srcfile $additional_sources_used { 809 foreach suffix $suffixes { 810 remove-build-file "[file rootname [file tail $srcfile]]$suffix" 811 remove-build-file "[file rootname [file tail $srcfile]].exe$suffix" 812 remove-build-file "[file rootname [file tail $srcfile]].exe.ltrans\[0-9\]*$suffix" 813 814 # -fcompare-debug dumps 815 remove-build-file "[file rootname [file tail $srcfile]].gk$suffix" 816 } 817 } 818 } 819} 820 821 822# Files to be kept after cleanup of --save-temps for the current test. 823# ARGS is a list of suffixes to NOT delete. 824proc dg-keep-saved-temps { args } { 825 global keep_saved_temps_suffixes 826 set keep_saved_temps_suffixes {} 827 828 # add the to-be-kept suffixes 829 foreach suffix {".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} { 830 if {[lsearch $args $suffix] >= 0} { 831 lappend keep_saved_temps_suffixes $suffix 832 } 833 } 834 if { [llength keep_saved_temps_suffixes] < 1 } { 835 error "dg-keep-saved-temps ${args} did not match any known suffix" 836 } 837} 838 839# Scan Fortran modules for a given regexp. 840# 841# Argument 0 is the module name 842# Argument 1 is the regexp to match 843proc scan-module { args } { 844 set modfilename [string tolower [lindex $args 0]].mod 845 set fd [open [list | gzip -dc $modfilename] r] 846 set text [read $fd] 847 close $fd 848 849 set testcase [testname-for-summary] 850 if [regexp -- [lindex $args 1] $text] { 851 pass "$testcase scan-module [lindex $args 1]" 852 } else { 853 fail "$testcase scan-module [lindex $args 1]" 854 } 855} 856 857# Scan Fortran modules for absence of a given regexp. 858# 859# Argument 0 is the module name 860# Argument 1 is the regexp to match 861proc scan-module-absence { args } { 862 set modfilename [string tolower [lindex $args 0]].mod 863 set fd [open [list | gzip -dc $modfilename] r] 864 set text [read $fd] 865 close $fd 866 867 set testcase [testname-for-summary] 868 if [regexp -- [lindex $args 1] $text] { 869 fail "$testcase scan-module [lindex $args 1]" 870 } else { 871 pass "$testcase scan-module [lindex $args 1]" 872 } 873} 874 875# Verify that the compiler output file exists, invoked via dg-final. 876proc output-exists { args } { 877 # Process an optional target or xfail list. 878 if { [llength $args] >= 1 } { 879 switch [dg-process-target [lindex $args 0]] { 880 "S" { } 881 "N" { return } 882 "F" { setup_xfail "*-*-*" } 883 "P" { } 884 } 885 } 886 887 set testcase [testname-for-summary] 888 # Access variable from gcc-dg-test-1. 889 upvar 2 output_file output_file 890 891 if [file exists $output_file] { 892 pass "$testcase output-exists $output_file" 893 } else { 894 fail "$testcase output-exists $output_file" 895 } 896} 897 898# Verify that the compiler output file does not exist, invoked via dg-final. 899proc output-exists-not { args } { 900 # Process an optional target or xfail list. 901 if { [llength $args] >= 1 } { 902 switch [dg-process-target [lindex $args 0]] { 903 "S" { } 904 "N" { return } 905 "F" { setup_xfail "*-*-*" } 906 "P" { } 907 } 908 } 909 910 set testcase [testname-for-summary] 911 # Access variable from gcc-dg-test-1. 912 upvar 2 output_file output_file 913 914 if [file exists $output_file] { 915 fail "$testcase output-exists-not $output_file" 916 } else { 917 pass "$testcase output-exists-not $output_file" 918 } 919} 920 921# We need to make sure that additional_* are cleared out after every 922# test. It is not enough to clear them out *before* the next test run 923# because gcc-target-compile gets run directly from some .exp files 924# (outside of any test). (Those uses should eventually be eliminated.) 925 926# Because the DG framework doesn't provide a hook that is run at the 927# end of a test, we must replace dg-test with a wrapper. 928 929if { [info procs saved-dg-test] == [list] } { 930 rename dg-test saved-dg-test 931 932 # Helper function for cleanups that should happen after the call 933 # to the real dg-test, whether or not it returns normally, or 934 # fails with an error. 935 proc cleanup-after-saved-dg-test { } { 936 global additional_files 937 global additional_sources 938 global additional_sources_used 939 global additional_prunes 940 global compiler_conditional_xfail_data 941 global shouldfail 942 global testname_with_flags 943 global set_target_env_var 944 global set_compiler_env_var 945 global saved_compiler_env_var 946 global keep_saved_temps_suffixes 947 global nn_line_numbers_enabled 948 global multiline_expected_outputs 949 global freeform_regexps 950 global save_linenr_varnames 951 952 set additional_files "" 953 set additional_sources "" 954 set additional_sources_used "" 955 set additional_prunes "" 956 set shouldfail 0 957 if [info exists set_target_env_var] { 958 unset set_target_env_var 959 } 960 if [info exists set_compiler_env_var] { 961 restore-compiler-env-var 962 unset set_compiler_env_var 963 unset saved_compiler_env_var 964 } 965 if [info exists keep_saved_temps_suffixes] { 966 unset keep_saved_temps_suffixes 967 } 968 unset_timeout_vars 969 if [info exists compiler_conditional_xfail_data] { 970 unset compiler_conditional_xfail_data 971 } 972 if [info exists testname_with_flags] { 973 unset testname_with_flags 974 } 975 set nn_line_numbers_enabled 0 976 set multiline_expected_outputs [] 977 set freeform_regexps [] 978 979 if { [info exists save_linenr_varnames] } { 980 foreach varname $save_linenr_varnames { 981 # Cleanup varname 982 eval global $varname 983 eval unset $varname 984 985 # Cleanup varname_used, or generate defined-but-not-used 986 # warning. 987 set varname_used used_$varname 988 eval global $varname_used 989 eval set used [info exists $varname_used] 990 if { $used } { 991 eval unset $varname_used 992 } else { 993 regsub {^saved_linenr_} $varname "" org_varname 994 warning "dg-line var $org_varname defined, but not used" 995 } 996 } 997 unset save_linenr_varnames 998 } 999 } 1000 1001 proc dg-test { args } { 1002 global errorInfo 1003 1004 if { [ catch { eval saved-dg-test $args } errmsg ] } { 1005 set saved_info $errorInfo 1006 cleanup-after-saved-dg-test 1007 error $errmsg $saved_info 1008 } 1009 cleanup-after-saved-dg-test 1010 } 1011} 1012 1013if { [info procs saved-dg-warning] == [list] \ 1014 && [info exists gcc_warning_prefix] } { 1015 rename dg-warning saved-dg-warning 1016 1017 proc dg-warning { args } { 1018 # Make this variable available here and to the saved proc. 1019 upvar dg-messages dg-messages 1020 global gcc_warning_prefix 1021 1022 process-message saved-dg-warning "$gcc_warning_prefix" "$args" 1023 } 1024} 1025 1026if { [info procs saved-dg-error] == [list] \ 1027 && [info exists gcc_error_prefix] } { 1028 rename dg-error saved-dg-error 1029 1030 proc dg-error { args } { 1031 # Make this variable available here and to the saved proc. 1032 upvar dg-messages dg-messages 1033 global gcc_error_prefix 1034 1035 process-message saved-dg-error "$gcc_error_prefix" "$args" 1036 } 1037 1038 # Override dg-bogus at the same time. It doesn't handle a prefix 1039 # but its expression should include a column number. Otherwise the 1040 # line number can match the column number for other messages, leading 1041 # to insanity. 1042 rename dg-bogus saved-dg-bogus 1043 1044 proc dg-bogus { args } { 1045 upvar dg-messages dg-messages 1046 process-message saved-dg-bogus "" $args 1047 } 1048} 1049 1050# Set variable VARNAME to LINENR 1051 1052proc dg-line { linenr varname } { 1053 set org_varname $varname 1054 set varname "saved_linenr_$varname" 1055 eval global $varname 1056 1057 # Generate defined-but-previously-defined error. 1058 eval set var_defined [info exists $varname] 1059 if { $var_defined } { 1060 eval set deflinenr \$$varname 1061 error "dg-line var $org_varname defined at line $linenr, but previously defined at line $deflinenr" 1062 return 1063 } 1064 1065 eval set $varname $linenr 1066 1067 # Schedule cleanup of varname by cleanup-after-saved-dg-test 1068 global save_linenr_varnames 1069 if { [info exists save_linenr_varnames] } { 1070 lappend save_linenr_varnames $varname 1071 } else { 1072 set save_linenr_varnames [list $varname] 1073 } 1074} 1075 1076# Get the absolute line number corresponding to: 1077# - a relative line number (a non-null useline is required), or 1078# - a line number variable reference. 1079# Argument 0 is the line number on which line was used 1080# Argument 1 is the relative line number or line number variable reference 1081# 1082proc get-absolute-line { useline line } { 1083 if { "$line" == "." } { 1084 return $useline 1085 } 1086 1087 if { [regsub "^\.\[+-\](\[0-9\]+)$" $line "\\1" num] && $useline != "" } { 1088 # Handle relative line specification, .+1 or .-1 etc. 1089 set num [expr $useline [string index $line 1] $num] 1090 return $num 1091 } 1092 1093 if { ! [regsub "^(\[a-zA-Z\]\[a-zA-Z0-9_\]*)$" $line "\\1" varname] } { 1094 return $line 1095 } 1096 1097 # Handle linenr variable defined by dg-line 1098 set org_varname $varname 1099 set varname "saved_linenr_$varname" 1100 eval global $varname 1101 1102 # Generate used-but-not-defined error. 1103 eval set var_defined [info exists $varname] 1104 if { ! $var_defined } { 1105 if { "$useline" != "" } { 1106 error "dg-line var $org_varname used at line $useline, but not defined" 1107 } else { 1108 error "dg-line var $org_varname used, but not defined" 1109 } 1110 return 1111 } 1112 1113 # Note that varname has been used. 1114 set varname_used "used_$varname" 1115 eval global $varname_used 1116 eval set $varname_used 1 1117 1118 # Get line number from var and use it. 1119 eval set num \$$varname 1120 set line $num 1121} 1122 1123# Modify the regular expression saved by a DejaGnu message directive to 1124# include a prefix and to force the expression to match a single line. 1125# MSGPROC is the procedure to call. 1126# MSGPREFIX is the prefix to prepend. 1127# DGARGS is the original argument list. 1128 1129proc process-message { msgproc msgprefix dgargs } { 1130 upvar dg-messages dg-messages 1131 1132 if { [llength $dgargs] == 5 } { 1133 set num [get-absolute-line [lindex $dgargs 0] [lindex $dgargs 4]] 1134 set dgargs [lreplace $dgargs 4 4 $num] 1135 } 1136 1137 # Process the dg- directive, including adding the regular expression 1138 # to the new message entry in dg-messages. 1139 set msgcnt [llength ${dg-messages}] 1140 eval $msgproc $dgargs 1141 1142 # If the target expression wasn't satisfied there is no new message. 1143 if { [llength ${dg-messages}] == $msgcnt } { 1144 return; 1145 } 1146 1147 # Get the entry for the new message. Prepend the message prefix to 1148 # the regular expression and make it match a single line. 1149 set newentry [lindex ${dg-messages} end] 1150 set expmsg [lindex $newentry 2] 1151 1152 set column "" 1153 # Handle column numbers from the specified expression (if there is 1154 # one) and set up the search expression that will be used by DejaGnu. 1155 if [regexp {^-:} $expmsg] { 1156 # The expected column is -, so shouldn't appear. 1157 set expmsg [string range $expmsg 2 end] 1158 } elseif [regexp {^[0-9]+:} $expmsg column] { 1159 # The expression in the directive included a column number. 1160 # Remove it from the original expression and move it 1161 # to the proper place in the search expression. 1162 set expmsg [string range $expmsg [string length $column] end] 1163 set column "$column " 1164 } elseif [string match "" [lindex $newentry 0]] { 1165 # The specified line number is 0; don't expect a column number. 1166 } else { 1167 # There is no column number in the search expression, but we 1168 # should expect one in the message itself. 1169 set column {[0-9]+: } 1170 } 1171 set expmsg "$column$msgprefix\[^\n\]*$expmsg" 1172 set newentry [lreplace $newentry 2 2 $expmsg] 1173 1174 set dg-messages [lreplace ${dg-messages} end end $newentry] 1175 verbose "process-message:\n${dg-messages}" 3 1176} 1177 1178# Look for messages that don't have standard prefixes. 1179 1180proc dg-message { args } { 1181 upvar dg-messages dg-messages 1182 process-message saved-dg-warning "" $args 1183} 1184 1185# Look for a location marker of the form 1186# file:line:column: 1187# with no extra text (e.g. a line-span separator). 1188 1189proc dg-locus { args } { 1190 upvar dg-messages dg-messages 1191 1192 # Process the dg- directive, including adding the regular expression 1193 # to the new message entry in dg-messages. 1194 set msgcnt [llength ${dg-messages}] 1195 eval saved-dg-warning $args 1196 1197 # If the target expression wasn't satisfied there is no new message. 1198 if { [llength ${dg-messages}] == $msgcnt } { 1199 return; 1200 } 1201 1202 # Get the entry for the new message. Prepend the message prefix to 1203 # the regular expression and make it match a single line. 1204 set newentry [lindex ${dg-messages} end] 1205 set expmsg [lindex $newentry 2] 1206 1207 set newentry [lreplace $newentry 2 2 $expmsg] 1208 set dg-messages [lreplace ${dg-messages} end end $newentry] 1209 verbose "process-message:\n${dg-messages}" 3 1210} 1211 1212# Handle output from -fopt-info for MSG_OPTIMIZED_LOCATIONS: 1213# a successful optimization. 1214 1215proc dg-optimized { args } { 1216 # Make this variable available here and to the saved proc. 1217 upvar dg-messages dg-messages 1218 1219 process-message saved-dg-warning "optimized:" "$args" 1220} 1221 1222# Handle output from -fopt-info for MSG_MISSED_OPTIMIZATION: 1223# a missed optimization. 1224 1225proc dg-missed { args } { 1226 # Make this variable available here and to the saved proc. 1227 upvar dg-messages dg-messages 1228 1229 process-message saved-dg-warning "missed:" "$args" 1230} 1231 1232# Check the existence of a gdb in the path, and return true if there 1233# is one. 1234# 1235# Set env(GDB_FOR_GCC_TESTING) accordingly. 1236 1237proc gdb-exists { args } { 1238 if ![info exists ::env(GDB_FOR_GCC_TESTING)] { 1239 global GDB 1240 if ![info exists ::env(GDB_FOR_GCC_TESTING)] { 1241 if [info exists GDB] { 1242 setenv GDB_FOR_GCC_TESTING "$GDB" 1243 } else { 1244 setenv GDB_FOR_GCC_TESTING "[transform gdb]" 1245 } 1246 } 1247 } 1248 if { [which $::env(GDB_FOR_GCC_TESTING)] != 0 } { 1249 return 1; 1250 } 1251 return 0; 1252} 1253 1254# Helper function for scan-symbol and scan-symbol-not. It scans a symbol in 1255# the final executable and return 1 if present, otherwise fail. 1256# 1257# Argument 0 is the regexp to match. 1258# Argument 1 handles expected failures and the like 1259proc scan-symbol-common { scan_directive args } { 1260 global nm 1261 global base_dir 1262 1263 # Access variable from gcc-dg-test-1 or lto-execute. 1264 upvar 3 output_file output_file 1265 1266 if { [llength $args] >= 2 } { 1267 switch [dg-process-target [lindex $args 1]] { 1268 "S" { } 1269 "N" { return } 1270 "F" { setup_xfail "*-*-*" } 1271 "P" { } 1272 } 1273 } 1274 1275 # Find nm like we find g++ in g++.exp. 1276 if ![info exists nm] { 1277 set nm [findfile $base_dir/../../../binutils/nm \ 1278 $base_dir/../../../binutils/nm \ 1279 [findfile $base_dir/../../nm $base_dir/../../nm \ 1280 [findfile $base_dir/nm $base_dir/nm \ 1281 [transform nm]]]] 1282 verbose -log "nm is $nm" 1283 } 1284 1285 set output_file "[glob -nocomplain $output_file]" 1286 if { $output_file == "" } { 1287 fail "$scan_directive $args: output file does not exist" 1288 return 1289 } 1290 1291 set fd [open "| $nm $output_file" r] 1292 set text [read $fd] 1293 close $fd 1294 1295 if [regexp -- [lindex $args 0] $text] { 1296 return 1 1297 } else { 1298 return 0 1299 } 1300} 1301 1302# Utility for scanning a symbol in the final executable, invoked via dg-final. 1303# Call pass if pattern is present, otherwise fail. 1304# 1305# Argument 0 is the regexp to match. 1306# Argument 1 handles expected failures and the like 1307proc scan-symbol { args } { 1308 set testcase [testname-for-summary] 1309 if { [scan-symbol-common "scan-symbol" $args]} { 1310 pass "$testcase scan-symbol $args" 1311 } else { 1312 fail "$testcase scan-symbol $args" 1313 } 1314} 1315 1316# Utility for scanning a symbol in the final executable, invoked via dg-final. 1317# Call pass if pattern is absent, otherwise fail. 1318# 1319# Argument 0 is the regexp to match. 1320# Argument 1 handles expected failures and the like 1321proc scan-symbol-not { args } { 1322 set testcase [testname-for-summary] 1323 if { [scan-symbol-common "scan-symbol-not" $args]} { 1324 fail "$testcase scan-symbol-not $args" 1325 } else { 1326 pass "$testcase scan-symbol-not $args" 1327 } 1328} 1329 1330set additional_prunes "" 1331set dg_runtest_extra_prunes "" 1332