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