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