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 scanltrans.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 #
Set TERM to xterm to ensure that URL escapes are disabled.
50 # This avoids issues where a diagnostic which could embed a URL
51 # is emitted before
-fdiagnostics
-plain
-output is handled
, where
52 # otherwise the output could be affected by the environment.
55 # Avoid sporadic data
-losses with expect
58 # Ensure GCC_COLORS is unset
, for the rare testcases that verify
59 # how output is colorized.
60 if [info exists ::env
(GCC_COLORS
) ] {
65 if ![info exists GCC_UNDER_TEST
] {
66 set GCC_UNDER_TEST
"[find_gcc]"
69 # This file may be sourced
, so don
't override environment settings
70 # that have been previously setup.
71 if { $orig_environment_saved == 0 } {
72 append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST]
73 set_ld_library_path_env_vars
76 # Some torture-options cause intermediate code output, unusable for
77 # testing using e.g. scan-assembler. In this variable are the options
78 # how to force it, when needed.
79 global gcc_set_required_options
80 set gcc_set_required_options ""
82 if [info exists TORTURE_OPTIONS] {
83 set DG_TORTURE_OPTIONS $TORTURE_OPTIONS
85 # It is theoretically beneficial to group all of the O2/O3 options together,
86 # as in many cases the compiler will generate identical executables for
87 # all of them--and the c-torture testsuite will skip testing identical
88 # executables multiple times.
89 # Also note that -finline-functions is explicitly included in one of the
90 # items below, even though -O3 is also specified, because some ports may
91 # choose to disable inlining functions by default, even when optimizing.
92 set DG_TORTURE_OPTIONS [list \
96 { -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions } \
100 if [check_effective_target_lto] {
101 set gcc_set_required_options "-ffat-lto-objects"
105 if [info exists ADDITIONAL_TORTURE_OPTIONS] {
106 set DG_TORTURE_OPTIONS \
107 [concat $DG_TORTURE_OPTIONS $ADDITIONAL_TORTURE_OPTIONS]
110 proc dg-final { args } {
111 upvar dg-final-code final-code
113 if { [llength $args] > 2 } {
114 error "[lindex $args 0]: too many arguments"
116 set line [lindex $args 0]
117 set code [lindex $args 1]
118 set directive [lindex $code 0]
121 set code [linsert $code 1 $line]
124 append final-code "$code\n"
127 global orig_environment_saved
129 # Deduce generated files from tool flags, return finalcode string
130 proc schedule-cleanups { opts } {
131 global additional_sources
134 lappend testcases [lindex [testname-for-summary] 0]
135 verbose "Cleanup testcases: $testcases" 4
136 if { [info exists additional_sources] && $additional_sources != "" } {
137 lappend testcases $additional_sources
138 verbose "Cleanup testcases, additional: $additional_sources" 4
140 verbose "Cleanup all options: $opts" 4
142 # First some fixups to transform stuff to something manageable ..
143 # --dump= should translate to -d with joined operand.
144 if [regexp -- {(^|\s+)--dump=[^\s]+(\s+|$)} $opts] {
145 regsub -all -- {--dump=} $opts {-d} opts
147 # -da and -dx are treated as shorthand for -fdump-rtl-all here
148 if [regexp -- {(^|\s+)-d[ax](\s+|$)} $opts] {
149 verbose "Cleanup -d seen" 4
150 lappend opts "-fdump-rtl-all"
152 # .. and don't question why there is
--dump
=? and
-d?
154 #
Then handle options that generate non
-dump files
156 #
-fprofile
-generate
-> cleanup
-coverage
-files
()
157 #
-fstack
-usage
-> cleanup
-stack
-usage
()
158 if [regexp
-- {(^|\s
+)-fstack
-usage
(\s
+|$
)} $opts
] {
159 verbose
"Cleanup -fstack-usage seen" 4
160 # append finalcode
"cleanup-stack-usage\n"
162 global keep_saved_temps_suffixes
163 if [info exists keep_saved_temps_suffixes
] {
164 verbose
"dg-keep-saved-temps ${keep_saved_temps_suffixes}" 2
166 #
-save
-temps
-> cleanup
-saved
-temps
()
167 if [regexp
-- {(^|\s
+)-?
-save
-temps
(\s
+|$
)} $opts
] {
168 verbose
"Cleanup -save-temps seen" 4
169 if [info exists keep_saved_temps_suffixes
] {
170 append finalcode
"cleanup-saved-temps ${keep_saved_temps_suffixes}\n"
172 append finalcode
"cleanup-saved-temps\n"
175 if [info exists keep_saved_temps_suffixes
] {
176 error
"dg-keep-saved-temps specified but testcase does not -save-temps"
180 # Finally see
if there are
any dumps in opts
, otherwise we are done
181 if [regexp
-- {(?
=(?
:^|
[ \t]+)?
)-fdump
-[^
\t]+(?
=(?
:$|
[ \t]+)?
)} $opts
] {
182 # Lang
, Ipa
, Rtl
, Tree
for simplicity
187 # stem.ext.
<passnum
><fam
>.
<passname
><pass
-instances
>
188 #
(tree
)passes can have multiple instances
, thus optional trailing
*
189 set ptn
"\[0-9\]\[0-9\]\[0-9\]$ptn.*"
190 # Handle ltrans files around
-flto
191 if [regexp
-- {(^|\s
+)-flto
(\s
+|$
)} $opts
] {
192 verbose
"Cleanup -flto seen" 4
193 set ltrans
"{ltrans\[0-9\]*{.ltrans,}.,}"
197 set ptn
"$ltrans$ptn"
198 verbose
"Cleanup final ptn: $ptn" 4
200 foreach src $testcases
{
201 set basename
[file tail $src
]
202 if { $ltrans
!= "" } {
203 # ??? should we use upvar
1 output_file instead of this
(dup ?
)
204 set stem
[file rootname $basename
]
205 set basename_ext
[file extension $basename
]
206 if {$basename_ext
!= ""} {
207 regsub
-- {^.
*\.
} $basename_ext
{} basename_ext
209 lappend tfiles
"$stem{.$basename_ext,.exe,}"
212 lappend tfiles $basename
215 if { [llength $tfiles
] > 1 } {
216 set tfiles
[join $tfiles
","]
217 set tfiles
"{$tfiles}"
219 verbose
"Cleanup final testcases: $tfiles" 4
220 # We have to quote the regex
221 regsub
-all
{([][$^?
+*()|
\\{}])} "$tfiles.$ptn" {\\\1} ptn
223 append final
{remove
-build
-file
}
224 append final
"\"$ptn\""
225 verbose
"Cleanup final: $final" 4
226 append finalcode
"$final\n"
231 #
Define gcc callbacks
for dg.exp.
233 proc gcc
-dg
-test
-1 { target_compile prog do_what extra_tool_flags
} {
234 #
Set up the compiler flags
, based
on what we
're going to do.
240 set compile_type "preprocess"
241 set output_file "[file rootname [file tail $prog]].i"
244 set compile_type "assembly"
245 set output_file "[file rootname [file tail $prog]].s"
248 set compile_type "object"
249 set output_file "[file rootname [file tail $prog]].o"
252 set compile_type "precompiled_header"
253 set output_file "[file tail $prog].gch"
256 set compile_type "executable"
257 set output_file "[file rootname [file tail $prog]].exe"
258 # The following line is needed for targets like the i960 where
259 # the default output file is b.out. Sigh.
262 set compile_type "object"
263 set output_file "[file rootname [file tail $prog]].o"
266 set compile_type "executable"
267 # FIXME: "./" is to cope with "." not being in $PATH.
268 # Should this be handled elsewhere?
270 set output_file "./[file rootname [file tail $prog]].exe"
271 # This is the only place where we care if an executable was
272 # created or not. If it was, dg.exp will try to run it.
273 catch { remote_file build delete $output_file }
276 perror "$do_what: not a valid dg-do keyword"
281 # Let { dg-final { action } } force options as returned by an
282 # optional proc ${action}_required_options.
283 upvar 2 dg-final-code finalcode
284 foreach x [split $finalcode "\n"] {
285 set finalcmd [lindex $x 0]
286 if { [info procs ${finalcmd}_required_options] != "" } {
287 foreach req [${finalcmd}_required_options] {
289 && [lsearch -exact $extra_tool_flags $req] == -1 } {
290 lappend extra_tool_flags $req
296 append finalcode [schedule-cleanups "$options $extra_tool_flags"]
297 if { $extra_tool_flags != "" } {
298 lappend options "additional_flags=$extra_tool_flags"
301 verbose "$target_compile $prog $output_file $compile_type $options" 4
302 set comp_output [$target_compile "$prog" "$output_file" "$compile_type" $options]
305 # Look for an internal compiler error, which sometimes masks the fact
306 # that we didn't
get an expected error message. XFAIL an ICE via
307 # dg
-xfail
-if and use
{ dg
-prune
-output
".*internal compiler error.*" }
308 # to avoid a second failure
for excess errors.
309 #
"Error reporting routines re-entered" ICE says "Internal" rather than
310 #
"internal", so match that too.
311 if [regexp
-line
-- {[Ii
]nternal compiler error.
*} $comp_output ice
] {
313 if { $expect_ice
== 0 } {
316 # We expected an ICE and we got it.
318 # Prune the ICE from the output.
319 set comp_output
[prune_ices $comp_output
]
321 } elseif
{ $expect_ice
== 1 } {
323 # We expected an ICE but we didn
't get it.
324 xpass "$name (internal compiler error)"
327 if { $do_what == "repo" } {
328 set object_file "$output_file"
329 set output_file "[file rootname [file tail $prog]].exe"
331 [ concat $comp_output \
332 [$target_compile "$object_file" "$output_file" \
333 "executable" $options] ]
336 return [list $comp_output $output_file]
339 proc gcc-dg-test { prog do_what extra_tool_flags } {
340 return [gcc-dg-test-1 gcc_target_compile $prog $do_what $extra_tool_flags]
343 # Global: should blank lines be allowed in the output?
344 # By default, they should not be. (PR other/69006)
345 # However, there are some ways for them to validly occur.
346 # If this variable is 0, blank lines are not allowed in output,
347 # if it is 1, they are allowed for a single testcase only and gcc-dg-prune
348 # will clear it again after checking it, if it is 2, they are disabled
350 set allow_blank_lines 0
352 if { [check_effective_target_llvm_binutils] } {
353 set allow_blank_lines 2
356 # A command for use by testcases to mark themselves as expecting
357 # blank lines in the output.
359 proc dg-allow-blank-lines-in-output { args } {
360 global allow_blank_lines
361 if { !$allow_blank_lines } {
362 set allow_blank_lines 1
366 proc gcc-dg-prune { system text } {
367 global additional_prunes
369 # Extra prune rules that will apply to tests defined in a .exp file.
370 # Always remember to clear it in .exp file after executed all tests.
371 global dg_runtest_extra_prunes
373 # Call into multiline.exp to handle any multiline output directives.
374 # This is done before the check for blank lines so that multiline
375 # output directives can have blank lines within them.
376 set text [handle-multiline-outputs $text]
378 # Complain about blank lines in the output (PR other/69006)
379 global allow_blank_lines
380 if { !$allow_blank_lines } {
381 set num_blank_lines [llength [regexp -all -inline "\n\n" $text]]
382 if { $num_blank_lines } {
383 global testname_with_flags
384 fail "$testname_with_flags $num_blank_lines blank line(s) in output"
387 if { $allow_blank_lines == 1 } {
388 set allow_blank_lines 0
391 set text [prune_gcc_output $text]
393 foreach p "$additional_prunes $dg_runtest_extra_prunes" {
394 if { [string length $p] > 0 } {
395 # Following regexp matches a complete line containing $p.
396 regsub -all "(^|\n)\[^\n\]*$p\[^\n\]*" $text "" text
400 # If we see "region xxx is full" then the testcase is too big for ram.
401 # This is tricky to deal with in a large testsuite like c-torture so
402 # deal with it here. Just mark the testcase as unsupported.
403 if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] {
404 # The format here is important. See dg.exp.
405 return "::unsupported::memory full"
408 if { [regexp "(^|\n)\[^\n\]*: relocation truncated to fit" $text]
409 && [check_effective_target_tiny] } {
410 return "::unsupported::memory full"
413 if [regexp "(^|\n)\[^\n\]* section.*will not fit in region" $text] {
414 return "::unsupported::memory full"
417 if [regexp "(^|\n)\[^\n\]* region.*overflowed by" $text] {
418 return "::unsupported::memory full"
421 if { [string match "*error: function pointers not supported*" $text]
422 && ![check_effective_target_function_pointers] } {
423 # The format here is important. See dg.exp.
424 return "::unsupported::funcptr"
426 if { [string match "*error: large return values not supported*" $text]
427 && ![check_effective_target_large_return_values] } {
428 # The format here is important. See dg.exp.
429 return "::unsupported::large return values"
432 # If exceptions are disabled, mark tests expecting exceptions to be enabled
434 if { ![check_effective_target_exceptions_enabled] } {
435 if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] {
436 return "::unsupported::exception handling disabled"
439 if [regexp "(^|\n)\[^\n\]*: error: #error .__cpp_exceptions." $text] {
440 return "::unsupported::exception handling disabled"
447 # Replace ${tool}_load with a wrapper to provide for an expected nonzero
448 # exit status. Multiple languages include this file so this handles them
450 if { [info procs ${tool}_load] != [list] \
451 && [info procs saved_${tool}_load] == [list] } {
452 rename ${tool}_load saved_${tool}_load
454 proc ${tool}_load { program args } {
457 global set_target_env_var
459 set saved_target_env_var [list]
460 if { [info exists set_target_env_var] \
461 && [llength $set_target_env_var] != 0 } {
462 if { [is_remote target] } {
463 return [list "unsupported" ""]
467 set result [eval [list saved_${tool}_load $program] $args]
468 if { [info exists set_target_env_var] \
469 && [llength $set_target_env_var] != 0 } {
470 restore-target-env-var
472 if { $shouldfail != 0 } {
473 switch [lindex $result 0] {
474 "pass" { set status "fail" }
475 "fail" { set status "pass" }
476 default { set status [lindex $result 0] }
478 set result [list $status [lindex $result 1]]
481 set result [list [lindex $result 0] [prune_file_path [lindex $result 1]]]
486 proc dg-set-target-env-var { args } {
487 global set_target_env_var
488 if { [llength $args] != 3 } {
489 error "dg-set-target-env-var: need two arguments"
492 set var [lindex $args 1]
493 set value [lindex $args 2]
494 verbose "dg-set-target-env-var $var $value" 2
495 lappend set_target_env_var [list $var $value]
498 proc set-target-env-var { } {
499 global set_target_env_var
500 upvar 1 saved_target_env_var saved_target_env_var
501 foreach env_var $set_target_env_var {
502 set var [lindex $env_var 0]
503 set value [lindex $env_var 1]
504 if [info exists ::env($var)] {
505 lappend saved_target_env_var [list $var 1 $::env($var)]
507 lappend saved_target_env_var [list $var 0]
513 proc restore-target-env-var { } {
514 upvar 1 saved_target_env_var saved_target_env_var
515 for { set env_vari [llength $saved_target_env_var] } {
516 [incr env_vari -1] >= 0 } {} {
517 set env_var [lindex $saved_target_env_var $env_vari]
518 set var [lindex $env_var 0]
519 if [lindex $env_var 1] {
520 setenv $var [lindex $env_var 2]
527 proc dg-set-compiler-env-var { args } {
528 global set_compiler_env_var
529 global saved_compiler_env_var
530 if { [llength $args] != 3 } {
531 error "dg-set-compiler-env-var: need two arguments"
534 set var [lindex $args 1]
535 set value [lindex $args 2]
536 verbose "dg-set-compiler-env-var $var $value" 2
537 if [info exists ::env($var)] {
538 lappend saved_compiler_env_var [list $var 1 $::env($var)]
540 lappend saved_compiler_env_var [list $var 0]
543 lappend set_compiler_env_var [list $var $value]
546 proc restore-compiler-env-var { } {
547 global saved_compiler_env_var
548 for { set env_vari [llength $saved_compiler_env_var] } {
549 [incr env_vari -1] >= 0 } {} {
550 set env_var [lindex $saved_compiler_env_var $env_vari]
551 set var [lindex $env_var 0]
552 if [lindex $env_var 1] {
553 setenv $var [lindex $env_var 2]
563 # search_for -- looks for a string match in a file
565 proc search_for { file pattern } {
566 set fd [open $file r]
567 while { [gets $fd cur_line]>=0 } {
568 if [string match "*$pattern*" $cur_line] then {
577 # get_matching_lines -- return a list of matching lines in file
578 proc get_matching_lines { file pattern } {
580 set fd [open $file r]
581 while { [gets $fd cur_line]>=0 } {
582 if [string match "*$pattern*" $cur_line] then {
583 lappend lines $cur_line
590 # Modified dg-runtest that can cycle through a list of optimization options
592 proc gcc-dg-runtest { testcases flags default-extra-flags } {
595 # Some callers initialize torture testing themselves; don't override those.
596 set existing_torture_init
[torture
-init
-done
]
597 if { $existing_torture_init
== 0 } {
600 # Some callers
set torture options themselves
; don
't override those.
601 set existing_torture_options [torture-options-exist]
602 if { $existing_torture_options == 0 } {
603 global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS
604 set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS
608 foreach test $testcases {
609 global torture_with_loops torture_without_loops
610 # If we're only testing specific files and this isn
't one of
612 if ![runtest_file_p $runtests $test] {
616 # Look for a loop within the source code - if we don't find one
,
617 # don
't pass -funroll[-all]-loops.
618 if [expr [search_for $test "for*("]+[search_for $test "while*("]] {
619 set option_list $torture_with_loops
621 set option_list $torture_without_loops
624 set nshort [file tail [file dirname $test]]/[file tail $test]
626 foreach flags_t $option_list {
627 global torture_current_flags
628 set torture_current_flags "$flags_t"
629 verbose "Testing $nshort, $flags $flags_t" 1
630 dg-test $test "$flags $flags_t" ${default-extra-flags}
634 if { $existing_torture_init == 0 } {
639 # Check if frontend has CTF support
640 proc gcc-dg-frontend-supports-ctf { target_compile trivial } {
643 set comp_output [$target_compile \
644 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
645 "additional_flags=-gctf"]
646 if { ! [string match \
647 "*CTF debug info requested, but not supported for * frontend*" \
649 remove-build-file "trivial.S"
655 # Check if the target system supports the debug format
656 proc gcc-dg-target-supports-debug-format { target_compile trivial type } {
659 set comp_output [$target_compile \
660 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
661 "additional_flags=$type"]
662 if { ! [string match "*: target system does not support the * debug format*" \
664 remove-build-file "trivial.S"
670 proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } {
671 if ![info exists DEBUG_TORTURE_OPTIONS] {
672 set DEBUG_TORTURE_OPTIONS ""
673 foreach type {-gctf -gdwarf-2} {
674 if [expr [gcc-dg-target-supports-debug-format \
675 $target_compile $trivial $type]] {
676 if { $type == "-gctf" } {
677 if [expr [gcc-dg-frontend-supports-ctf \
678 $target_compile $trivial]] {
679 # At this time, running tests with various opt levels or
680 # ctf debug info levels does not add value.
681 lappend DEBUG_TORTURE_OPTIONS [list "${type}"]
685 foreach level {1 "" 3} {
686 if { ($type == "-gdwarf-2") && ($level != "") } {
687 lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"]
688 foreach opt $opt_opts {
689 lappend DEBUG_TORTURE_OPTIONS \
690 [list "${type}" "-g${level}" "$opt" ]
693 lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"]
694 foreach opt $opt_opts {
695 lappend DEBUG_TORTURE_OPTIONS \
696 [list "${type}${level}" "$opt" ]
704 verbose -log "Using options $DEBUG_TORTURE_OPTIONS"
708 foreach test $testcases {
709 # If we're only testing specific files and this isn
't one of
711 if ![runtest_file_p $runtests $test] {
715 set nshort [file tail [file dirname $test]]/[file tail $test]
717 foreach flags $DEBUG_TORTURE_OPTIONS {
720 # These tests check for information which may be deliberately
722 if { ([string match {*/debug-[126].c} "$nshort"] \
723 || [string match {*/enum-1.c} "$nshort"] \
724 || [string match {*/enum-[12].C} "$nshort"]) \
725 && ([string match "*1" [lindex "$flags" 0] ]
726 || [lindex "$flags" 1] == "-g1") } {
730 # High optimization can remove the variable whose existence is tested.
731 # Dwarf debugging with commentary (-dA) preserves the symbol name in the
732 # assembler output, but stabs debugging does not.
733 # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html
734 if { [string match {*/debug-[12].c} "$nshort"] \
735 && [string match "*O*" "$flags"] \
736 && ( [string match "*coff*" "$flags"] \
737 || [string match "*stabs*" "$flags"] ) } {
741 # These tests check for information which is not emitted for CTF
742 # as CTF type information is emitted for entities at file and
744 if { ([string match {*/debug-[126].c} "$nshort"] \
745 || [string match {*/enum-[12].C} "$nshort"] ) \
746 && [string match "*ctf*" "$flags"] } {
751 verbose -log "Testing $nshort, $flags" 1
752 dg-test $test $flags ""
758 # Prune any messages matching ARGS[1] (a regexp) from test output.
759 proc dg-prune-output { args } {
760 global additional_prunes
762 if { [llength $args] != 2 } {
763 error "[lindex $args 1]: need one argument"
767 lappend additional_prunes [lindex $args 1]
770 # Remove files matching the pattern from the build machine.
771 proc remove-build-file { pat } {
772 verbose "remove-build-file `$pat'" 2
773 set file_list
"[glob -nocomplain $pat]"
774 verbose
"remove-build-file `$file_list'" 2
775 foreach output_file $file_list
{
776 if [is_remote host
] {
777 # Ensure the host knows the file is gone by deleting there
779 remote_file host
delete $output_file
781 remote_file build
delete $output_file
785 # Remove runtime
-generated profile file
for the current test.
786 proc cleanup
-profile
-file
{ } {
787 remove
-build
-file
"mon.out"
788 remove
-build
-file
"gmon.out"
791 # Remove compiler
-generated coverage files
for the current test.
792 proc cleanup
-coverage
-files
{ } {
793 global additional_sources_used
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]].gc??"
799 # Clean up coverage 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]].gc??"
807 # Remove a final insns dump file
for the current test.
808 proc cleanup
-final
-insns
-dump
{ } {
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]].s.gkd"
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]].s.gkd"
822 # Remove a stack usage file
for the current test.
823 proc cleanup
-stack
-usage
{ } {
824 set testcase
[testname
-for-summary
]
825 # The
name might
include a list of options
; extract the file
name.
826 set testcase
[lindex $testcase
0]
827 remove
-build
-file
"[file rootname [file tail $testcase]].su"
829 # Clean up files
for additional source files.
830 if [info exists additional_sources_used
] {
831 foreach srcfile $additional_sources_used
{
832 remove
-build
-file
"[file rootname [file tail $srcfile]].su"
837 # Remove an Ada spec file
for the current test.
838 proc cleanup
-ada
-spec
{ } {
839 global additional_sources_used
840 set testcase
[testname
-for-summary
]
841 remove
-build
-file
"[get_ada_spec_filename $testcase]"
843 # Clean up files
for additional source files.
844 if [info exists additional_sources_used
] {
845 foreach srcfile $additional_sources_used
{
846 remove
-build
-file
"[get_ada_spec_filename $srcfile]"
851 # Remove files kept by
--save
-temps
for the current test.
853 # Currently this is only .i
, .ii
, .s and .o files
, but more can be added
854 #
if there are tests generating them.
855 #
ARGS is a list of suffixes to NOT
delete.
856 proc cleanup
-saved
-temps
{ args } {
857 global additional_sources_used
860 # add the to
-be
-kept suffixes
861 foreach suffix
{".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
862 if {[lsearch $
args $suffix
] < 0} {
863 lappend suffixes $suffix
867 set testcase
[testname
-for-summary
]
868 # The
name might
include a list of options
; extract the file
name.
869 set testcase
[lindex $testcase
0]
870 foreach suffix $suffixes
{
871 remove
-build
-file
"[file rootname [file tail $testcase]]$suffix"
872 remove
-build
-file
"[file rootname [file tail $testcase]].exe$suffix"
873 remove
-build
-file
"[file rootname [file tail $testcase]].exe.ltrans\[0-9\]*$suffix"
874 #
-fcompare
-debug dumps
875 remove
-build
-file
"[file rootname [file tail $testcase]].gk$suffix"
878 # Clean up saved temp files
for additional source files.
879 if [info exists additional_sources_used
] {
880 foreach srcfile $additional_sources_used
{
881 foreach suffix $suffixes
{
882 remove
-build
-file
"[file rootname [file tail $srcfile]]$suffix"
883 remove
-build
-file
"[file rootname [file tail $srcfile]].exe$suffix"
884 remove
-build
-file
"[file rootname [file tail $srcfile]].exe.ltrans\[0-9\]*$suffix"
886 #
-fcompare
-debug dumps
887 remove
-build
-file
"[file rootname [file tail $srcfile]].gk$suffix"
894 # Files to be kept after cleanup of
--save
-temps
for the current test.
895 #
ARGS is a list of suffixes to NOT
delete.
896 proc dg
-keep
-saved
-temps
{ args } {
897 global keep_saved_temps_suffixes
898 set keep_saved_temps_suffixes
{}
900 # add the to
-be
-kept suffixes
901 foreach suffix
{".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
902 if {[lsearch $
args $suffix
] >= 0} {
903 lappend keep_saved_temps_suffixes $suffix
906 if { [llength keep_saved_temps_suffixes
] < 1 } {
907 error
"dg-keep-saved-temps ${args} did not match any known suffix"
911 # Scan Fortran modules
for a given regexp.
913 #
Argument 0 is the module
name
914 #
Argument 1 is the regexp to match
915 proc scan
-module
{ args } {
916 set modfilename
[string tolower
[lindex $
args 0]].mod
917 set fd
[open
[list | gzip
-dc $modfilename
] r
]
921 set testcase
[testname
-for-summary
]
922 if [regexp
-- [lindex $
args 1] $
text] {
923 pass
"$testcase scan-module [lindex $args 1]"
925 fail
"$testcase scan-module [lindex $args 1]"
929 # Scan Fortran modules
for absence of a given regexp.
931 #
Argument 0 is the module
name
932 #
Argument 1 is the regexp to match
933 proc scan
-module
-absence
{ args } {
934 set modfilename
[string tolower
[lindex $
args 0]].mod
935 set fd
[open
[list | gzip
-dc $modfilename
] r
]
939 set testcase
[testname
-for-summary
]
940 if [regexp
-- [lindex $
args 1] $
text] {
941 fail
"$testcase scan-module [lindex $args 1]"
943 pass
"$testcase scan-module [lindex $args 1]"
947 # Verify that the compiler output file
exists, invoked via dg
-final.
948 proc output
-exists { args } {
949 # Process an optional target or xfail list.
950 if { [llength $
args] >= 1 } {
951 switch [dg
-process
-target
[lindex $
args 0]] {
954 "F" { setup_xfail "*-*-*" }
959 set testcase
[testname
-for-summary
]
960 # Access
variable from gcc
-dg
-test
-1.
961 upvar
2 output_file output_file
963 if [file
exists $output_file
] {
964 pass
"$testcase output-exists $output_file"
966 fail
"$testcase output-exists $output_file"
970 # Verify that the compiler output file does not exist
, invoked via dg
-final.
971 proc output
-exists-not
{ args } {
972 # Process an optional target or xfail list.
973 if { [llength $
args] >= 1 } {
974 switch [dg
-process
-target
[lindex $
args 0]] {
977 "F" { setup_xfail "*-*-*" }
982 set testcase
[testname
-for-summary
]
983 # Access
variable from gcc
-dg
-test
-1.
984 upvar
2 output_file output_file
986 if [file
exists $output_file
] {
987 fail
"$testcase output-exists-not $output_file"
989 pass
"$testcase output-exists-not $output_file"
993 # We need to make sure that additional_
* are cleared out after
every
994 # test. It is not enough to clear them out
*before
* the next test run
995 # because gcc
-target
-compile gets run directly from some .exp files
996 #
(outside of
any test
).
(Those uses should eventually be eliminated.
)
998 # Because the DG framework doesn
't provide a hook that is run at the
999 # end of a test, we must replace dg-test with a wrapper.
1001 if { [info procs saved-dg-test] == [list] } {
1002 rename dg-test saved-dg-test
1004 # Helper function for cleanups that should happen after the call
1005 # to the real dg-test, whether or not it returns normally, or
1006 # fails with an error.
1007 proc cleanup-after-saved-dg-test { } {
1008 global additional_files
1009 global additional_sources
1010 global additional_sources_used
1011 global additional_prunes
1012 global compiler_conditional_xfail_data
1015 global testname_with_flags
1016 global set_target_env_var
1017 global set_compiler_env_var
1018 global saved_compiler_env_var
1019 global keep_saved_temps_suffixes
1020 global nn_line_numbers_enabled
1021 global multiline_expected_outputs
1022 global freeform_regexps
1023 global save_linenr_varnames
1025 set additional_files ""
1026 set additional_sources ""
1027 set additional_sources_used ""
1028 set additional_prunes ""
1031 if [info exists set_target_env_var] {
1032 unset set_target_env_var
1034 if [info exists set_compiler_env_var] {
1035 restore-compiler-env-var
1036 unset set_compiler_env_var
1037 unset saved_compiler_env_var
1039 if [info exists keep_saved_temps_suffixes] {
1040 unset keep_saved_temps_suffixes
1043 if [info exists compiler_conditional_xfail_data] {
1044 unset compiler_conditional_xfail_data
1046 if [info exists testname_with_flags] {
1047 unset testname_with_flags
1049 set nn_line_numbers_enabled 0
1050 set multiline_expected_outputs []
1051 set freeform_regexps []
1053 if { [info exists save_linenr_varnames] } {
1054 foreach varname $save_linenr_varnames {
1056 eval global $varname
1059 # Cleanup varname_used, or generate defined-but-not-used
1061 set varname_used used_$varname
1062 eval global $varname_used
1063 eval set used [info exists $varname_used]
1065 eval unset $varname_used
1067 regsub {^saved_linenr_} $varname "" org_varname
1068 warning "dg-line var $org_varname defined, but not used"
1071 unset save_linenr_varnames
1074 initialize_prune_notes
1077 proc dg-test { args } {
1080 if { [ catch { eval saved-dg-test $args } errmsg ] } {
1081 set saved_info $errorInfo
1082 cleanup-after-saved-dg-test
1083 error $errmsg $saved_info
1085 cleanup-after-saved-dg-test
1089 if { [info procs saved-dg-warning] == [list] \
1090 && [info exists gcc_warning_prefix] } {
1091 rename dg-warning saved-dg-warning
1093 proc dg-warning { args } {
1094 # Make this variable available here and to the saved proc.
1095 upvar dg-messages dg-messages
1096 global gcc_warning_prefix
1098 process-message saved-dg-warning "$gcc_warning_prefix" "$args"
1102 if { [info procs saved-dg-error] == [list] \
1103 && [info exists gcc_error_prefix] } {
1104 rename dg-error saved-dg-error
1106 proc dg-error { args } {
1107 # Make this variable available here and to the saved proc.
1108 upvar dg-messages dg-messages
1109 global gcc_error_prefix
1111 process-message saved-dg-error "$gcc_error_prefix" "$args"
1114 # Override dg-bogus at the same time. It doesn't handle a prefix
1115 # but its expression should
include a column number. Otherwise the
1116 # line number can match the column number
for other messages
, leading
1118 rename dg
-bogus saved
-dg
-bogus
1120 proc dg
-bogus
{ args } {
1121 upvar dg
-messages dg
-messages
1122 process
-message saved
-dg
-bogus
"" $args
1126 #
Set variable VARNAME to LINENR
1128 proc dg
-line
{ linenr varname
} {
1129 set org_varname $varname
1130 set varname
"saved_linenr_$varname"
1131 eval global $varname
1133 # Generate defined
-but
-previously
-defined error.
1134 eval
set var_defined
[info exists $varname
]
1135 if { $var_defined
} {
1136 eval
set deflinenr \$$varname
1137 error
"dg-line var $org_varname defined at line $linenr, but previously defined at line $deflinenr"
1141 eval
set $varname $linenr
1143 # Schedule cleanup of varname by cleanup
-after
-saved
-dg
-test
1144 global save_linenr_varnames
1145 if { [info exists save_linenr_varnames
] } {
1146 lappend save_linenr_varnames $varname
1148 set save_linenr_varnames
[list $varname
]
1152 #
Get the absolute line number corresponding to
:
1153 #
- a relative line number
(a non
-null useline is required
), or
1154 #
- a line number
variable reference.
1155 #
Argument 0 is the line number
on which line was used
1156 #
Argument 1 is the relative line number or line number
variable reference
1158 proc
get-absolute
-line
{ useline line
} {
1159 if { "$line" == "." } {
1163 if { [regsub
"^\.\[+-\](\[0-9\]+)$" $line "\\1" num] && $useline != "" } {
1164 # Handle relative line specification
, .
+1 or .
-1 etc.
1165 set num
[expr $useline
[string index $line
1] $num
]
1169 if { ! [regsub
"^(\[a-zA-Z\]\[a-zA-Z0-9_\]*)$" $line "\\1" varname] } {
1173 # Handle linenr
variable defined by dg
-line
1174 set org_varname $varname
1175 set varname
"saved_linenr_$varname"
1176 eval global $varname
1178 # Generate used
-but
-not
-defined error.
1179 eval
set var_defined
[info exists $varname
]
1180 if { ! $var_defined
} {
1181 if { "$useline" != "" } {
1182 error
"dg-line var $org_varname used at line $useline, but not defined"
1184 error
"dg-line var $org_varname used, but not defined"
1189 # Note that varname has been used.
1190 set varname_used
"used_$varname"
1191 eval global $varname_used
1192 eval
set $varname_used
1
1194 #
Get line number from var and use it.
1195 eval
set num \$$varname
1199 # Modify the regular expression saved by a DejaGnu message directive to
1200 #
include a prefix and to force the expression to match a single line.
1201 # MSGPROC is the procedure to
call.
1202 # MSGPREFIX is the prefix to prepend.
1203 # DGARGS is the original
argument list.
1205 proc process
-message
{ msgproc msgprefix dgargs
} {
1206 upvar dg
-messages dg
-messages
1208 if { [llength $dgargs
] == 5 } {
1209 set useline
[lindex $dgargs
0]
1211 # Resolve absolute line number.
1212 set line
[get-absolute
-line $useline
[lindex $dgargs
4]]
1213 set dgargs
[lreplace $dgargs
4 4 $line
]
1215 if { $line
!= $useline
} {
1216 # Make sure that we
get unique test names
if different USELINEs
1217 # refer to the same LINE.
1218 set comment
"[lindex $dgargs 2] at line $useline"
1219 set dgargs
[lreplace $dgargs
2 2 $comment
]
1223 # Process the dg
- directive
, including adding the regular expression
1224 # to the new message entry in dg
-messages.
1225 set msgcnt
[llength $
{dg
-messages
}]
1226 eval $msgproc $dgargs
1228 #
If the target expression wasn
't satisfied there is no new message.
1229 if { [llength ${dg-messages}] == $msgcnt } {
1233 # Get the entry for the new message. Prepend the message prefix to
1234 # the regular expression and make it match a single line.
1235 set newentry [lindex ${dg-messages} end]
1236 set expmsg [lindex $newentry 2]
1239 # Handle column numbers from the specified expression (if there is
1240 # one) and set up the search expression that will be used by DejaGnu.
1241 if [regexp {^-:} $expmsg] {
1242 # The expected column is -, so shouldn't appear.
1243 set expmsg
[string range $expmsg
2 end
]
1244 } elseif
[regexp
{^
[0-9]+:} $expmsg column
] {
1245 # The expression in the directive included a column number.
1246 # Remove it from the original expression and
move it
1247 # to the proper place in the search expression.
1248 set expmsg
[string range $expmsg
[string length $column
] end
]
1249 set column
"$column "
1250 } elseif
[string match
"" [lindex $newentry 0]] {
1251 # The specified line number is
0; don
't expect a column number.
1253 # There is no column number in the search expression, but we
1254 # should expect one in the message itself.
1255 set column {[0-9]+: }
1257 set expmsg "$column$msgprefix\[^\n\]*$expmsg"
1258 set newentry [lreplace $newentry 2 2 $expmsg]
1260 set dg-messages [lreplace ${dg-messages} end end $newentry]
1261 verbose "process-message:\n${dg-messages}" 3
1264 # Look for messages that don't have standard prefixes.
1266 proc dg
-message
{ args } {
1267 upvar dg
-messages dg
-messages
1268 process
-message saved
-dg
-warning
"" $args
1271 # Look
for a location marker of the form
1273 # with no extra
text (e.g. a line
-span separator
).
1275 proc dg
-locus
{ args } {
1276 upvar dg
-messages dg
-messages
1278 # Process the dg
- directive
, including adding the regular expression
1279 # to the new message entry in dg
-messages.
1280 set msgcnt
[llength $
{dg
-messages
}]
1281 eval saved
-dg
-warning $
args
1283 #
If the target expression wasn
't satisfied there is no new message.
1284 if { [llength ${dg-messages}] == $msgcnt } {
1288 # Get the entry for the new message. Prepend the message prefix to
1289 # the regular expression and make it match a single line.
1290 set newentry [lindex ${dg-messages} end]
1291 set expmsg [lindex $newentry 2]
1293 set newentry [lreplace $newentry 2 2 $expmsg]
1294 set dg-messages [lreplace ${dg-messages} end end $newentry]
1295 verbose "process-message:\n${dg-messages}" 3
1298 # Handle output from -fopt-info for MSG_OPTIMIZED_LOCATIONS:
1299 # a successful optimization.
1301 proc dg-optimized { args } {
1302 # Make this variable available here and to the saved proc.
1303 upvar dg-messages dg-messages
1305 process-message saved-dg-warning "optimized:" "$args"
1308 # Handle output from -fopt-info for MSG_MISSED_OPTIMIZATION:
1309 # a missed optimization.
1311 proc dg-missed { args } {
1312 # Make this variable available here and to the saved proc.
1313 upvar dg-messages dg-messages
1315 process-message saved-dg-warning "missed:" "$args"
1318 # Look for messages with 'note
: ' prefixes.
1319 # In addition to standard compiler diagnostics ('DK_NOTE
', 'inform
' functions,
1320 # "for additional details on an error message"),
1321 # this also includes output from '-fopt
-info' for 'MSG_NOTE
':
1322 # a general optimization info.
1323 # By default, any *excess* notes are pruned, meaning their appearance doesn't
1324 # trigger
*excess errors
*. However
, if 'dg-note' is used at least once in a
1325 # testcase
, they
're not pruned and instead must *all* be handled explicitly.
1326 # Thus, if looking for just single instances of messages with 'note
: ' prefixes
1327 # without caring for all of them, use 'dg
-message
"note: [...]"' instead of
1328 #
'dg-note', or use
'dg-note' together with
'dg-prune-output "note: "'.
1330 variable prune_notes
1332 proc initialize_prune_notes
{ } {
1337 initialize_prune_notes
1339 proc dg
-note
{ args } {
1340 upvar dg
-messages dg
-messages
1345 process
-message saved
-dg
-warning
"note:" "$args"
1348 # Check the existence of a gdb in the path
, and
return true
if there
1351 #
Set env
(GDB_FOR_GCC_TESTING
) accordingly.
1353 proc gdb
-exists { args } {
1354 if ![info exists ::env
(GDB_FOR_GCC_TESTING
)] {
1356 if ![info exists ::env
(GDB_FOR_GCC_TESTING
)] {
1357 if [info exists GDB
] {
1358 setenv GDB_FOR_GCC_TESTING
"$GDB"
1360 setenv GDB_FOR_GCC_TESTING
"[transform gdb]"
1364 if { [which $
::env
(GDB_FOR_GCC_TESTING
)] != 0 } {
1370 # Helper function
for scan
-symbol and scan
-symbol
-not. It scans a symbol in
1371 # the final executable and
return 1 if present
, otherwise fail.
1373 #
Argument 0 is the regexp to match.
1374 #
Argument 1 handles expected failures and the like
1375 proc scan
-symbol
-common
{ scan_directive
args } {
1379 # Access
variable from gcc
-dg
-test
-1 or lto
-execute.
1380 upvar
3 output_file output_file
1382 if { [llength $
args] >= 2 } {
1383 switch [dg
-process
-target
[lindex $
args 1]] {
1386 "F" { setup_xfail "*-*-*" }
1391 # Find nm like we find g
++ in g
++.exp.
1392 if ![info exists nm
] {
1393 set nm
[findfile $base_dir
/..
/..
/..
/binutils
/nm \
1394 $base_dir
/..
/..
/..
/binutils
/nm \
1395 [findfile $base_dir
/..
/..
/nm $base_dir
/..
/..
/nm \
1396 [findfile $base_dir
/nm $base_dir
/nm \
1398 verbose
-log "nm is $nm"
1401 set output_file
"[glob -nocomplain $output_file]"
1402 if { $output_file
== "" } {
1403 fail
"$scan_directive $args: output file does not exist"
1407 set fd
[open
"| $nm $output_file" r]
1411 if [regexp
-- [lindex $
args 0] $
text] {
1418 # Utility
for scanning a symbol in the final executable
, invoked via dg
-final.
1419 #
Call pass
if pattern is present
, otherwise fail.
1421 #
Argument 0 is the regexp to match.
1422 #
Argument 1 handles expected failures and the like
1423 proc scan
-symbol
{ args } {
1424 set testcase
[testname
-for-summary
]
1425 if { [scan
-symbol
-common
"scan-symbol" $args]} {
1426 pass
"$testcase scan-symbol $args"
1428 fail
"$testcase scan-symbol $args"
1432 # Utility
for scanning a symbol in the final executable
, invoked via dg
-final.
1433 #
Call pass
if pattern is absent
, otherwise fail.
1435 #
Argument 0 is the regexp to match.
1436 #
Argument 1 handles expected failures and the like
1437 proc scan
-symbol
-not
{ args } {
1438 set testcase
[testname
-for-summary
]
1439 if { [scan
-symbol
-common
"scan-symbol-not" $args]} {
1440 fail
"$testcase scan-symbol-not $args"
1442 pass
"$testcase scan-symbol-not $args"
1446 # Transform a tool
-name to its canonical
-target
-name by
"transform"
1447 #
(which may
return the original
name for native targets
) but only
if
1448 # testing out
-of
-tree. When in
-tree
, the tool is expected to be found
1449 # by its original
name, typically with some build
-directory prefix
1450 # prepended by the caller.
1451 proc gcc
-transform
-out
-of
-tree
{ args } {
1452 global TESTING_IN_BUILD_TREE
1453 if { [info exists TESTING_IN_BUILD_TREE
] } {
1456 return [transform $
args]
1459 set additional_prunes
""
1460 set dg_runtest_extra_prunes
""