1 # Copyright (C) 1997-2024 Free Software Foundation, Inc.
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.
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.
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/>.
18 load_lib file-format.exp
19 load_lib target-supports.exp
20 load_lib target-supports-dg.exp
24 load_lib scanltranstree.exp
26 load_lib scanwpaipa.exp
28 load_lib scansarif.exp
30 load_lib timeout-dg.exp
33 load_lib target-libpath.exp
34 load_lib torture-options.exp
35 load_lib fortran-modules.exp
36 load_lib multiline.exp
38 # We set LC_ALL and LANG to C so that we get the same error messages as expected.
42 # Many hosts now default to a non-ASCII C locale, however, so
43 # they can set a charset encoding here if they need.
44 if { [ishost "*-*-cygwin*"] } {
49 # Avoid sporadic data-losses with expect
52 # Ensure GCC_COLORS is unset, for the rare testcases that verify
53 # how output is colorized.
54 if [info exists ::env(GCC_COLORS) ] {
59 if ![info exists GCC_UNDER_TEST] {
60 set GCC_UNDER_TEST "[find_gcc]"
63 # This file may be sourced, so don't override environment settings
64 # that have been previously setup.
65 if { $orig_environment_saved == 0 } {
66 append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST]
67 set_ld_library_path_env_vars
70 # Some torture-options cause intermediate code output, unusable for
71 # testing using e.g. scan-assembler. In this variable are the options
72 # how to force it, when needed.
73 global gcc_set_required_options
74 set gcc_set_required_options ""
76 if [info exists TORTURE_OPTIONS] {
77 set DG_TORTURE_OPTIONS $TORTURE_OPTIONS
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 \
90 { -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions } \
94 if [check_effective_target_lto] {
95 set gcc_set_required_options "-ffat-lto-objects"
99 if [info exists ADDITIONAL_TORTURE_OPTIONS] {
100 set DG_TORTURE_OPTIONS \
101 [concat $DG_TORTURE_OPTIONS $ADDITIONAL_TORTURE_OPTIONS]
104 proc dg-final { args } {
105 upvar dg-final-code final-code
107 if { [llength $args] > 2 } {
108 error "[lindex $args 0]: too many arguments"
110 set line [lindex $args 0]
111 set code [lindex $args 1]
112 set directive [lindex $code 0]
115 set code [linsert $code 1 $line]
118 append final-code "$code\n"
121 global orig_environment_saved
123 # Deduce generated files from tool flags, return finalcode string
124 proc schedule-cleanups { opts } {
125 global additional_sources
128 lappend testcases [lindex [testname-for-summary] 0]
129 verbose "Cleanup testcases: $testcases" 4
130 if { [info exists additional_sources] && $additional_sources != "" } {
131 lappend testcases $additional_sources
132 verbose "Cleanup testcases, additional: $additional_sources" 4
134 verbose "Cleanup all options: $opts" 4
136 # First some fixups to transform stuff to something manageable ..
137 # --dump= should translate to -d with joined operand.
138 if [regexp -- {(^|\s+)--dump=[^\s]+(\s+|$)} $opts] {
139 regsub -all -- {--dump=} $opts {-d} opts
141 # -da and -dx are treated as shorthand for -fdump-rtl-all here
142 if [regexp -- {(^|\s+)-d[ax](\s+|$)} $opts] {
143 verbose "Cleanup -d seen" 4
144 lappend opts "-fdump-rtl-all"
146 # .. and don't question why there is --dump=? and -d?
148 # Then handle options that generate non-dump files
150 # -fprofile-generate -> cleanup-coverage-files()
151 # -fstack-usage -> cleanup-stack-usage()
152 if [regexp -- {(^|\s+)-fstack-usage(\s+|$)} $opts] {
153 verbose "Cleanup -fstack-usage seen" 4
154 # append finalcode "cleanup-stack-usage\n"
156 global keep_saved_temps_suffixes
157 if [info exists keep_saved_temps_suffixes ] {
158 verbose "dg-keep-saved-temps ${keep_saved_temps_suffixes}" 2
160 # -save-temps -> cleanup-saved-temps()
161 if [regexp -- {(^|\s+)-?-save-temps(\s+|$)} $opts] {
162 verbose "Cleanup -save-temps seen" 4
163 if [info exists keep_saved_temps_suffixes] {
164 append finalcode "cleanup-saved-temps ${keep_saved_temps_suffixes}\n"
166 append finalcode "cleanup-saved-temps\n"
169 if [info exists keep_saved_temps_suffixes ] {
170 error "dg-keep-saved-temps specified but testcase does not -save-temps"
174 # Finally see if there are any dumps in opts, otherwise we are done
175 if [regexp -- {(?=(?:^|[ \t]+)?)-fdump-[^ \t]+(?=(?:$|[ \t]+)?)} $opts] {
176 # Lang, Ipa, Rtl, Tree for simplicity
181 # stem.ext.<passnum><fam>.<passname><pass-instances>
182 # (tree)passes can have multiple instances, thus optional trailing *
183 set ptn "\[0-9\]\[0-9\]\[0-9\]$ptn.*"
184 # Handle ltrans files around -flto
185 if [regexp -- {(^|\s+)-flto(\s+|$)} $opts] {
186 verbose "Cleanup -flto seen" 4
187 set ltrans "{ltrans\[0-9\]*.,}"
191 set ptn "$ltrans$ptn"
192 verbose "Cleanup final ptn: $ptn" 4
194 foreach src $testcases {
195 set basename [file tail $src]
196 if { $ltrans != "" } {
197 # ??? should we use upvar 1 output_file instead of this (dup ?)
198 set stem [file rootname $basename]
199 set basename_ext [file extension $basename]
200 if {$basename_ext != ""} {
201 regsub -- {^.*\.} $basename_ext {} basename_ext
203 lappend tfiles "$stem.{$basename_ext,exe}"
206 lappend tfiles $basename
209 if { [llength $tfiles] > 1 } {
210 set tfiles [join $tfiles ","]
211 set tfiles "{$tfiles}"
213 verbose "Cleanup final testcases: $tfiles" 4
214 # We have to quote the regex
215 regsub -all {([][$^?+*()|\\{}])} "$tfiles.$ptn" {\\\1} ptn
217 append final {remove-build-file }
218 append final "\"$ptn\""
219 verbose "Cleanup final: $final" 4
220 append finalcode "$final\n"
225 # Define gcc callbacks for dg.exp.
227 proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } {
228 # Set up the compiler flags, based on what we're going to do.
234 set compile_type "preprocess"
235 set output_file "[file rootname [file tail $prog]].i"
238 set compile_type "assembly"
239 set output_file "[file rootname [file tail $prog]].s"
242 set compile_type "object"
243 set output_file "[file rootname [file tail $prog]].o"
246 set compile_type "precompiled_header"
247 set output_file "[file tail $prog].gch"
250 set compile_type "executable"
251 set output_file "[file rootname [file tail $prog]].exe"
252 # The following line is needed for targets like the i960 where
253 # the default output file is b.out. Sigh.
256 set compile_type "object"
257 set output_file "[file rootname [file tail $prog]].o"
260 set compile_type "executable"
261 # FIXME: "./" is to cope with "." not being in $PATH.
262 # Should this be handled elsewhere?
264 set output_file "./[file rootname [file tail $prog]].exe"
265 # This is the only place where we care if an executable was
266 # created or not. If it was, dg.exp will try to run it.
267 catch { remote_file build delete $output_file }
270 perror "$do_what: not a valid dg-do keyword"
275 # Let { dg-final { action } } force options as returned by an
276 # optional proc ${action}_required_options.
277 upvar 2 dg-final-code finalcode
278 foreach x [split $finalcode "\n"] {
279 set finalcmd [lindex $x 0]
280 if { [info procs ${finalcmd}_required_options] != "" } {
281 foreach req [${finalcmd}_required_options] {
283 && [lsearch -exact $extra_tool_flags $req] == -1 } {
284 lappend extra_tool_flags $req
290 append finalcode [schedule-cleanups "$options $extra_tool_flags"]
291 if { $extra_tool_flags != "" } {
292 lappend options "additional_flags=$extra_tool_flags"
295 verbose "$target_compile $prog $output_file $compile_type $options" 4
296 set comp_output [$target_compile "$prog" "$output_file" "$compile_type" $options]
299 # Look for an internal compiler error, which sometimes masks the fact
300 # that we didn't get an expected error message. XFAIL an ICE via
301 # dg-xfail-if and use { dg-prune-output ".*internal compiler error.*" }
302 # to avoid a second failure for excess errors.
303 # "Error reporting routines re-entered" ICE says "Internal" rather than
304 # "internal", so match that too.
305 if [regexp -line -- {[Ii]nternal compiler error.*} $comp_output ice] {
307 if { $expect_ice == 0 } {
310 # We expected an ICE and we got it.
312 # Prune the ICE from the output.
313 set comp_output [prune_ices $comp_output]
315 } elseif { $expect_ice == 1 } {
317 # We expected an ICE but we didn't get it.
318 xpass "$name (internal compiler error)"
321 if { $do_what == "repo" } {
322 set object_file "$output_file"
323 set output_file "[file rootname [file tail $prog]].exe"
325 [ concat $comp_output \
326 [$target_compile "$object_file" "$output_file" \
327 "executable" $options] ]
330 return [list $comp_output $output_file]
333 proc gcc-dg-test { prog do_what extra_tool_flags } {
334 return [gcc-dg-test-1 gcc_target_compile $prog $do_what $extra_tool_flags]
337 # Global: should blank lines be allowed in the output?
338 # By default, they should not be. (PR other/69006)
339 # However, there are some ways for them to validly occur.
340 # If this variable is 0, blank lines are not allowed in output,
341 # if it is 1, they are allowed for a single testcase only and gcc-dg-prune
342 # will clear it again after checking it, if it is 2, they are disabled
344 set allow_blank_lines 0
346 if { [check_effective_target_llvm_binutils] } {
347 set allow_blank_lines 2
350 # A command for use by testcases to mark themselves as expecting
351 # blank lines in the output.
353 proc dg-allow-blank-lines-in-output { args } {
354 global allow_blank_lines
355 if { !$allow_blank_lines } {
356 set allow_blank_lines 1
360 proc gcc-dg-prune { system text } {
361 global additional_prunes
363 # Extra prune rules that will apply to tests defined in a .exp file.
364 # Always remember to clear it in .exp file after executed all tests.
365 global dg_runtest_extra_prunes
367 # Call into multiline.exp to handle any multiline output directives.
368 # This is done before the check for blank lines so that multiline
369 # output directives can have blank lines within them.
370 set text [handle-multiline-outputs $text]
372 # Complain about blank lines in the output (PR other/69006)
373 global allow_blank_lines
374 if { !$allow_blank_lines } {
375 set num_blank_lines [llength [regexp -all -inline "\n\n" $text]]
376 if { $num_blank_lines } {
377 global testname_with_flags
378 fail "$testname_with_flags $num_blank_lines blank line(s) in output"
381 if { $allow_blank_lines == 1 } {
382 set allow_blank_lines 0
385 set text [prune_gcc_output $text]
387 foreach p "$additional_prunes $dg_runtest_extra_prunes" {
388 if { [string length $p] > 0 } {
389 # Following regexp matches a complete line containing $p.
390 regsub -all "(^|\n)\[^\n\]*$p\[^\n\]*" $text "" text
394 # If we see "region xxx is full" then the testcase is too big for ram.
395 # This is tricky to deal with in a large testsuite like c-torture so
396 # deal with it here. Just mark the testcase as unsupported.
397 if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] {
398 # The format here is important. See dg.exp.
399 return "::unsupported::memory full"
402 if { [regexp "(^|\n)\[^\n\]*: relocation truncated to fit" $text]
403 && [check_effective_target_tiny] } {
404 return "::unsupported::memory full"
407 if [regexp "(^|\n)\[^\n\]* section.*will not fit in region" $text] {
408 return "::unsupported::memory full"
411 if [regexp "(^|\n)\[^\n\]* region.*overflowed by" $text] {
412 return "::unsupported::memory full"
415 if { [string match "*error: function pointers not supported*" $text]
416 && ![check_effective_target_function_pointers] } {
417 # The format here is important. See dg.exp.
418 return "::unsupported::funcptr"
420 if { [string match "*error: large return values not supported*" $text]
421 && ![check_effective_target_large_return_values] } {
422 # The format here is important. See dg.exp.
423 return "::unsupported::large return values"
426 # If exceptions are disabled, mark tests expecting exceptions to be enabled
428 if { ![check_effective_target_exceptions_enabled] } {
429 if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] {
430 return "::unsupported::exception handling disabled"
433 if [regexp "(^|\n)\[^\n\]*: error: #error .__cpp_exceptions." $text] {
434 return "::unsupported::exception handling disabled"
441 # Replace ${tool}_load with a wrapper to provide for an expected nonzero
442 # exit status. Multiple languages include this file so this handles them
444 if { [info procs ${tool}_load] != [list] \
445 && [info procs saved_${tool}_load] == [list] } {
446 rename ${tool}_load saved_${tool}_load
448 proc ${tool}_load { program args } {
451 global set_target_env_var
453 set saved_target_env_var [list]
454 if { [info exists set_target_env_var] \
455 && [llength $set_target_env_var] != 0 } {
456 if { [is_remote target] } {
457 return [list "unsupported" ""]
461 set result [eval [list saved_${tool}_load $program] $args]
462 if { [info exists set_target_env_var] \
463 && [llength $set_target_env_var] != 0 } {
464 restore-target-env-var
466 if { $shouldfail != 0 } {
467 switch [lindex $result 0] {
468 "pass" { set status "fail" }
469 "fail" { set status "pass" }
470 default { set status [lindex $result 0] }
472 set result [list $status [lindex $result 1]]
475 set result [list [lindex $result 0] [prune_file_path [lindex $result 1]]]
480 proc dg-set-target-env-var { args } {
481 global set_target_env_var
482 if { [llength $args] != 3 } {
483 error "dg-set-target-env-var: need two arguments"
486 set var [lindex $args 1]
487 set value [lindex $args 2]
488 verbose "dg-set-target-env-var $var $value" 2
489 lappend set_target_env_var [list $var $value]
492 proc set-target-env-var { } {
493 global set_target_env_var
494 upvar 1 saved_target_env_var saved_target_env_var
495 foreach env_var $set_target_env_var {
496 set var [lindex $env_var 0]
497 set value [lindex $env_var 1]
498 if [info exists ::env($var)] {
499 lappend saved_target_env_var [list $var 1 $::env($var)]
501 lappend saved_target_env_var [list $var 0]
507 proc restore-target-env-var { } {
508 upvar 1 saved_target_env_var saved_target_env_var
509 for { set env_vari [llength $saved_target_env_var] } {
510 [incr env_vari -1] >= 0 } {} {
511 set env_var [lindex $saved_target_env_var $env_vari]
512 set var [lindex $env_var 0]
513 if [lindex $env_var 1] {
514 setenv $var [lindex $env_var 2]
521 proc dg-set-compiler-env-var { args } {
522 global set_compiler_env_var
523 global saved_compiler_env_var
524 if { [llength $args] != 3 } {
525 error "dg-set-compiler-env-var: need two arguments"
528 set var [lindex $args 1]
529 set value [lindex $args 2]
530 verbose "dg-set-compiler-env-var $var $value" 2
531 if [info exists ::env($var)] {
532 lappend saved_compiler_env_var [list $var 1 $::env($var)]
534 lappend saved_compiler_env_var [list $var 0]
537 lappend set_compiler_env_var [list $var $value]
540 proc restore-compiler-env-var { } {
541 global saved_compiler_env_var
542 for { set env_vari [llength $saved_compiler_env_var] } {
543 [incr env_vari -1] >= 0 } {} {
544 set env_var [lindex $saved_compiler_env_var $env_vari]
545 set var [lindex $env_var 0]
546 if [lindex $env_var 1] {
547 setenv $var [lindex $env_var 2]
557 # search_for -- looks for a string match in a file
559 proc search_for { file pattern } {
560 set fd [open $file r]
561 while { [gets $fd cur_line]>=0 } {
562 if [string match "*$pattern*" $cur_line] then {
571 # Modified dg-runtest that can cycle through a list of optimization options
573 proc gcc-dg-runtest { testcases flags default-extra-flags } {
576 # Some callers initialize torture testing themselves; don't override those.
577 set existing_torture_init [torture-init-done]
578 if { $existing_torture_init == 0 } {
581 # Some callers set torture options themselves; don't override those.
582 set existing_torture_options [torture-options-exist]
583 if { $existing_torture_options == 0 } {
584 global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS
585 set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS
589 foreach test $testcases {
590 global torture_with_loops torture_without_loops
591 # If we're only testing specific files and this isn't one of
593 if ![runtest_file_p $runtests $test] {
597 # Look for a loop within the source code - if we don't find one,
598 # don't pass -funroll[-all]-loops.
599 if [expr [search_for $test "for*("]+[search_for $test "while*("]] {
600 set option_list $torture_with_loops
602 set option_list $torture_without_loops
605 set nshort [file tail [file dirname $test]]/[file tail $test]
607 foreach flags_t $option_list {
608 global torture_current_flags
609 set torture_current_flags "$flags_t"
610 verbose "Testing $nshort, $flags $flags_t" 1
611 dg-test $test "$flags $flags_t" ${default-extra-flags}
615 if { $existing_torture_init == 0 } {
620 # Check if frontend has CTF support
621 proc gcc-dg-frontend-supports-ctf { target_compile trivial } {
624 set comp_output [$target_compile \
625 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
626 "additional_flags=-gctf"]
627 if { ! [string match \
628 "*CTF debug info requested, but not supported for * frontend*" \
630 remove-build-file "trivial.S"
636 # Check if the target system supports the debug format
637 proc gcc-dg-target-supports-debug-format { target_compile trivial type } {
640 set comp_output [$target_compile \
641 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
642 "additional_flags=$type"]
643 if { ! [string match "*: target system does not support the * debug format*" \
645 remove-build-file "trivial.S"
651 proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } {
652 if ![info exists DEBUG_TORTURE_OPTIONS] {
653 set DEBUG_TORTURE_OPTIONS ""
654 foreach type {-gctf -gdwarf-2} {
655 if [expr [gcc-dg-target-supports-debug-format \
656 $target_compile $trivial $type]] {
657 if { $type == "-gctf" } {
658 if [expr [gcc-dg-frontend-supports-ctf \
659 $target_compile $trivial]] {
660 # At this time, running tests with various opt levels or
661 # ctf debug info levels does not add value.
662 lappend DEBUG_TORTURE_OPTIONS [list "${type}"]
666 foreach level {1 "" 3} {
667 if { ($type == "-gdwarf-2") && ($level != "") } {
668 lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"]
669 foreach opt $opt_opts {
670 lappend DEBUG_TORTURE_OPTIONS \
671 [list "${type}" "-g${level}" "$opt" ]
674 lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"]
675 foreach opt $opt_opts {
676 lappend DEBUG_TORTURE_OPTIONS \
677 [list "${type}${level}" "$opt" ]
685 verbose -log "Using options $DEBUG_TORTURE_OPTIONS"
689 foreach test $testcases {
690 # If we're only testing specific files and this isn't one of
692 if ![runtest_file_p $runtests $test] {
696 set nshort [file tail [file dirname $test]]/[file tail $test]
698 foreach flags $DEBUG_TORTURE_OPTIONS {
701 # These tests check for information which may be deliberately
703 if { ([string match {*/debug-[126].c} "$nshort"] \
704 || [string match {*/enum-1.c} "$nshort"] \
705 || [string match {*/enum-[12].C} "$nshort"]) \
706 && ([string match "*1" [lindex "$flags" 0] ]
707 || [lindex "$flags" 1] == "-g1") } {
711 # High optimization can remove the variable whose existence is tested.
712 # Dwarf debugging with commentary (-dA) preserves the symbol name in the
713 # assembler output, but stabs debugging does not.
714 # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html
715 if { [string match {*/debug-[12].c} "$nshort"] \
716 && [string match "*O*" "$flags"] \
717 && ( [string match "*coff*" "$flags"] \
718 || [string match "*stabs*" "$flags"] ) } {
722 # These tests check for information which is not emitted for CTF
723 # as CTF type information is emitted for entities at file and
725 if { ([string match {*/debug-[126].c} "$nshort"] \
726 || [string match {*/enum-[12].C} "$nshort"] ) \
727 && [string match "*ctf*" "$flags"] } {
732 verbose -log "Testing $nshort, $flags" 1
733 dg-test $test $flags ""
739 # Prune any messages matching ARGS[1] (a regexp) from test output.
740 proc dg-prune-output { args } {
741 global additional_prunes
743 if { [llength $args] != 2 } {
744 error "[lindex $args 1]: need one argument"
748 lappend additional_prunes [lindex $args 1]
751 # Remove files matching the pattern from the build machine.
752 proc remove-build-file { pat } {
753 verbose "remove-build-file `$pat'" 2
754 set file_list "[glob -nocomplain $pat]"
755 verbose "remove-build-file `$file_list'" 2
756 foreach output_file $file_list {
757 if [is_remote host] {
758 # Ensure the host knows the file is gone by deleting there
760 remote_file host delete $output_file
762 remote_file build delete $output_file
766 # Remove runtime-generated profile file for the current test.
767 proc cleanup-profile-file { } {
768 remove-build-file "mon.out"
769 remove-build-file "gmon.out"
772 # Remove compiler-generated coverage files for the current test.
773 proc cleanup-coverage-files { } {
774 global additional_sources_used
775 set testcase [testname-for-summary]
776 # The name might include a list of options; extract the file name.
777 set testcase [lindex $testcase 0]
778 remove-build-file "[file rootname [file tail $testcase]].gc??"
780 # Clean up coverage files for additional source files.
781 if [info exists additional_sources_used] {
782 foreach srcfile $additional_sources_used {
783 remove-build-file "[file rootname [file tail $srcfile]].gc??"
788 # Remove a final insns dump file for the current test.
789 proc cleanup-final-insns-dump { } {
790 set testcase [testname-for-summary]
791 # The name might include a list of options; extract the file name.
792 set testcase [lindex $testcase 0]
793 remove-build-file "[file rootname [file tail $testcase]].s.gkd"
795 # Clean up files for additional source files.
796 if [info exists additional_sources_used] {
797 foreach srcfile $additional_sources_used {
798 remove-build-file "[file rootname [file tail $srcfile]].s.gkd"
803 # Remove a stack usage file for the current test.
804 proc cleanup-stack-usage { } {
805 set testcase [testname-for-summary]
806 # The name might include a list of options; extract the file name.
807 set testcase [lindex $testcase 0]
808 remove-build-file "[file rootname [file tail $testcase]].su"
810 # Clean up files for additional source files.
811 if [info exists additional_sources_used] {
812 foreach srcfile $additional_sources_used {
813 remove-build-file "[file rootname [file tail $srcfile]].su"
818 # Remove an Ada spec file for the current test.
819 proc cleanup-ada-spec { } {
820 global additional_sources_used
821 set testcase [testname-for-summary]
822 remove-build-file "[get_ada_spec_filename $testcase]"
824 # Clean up files for additional source files.
825 if [info exists additional_sources_used] {
826 foreach srcfile $additional_sources_used {
827 remove-build-file "[get_ada_spec_filename $srcfile]"
832 # Remove files kept by --save-temps for the current test.
834 # Currently this is only .i, .ii, .s and .o files, but more can be added
835 # if there are tests generating them.
836 # ARGS is a list of suffixes to NOT delete.
837 proc cleanup-saved-temps { args } {
838 global additional_sources_used
841 # add the to-be-kept suffixes
842 foreach suffix {".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
843 if {[lsearch $args $suffix] < 0} {
844 lappend suffixes $suffix
848 set testcase [testname-for-summary]
849 # The name might include a list of options; extract the file name.
850 set testcase [lindex $testcase 0]
851 foreach suffix $suffixes {
852 remove-build-file "[file rootname [file tail $testcase]]$suffix"
853 remove-build-file "[file rootname [file tail $testcase]].exe$suffix"
854 remove-build-file "[file rootname [file tail $testcase]].exe.ltrans\[0-9\]*$suffix"
855 # -fcompare-debug dumps
856 remove-build-file "[file rootname [file tail $testcase]].gk$suffix"
859 # Clean up saved temp files for additional source files.
860 if [info exists additional_sources_used] {
861 foreach srcfile $additional_sources_used {
862 foreach suffix $suffixes {
863 remove-build-file "[file rootname [file tail $srcfile]]$suffix"
864 remove-build-file "[file rootname [file tail $srcfile]].exe$suffix"
865 remove-build-file "[file rootname [file tail $srcfile]].exe.ltrans\[0-9\]*$suffix"
867 # -fcompare-debug dumps
868 remove-build-file "[file rootname [file tail $srcfile]].gk$suffix"
875 # Files to be kept after cleanup of --save-temps for the current test.
876 # ARGS is a list of suffixes to NOT delete.
877 proc dg-keep-saved-temps { args } {
878 global keep_saved_temps_suffixes
879 set keep_saved_temps_suffixes {}
881 # add the to-be-kept suffixes
882 foreach suffix {".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
883 if {[lsearch $args $suffix] >= 0} {
884 lappend keep_saved_temps_suffixes $suffix
887 if { [llength keep_saved_temps_suffixes] < 1 } {
888 error "dg-keep-saved-temps ${args} did not match any known suffix"
892 # Scan Fortran modules for a given regexp.
894 # Argument 0 is the module name
895 # Argument 1 is the regexp to match
896 proc scan-module { args } {
897 set modfilename [string tolower [lindex $args 0]].mod
898 set fd [open [list | gzip -dc $modfilename] r]
902 set testcase [testname-for-summary]
903 if [regexp -- [lindex $args 1] $text] {
904 pass "$testcase scan-module [lindex $args 1]"
906 fail "$testcase scan-module [lindex $args 1]"
910 # Scan Fortran modules for absence of a given regexp.
912 # Argument 0 is the module name
913 # Argument 1 is the regexp to match
914 proc scan-module-absence { args } {
915 set modfilename [string tolower [lindex $args 0]].mod
916 set fd [open [list | gzip -dc $modfilename] r]
920 set testcase [testname-for-summary]
921 if [regexp -- [lindex $args 1] $text] {
922 fail "$testcase scan-module [lindex $args 1]"
924 pass "$testcase scan-module [lindex $args 1]"
928 # Verify that the compiler output file exists, invoked via dg-final.
929 proc output-exists { args } {
930 # Process an optional target or xfail list.
931 if { [llength $args] >= 1 } {
932 switch [dg-process-target [lindex $args 0]] {
935 "F" { setup_xfail "*-*-*" }
940 set testcase [testname-for-summary]
941 # Access variable from gcc-dg-test-1.
942 upvar 2 output_file output_file
944 if [file exists $output_file] {
945 pass "$testcase output-exists $output_file"
947 fail "$testcase output-exists $output_file"
951 # Verify that the compiler output file does not exist, invoked via dg-final.
952 proc output-exists-not { args } {
953 # Process an optional target or xfail list.
954 if { [llength $args] >= 1 } {
955 switch [dg-process-target [lindex $args 0]] {
958 "F" { setup_xfail "*-*-*" }
963 set testcase [testname-for-summary]
964 # Access variable from gcc-dg-test-1.
965 upvar 2 output_file output_file
967 if [file exists $output_file] {
968 fail "$testcase output-exists-not $output_file"
970 pass "$testcase output-exists-not $output_file"
974 # We need to make sure that additional_* are cleared out after every
975 # test. It is not enough to clear them out *before* the next test run
976 # because gcc-target-compile gets run directly from some .exp files
977 # (outside of any test). (Those uses should eventually be eliminated.)
979 # Because the DG framework doesn't provide a hook that is run at the
980 # end of a test, we must replace dg-test with a wrapper.
982 if { [info procs saved-dg-test] == [list] } {
983 rename dg-test saved-dg-test
985 # Helper function for cleanups that should happen after the call
986 # to the real dg-test, whether or not it returns normally, or
987 # fails with an error.
988 proc cleanup-after-saved-dg-test { } {
989 global additional_files
990 global additional_sources
991 global additional_sources_used
992 global additional_prunes
993 global compiler_conditional_xfail_data
996 global testname_with_flags
997 global set_target_env_var
998 global set_compiler_env_var
999 global saved_compiler_env_var
1000 global keep_saved_temps_suffixes
1001 global nn_line_numbers_enabled
1002 global multiline_expected_outputs
1003 global freeform_regexps
1004 global save_linenr_varnames
1006 set additional_files ""
1007 set additional_sources ""
1008 set additional_sources_used ""
1009 set additional_prunes ""
1012 if [info exists set_target_env_var] {
1013 unset set_target_env_var
1015 if [info exists set_compiler_env_var] {
1016 restore-compiler-env-var
1017 unset set_compiler_env_var
1018 unset saved_compiler_env_var
1020 if [info exists keep_saved_temps_suffixes] {
1021 unset keep_saved_temps_suffixes
1024 if [info exists compiler_conditional_xfail_data] {
1025 unset compiler_conditional_xfail_data
1027 if [info exists testname_with_flags] {
1028 unset testname_with_flags
1030 set nn_line_numbers_enabled 0
1031 set multiline_expected_outputs []
1032 set freeform_regexps []
1034 if { [info exists save_linenr_varnames] } {
1035 foreach varname $save_linenr_varnames {
1037 eval global $varname
1040 # Cleanup varname_used, or generate defined-but-not-used
1042 set varname_used used_$varname
1043 eval global $varname_used
1044 eval set used [info exists $varname_used]
1046 eval unset $varname_used
1048 regsub {^saved_linenr_} $varname "" org_varname
1049 warning "dg-line var $org_varname defined, but not used"
1052 unset save_linenr_varnames
1055 initialize_prune_notes
1058 proc dg-test { args } {
1061 if { [ catch { eval saved-dg-test $args } errmsg ] } {
1062 set saved_info $errorInfo
1063 cleanup-after-saved-dg-test
1064 error $errmsg $saved_info
1066 cleanup-after-saved-dg-test
1070 if { [info procs saved-dg-warning] == [list] \
1071 && [info exists gcc_warning_prefix] } {
1072 rename dg-warning saved-dg-warning
1074 proc dg-warning { args } {
1075 # Make this variable available here and to the saved proc.
1076 upvar dg-messages dg-messages
1077 global gcc_warning_prefix
1079 process-message saved-dg-warning "$gcc_warning_prefix" "$args"
1083 if { [info procs saved-dg-error] == [list] \
1084 && [info exists gcc_error_prefix] } {
1085 rename dg-error saved-dg-error
1087 proc dg-error { args } {
1088 # Make this variable available here and to the saved proc.
1089 upvar dg-messages dg-messages
1090 global gcc_error_prefix
1092 process-message saved-dg-error "$gcc_error_prefix" "$args"
1095 # Override dg-bogus at the same time. It doesn't handle a prefix
1096 # but its expression should include a column number. Otherwise the
1097 # line number can match the column number for other messages, leading
1099 rename dg-bogus saved-dg-bogus
1101 proc dg-bogus { args } {
1102 upvar dg-messages dg-messages
1103 process-message saved-dg-bogus "" $args
1107 # Set variable VARNAME to LINENR
1109 proc dg-line { linenr varname } {
1110 set org_varname $varname
1111 set varname "saved_linenr_$varname"
1112 eval global $varname
1114 # Generate defined-but-previously-defined error.
1115 eval set var_defined [info exists $varname]
1116 if { $var_defined } {
1117 eval set deflinenr \$$varname
1118 error "dg-line var $org_varname defined at line $linenr, but previously defined at line $deflinenr"
1122 eval set $varname $linenr
1124 # Schedule cleanup of varname by cleanup-after-saved-dg-test
1125 global save_linenr_varnames
1126 if { [info exists save_linenr_varnames] } {
1127 lappend save_linenr_varnames $varname
1129 set save_linenr_varnames [list $varname]
1133 # Get the absolute line number corresponding to:
1134 # - a relative line number (a non-null useline is required), or
1135 # - a line number variable reference.
1136 # Argument 0 is the line number on which line was used
1137 # Argument 1 is the relative line number or line number variable reference
1139 proc get-absolute-line { useline line } {
1140 if { "$line" == "." } {
1144 if { [regsub "^\.\[+-\](\[0-9\]+)$" $line "\\1" num] && $useline != "" } {
1145 # Handle relative line specification, .+1 or .-1 etc.
1146 set num [expr $useline [string index $line 1] $num]
1150 if { ! [regsub "^(\[a-zA-Z\]\[a-zA-Z0-9_\]*)$" $line "\\1" varname] } {
1154 # Handle linenr variable defined by dg-line
1155 set org_varname $varname
1156 set varname "saved_linenr_$varname"
1157 eval global $varname
1159 # Generate used-but-not-defined error.
1160 eval set var_defined [info exists $varname]
1161 if { ! $var_defined } {
1162 if { "$useline" != "" } {
1163 error "dg-line var $org_varname used at line $useline, but not defined"
1165 error "dg-line var $org_varname used, but not defined"
1170 # Note that varname has been used.
1171 set varname_used "used_$varname"
1172 eval global $varname_used
1173 eval set $varname_used 1
1175 # Get line number from var and use it.
1176 eval set num \$$varname
1180 # Modify the regular expression saved by a DejaGnu message directive to
1181 # include a prefix and to force the expression to match a single line.
1182 # MSGPROC is the procedure to call.
1183 # MSGPREFIX is the prefix to prepend.
1184 # DGARGS is the original argument list.
1186 proc process-message { msgproc msgprefix dgargs } {
1187 upvar dg-messages dg-messages
1189 if { [llength $dgargs] == 5 } {
1190 set useline [lindex $dgargs 0]
1192 # Resolve absolute line number.
1193 set line [get-absolute-line $useline [lindex $dgargs 4]]
1194 set dgargs [lreplace $dgargs 4 4 $line]
1196 if { $line != $useline } {
1197 # Make sure that we get unique test names if different USELINEs
1198 # refer to the same LINE.
1199 set comment "[lindex $dgargs 2] at line $useline"
1200 set dgargs [lreplace $dgargs 2 2 $comment]
1204 # Process the dg- directive, including adding the regular expression
1205 # to the new message entry in dg-messages.
1206 set msgcnt [llength ${dg-messages}]
1207 eval $msgproc $dgargs
1209 # If the target expression wasn't satisfied there is no new message.
1210 if { [llength ${dg-messages}] == $msgcnt } {
1214 # Get the entry for the new message. Prepend the message prefix to
1215 # the regular expression and make it match a single line.
1216 set newentry [lindex ${dg-messages} end]
1217 set expmsg [lindex $newentry 2]
1220 # Handle column numbers from the specified expression (if there is
1221 # one) and set up the search expression that will be used by DejaGnu.
1222 if [regexp {^-:} $expmsg] {
1223 # The expected column is -, so shouldn't appear.
1224 set expmsg [string range $expmsg 2 end]
1225 } elseif [regexp {^[0-9]+:} $expmsg column] {
1226 # The expression in the directive included a column number.
1227 # Remove it from the original expression and move it
1228 # to the proper place in the search expression.
1229 set expmsg [string range $expmsg [string length $column] end]
1230 set column "$column "
1231 } elseif [string match "" [lindex $newentry 0]] {
1232 # The specified line number is 0; don't expect a column number.
1234 # There is no column number in the search expression, but we
1235 # should expect one in the message itself.
1236 set column {[0-9]+: }
1238 set expmsg "$column$msgprefix\[^\n\]*$expmsg"
1239 set newentry [lreplace $newentry 2 2 $expmsg]
1241 set dg-messages [lreplace ${dg-messages} end end $newentry]
1242 verbose "process-message:\n${dg-messages}" 3
1245 # Look for messages that don't have standard prefixes.
1247 proc dg-message { args } {
1248 upvar dg-messages dg-messages
1249 process-message saved-dg-warning "" $args
1252 # Look for a location marker of the form
1254 # with no extra text (e.g. a line-span separator).
1256 proc dg-locus { args } {
1257 upvar dg-messages dg-messages
1259 # Process the dg- directive, including adding the regular expression
1260 # to the new message entry in dg-messages.
1261 set msgcnt [llength ${dg-messages}]
1262 eval saved-dg-warning $args
1264 # If the target expression wasn't satisfied there is no new message.
1265 if { [llength ${dg-messages}] == $msgcnt } {
1269 # Get the entry for the new message. Prepend the message prefix to
1270 # the regular expression and make it match a single line.
1271 set newentry [lindex ${dg-messages} end]
1272 set expmsg [lindex $newentry 2]
1274 set newentry [lreplace $newentry 2 2 $expmsg]
1275 set dg-messages [lreplace ${dg-messages} end end $newentry]
1276 verbose "process-message:\n${dg-messages}" 3
1279 # Handle output from -fopt-info for MSG_OPTIMIZED_LOCATIONS:
1280 # a successful optimization.
1282 proc dg-optimized { args } {
1283 # Make this variable available here and to the saved proc.
1284 upvar dg-messages dg-messages
1286 process-message saved-dg-warning "optimized:" "$args"
1289 # Handle output from -fopt-info for MSG_MISSED_OPTIMIZATION:
1290 # a missed optimization.
1292 proc dg-missed { args } {
1293 # Make this variable available here and to the saved proc.
1294 upvar dg-messages dg-messages
1296 process-message saved-dg-warning "missed:" "$args"
1299 # Look for messages with 'note: ' prefixes.
1300 # In addition to standard compiler diagnostics ('DK_NOTE', 'inform' functions,
1301 # "for additional details on an error message"),
1302 # this also includes output from '-fopt-info' for 'MSG_NOTE':
1303 # a general optimization info.
1304 # By default, any *excess* notes are pruned, meaning their appearance doesn't
1305 # trigger *excess errors*. However, if 'dg-note' is used at least once in a
1306 # testcase, they're not pruned and instead must *all* be handled explicitly.
1307 # Thus, if looking for just single instances of messages with 'note: ' prefixes
1308 # without caring for all of them, use 'dg-message "note: [...]"' instead of
1309 # 'dg-note', or use 'dg-note' together with 'dg-prune-output "note: "'.
1311 variable prune_notes
1313 proc initialize_prune_notes { } {
1318 initialize_prune_notes
1320 proc dg-note { args } {
1321 upvar dg-messages dg-messages
1326 process-message saved-dg-warning "note:" "$args"
1329 # Check the existence of a gdb in the path, and return true if there
1332 # Set env(GDB_FOR_GCC_TESTING) accordingly.
1334 proc gdb-exists { args } {
1335 if ![info exists ::env(GDB_FOR_GCC_TESTING)] {
1337 if ![info exists ::env(GDB_FOR_GCC_TESTING)] {
1338 if [info exists GDB] {
1339 setenv GDB_FOR_GCC_TESTING "$GDB"
1341 setenv GDB_FOR_GCC_TESTING "[transform gdb]"
1345 if { [which $::env(GDB_FOR_GCC_TESTING)] != 0 } {
1351 # Helper function for scan-symbol and scan-symbol-not. It scans a symbol in
1352 # the final executable and return 1 if present, otherwise fail.
1354 # Argument 0 is the regexp to match.
1355 # Argument 1 handles expected failures and the like
1356 proc scan-symbol-common { scan_directive args } {
1360 # Access variable from gcc-dg-test-1 or lto-execute.
1361 upvar 3 output_file output_file
1363 if { [llength $args] >= 2 } {
1364 switch [dg-process-target [lindex $args 1]] {
1367 "F" { setup_xfail "*-*-*" }
1372 # Find nm like we find g++ in g++.exp.
1373 if ![info exists nm] {
1374 set nm [findfile $base_dir/../../../binutils/nm \
1375 $base_dir/../../../binutils/nm \
1376 [findfile $base_dir/../../nm $base_dir/../../nm \
1377 [findfile $base_dir/nm $base_dir/nm \
1379 verbose -log "nm is $nm"
1382 set output_file "[glob -nocomplain $output_file]"
1383 if { $output_file == "" } {
1384 fail "$scan_directive $args: output file does not exist"
1388 set fd [open "| $nm $output_file" r]
1392 if [regexp -- [lindex $args 0] $text] {
1399 # Utility for scanning a symbol in the final executable, invoked via dg-final.
1400 # Call pass if pattern is present, otherwise fail.
1402 # Argument 0 is the regexp to match.
1403 # Argument 1 handles expected failures and the like
1404 proc scan-symbol { args } {
1405 set testcase [testname-for-summary]
1406 if { [scan-symbol-common "scan-symbol" $args]} {
1407 pass "$testcase scan-symbol $args"
1409 fail "$testcase scan-symbol $args"
1413 # Utility for scanning a symbol in the final executable, invoked via dg-final.
1414 # Call pass if pattern is absent, otherwise fail.
1416 # Argument 0 is the regexp to match.
1417 # Argument 1 handles expected failures and the like
1418 proc scan-symbol-not { args } {
1419 set testcase [testname-for-summary]
1420 if { [scan-symbol-common "scan-symbol-not" $args]} {
1421 fail "$testcase scan-symbol-not $args"
1423 pass "$testcase scan-symbol-not $args"
1427 # Transform a tool-name to its canonical-target-name by "transform"
1428 # (which may return the original name for native targets) but only if
1429 # testing out-of-tree. When in-tree, the tool is expected to be found
1430 # by its original name, typically with some build-directory prefix
1431 # prepended by the caller.
1432 proc gcc-transform-out-of-tree { args } {
1433 global TESTING_IN_BUILD_TREE
1434 if { [info exists TESTING_IN_BUILD_TREE] } {
1437 return [transform $args]
1440 set additional_prunes ""
1441 set dg_runtest_extra_prunes ""