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 #
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\]*.,}"
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 # Modified dg-runtest that can cycle through a list of optimization options
579 proc gcc-dg-runtest { testcases flags default-extra-flags } {
582 # Some callers initialize torture testing themselves; don't override those.
583 set existing_torture_init
[torture
-init
-done
]
584 if { $existing_torture_init
== 0 } {
587 # Some callers
set torture options themselves
; don
't override those.
588 set existing_torture_options [torture-options-exist]
589 if { $existing_torture_options == 0 } {
590 global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS
591 set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS
595 foreach test $testcases {
596 global torture_with_loops torture_without_loops
597 # If we're only testing specific files and this isn
't one of
599 if ![runtest_file_p $runtests $test] {
603 # Look for a loop within the source code - if we don't find one
,
604 # don
't pass -funroll[-all]-loops.
605 if [expr [search_for $test "for*("]+[search_for $test "while*("]] {
606 set option_list $torture_with_loops
608 set option_list $torture_without_loops
611 set nshort [file tail [file dirname $test]]/[file tail $test]
613 foreach flags_t $option_list {
614 global torture_current_flags
615 set torture_current_flags "$flags_t"
616 verbose "Testing $nshort, $flags $flags_t" 1
617 dg-test $test "$flags $flags_t" ${default-extra-flags}
621 if { $existing_torture_init == 0 } {
626 # Check if frontend has CTF support
627 proc gcc-dg-frontend-supports-ctf { target_compile trivial } {
630 set comp_output [$target_compile \
631 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
632 "additional_flags=-gctf"]
633 if { ! [string match \
634 "*CTF debug info requested, but not supported for * frontend*" \
636 remove-build-file "trivial.S"
642 # Check if the target system supports the debug format
643 proc gcc-dg-target-supports-debug-format { target_compile trivial type } {
646 set comp_output [$target_compile \
647 "$srcdir/$subdir/$trivial" "trivial.S" assembly \
648 "additional_flags=$type"]
649 if { ! [string match "*: target system does not support the * debug format*" \
651 remove-build-file "trivial.S"
657 proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } {
658 if ![info exists DEBUG_TORTURE_OPTIONS] {
659 set DEBUG_TORTURE_OPTIONS ""
660 foreach type {-gctf -gdwarf-2} {
661 if [expr [gcc-dg-target-supports-debug-format \
662 $target_compile $trivial $type]] {
663 if { $type == "-gctf" } {
664 if [expr [gcc-dg-frontend-supports-ctf \
665 $target_compile $trivial]] {
666 # At this time, running tests with various opt levels or
667 # ctf debug info levels does not add value.
668 lappend DEBUG_TORTURE_OPTIONS [list "${type}"]
672 foreach level {1 "" 3} {
673 if { ($type == "-gdwarf-2") && ($level != "") } {
674 lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"]
675 foreach opt $opt_opts {
676 lappend DEBUG_TORTURE_OPTIONS \
677 [list "${type}" "-g${level}" "$opt" ]
680 lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"]
681 foreach opt $opt_opts {
682 lappend DEBUG_TORTURE_OPTIONS \
683 [list "${type}${level}" "$opt" ]
691 verbose -log "Using options $DEBUG_TORTURE_OPTIONS"
695 foreach test $testcases {
696 # If we're only testing specific files and this isn
't one of
698 if ![runtest_file_p $runtests $test] {
702 set nshort [file tail [file dirname $test]]/[file tail $test]
704 foreach flags $DEBUG_TORTURE_OPTIONS {
707 # These tests check for information which may be deliberately
709 if { ([string match {*/debug-[126].c} "$nshort"] \
710 || [string match {*/enum-1.c} "$nshort"] \
711 || [string match {*/enum-[12].C} "$nshort"]) \
712 && ([string match "*1" [lindex "$flags" 0] ]
713 || [lindex "$flags" 1] == "-g1") } {
717 # High optimization can remove the variable whose existence is tested.
718 # Dwarf debugging with commentary (-dA) preserves the symbol name in the
719 # assembler output, but stabs debugging does not.
720 # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html
721 if { [string match {*/debug-[12].c} "$nshort"] \
722 && [string match "*O*" "$flags"] \
723 && ( [string match "*coff*" "$flags"] \
724 || [string match "*stabs*" "$flags"] ) } {
728 # These tests check for information which is not emitted for CTF
729 # as CTF type information is emitted for entities at file and
731 if { ([string match {*/debug-[126].c} "$nshort"] \
732 || [string match {*/enum-[12].C} "$nshort"] ) \
733 && [string match "*ctf*" "$flags"] } {
738 verbose -log "Testing $nshort, $flags" 1
739 dg-test $test $flags ""
745 # Prune any messages matching ARGS[1] (a regexp) from test output.
746 proc dg-prune-output { args } {
747 global additional_prunes
749 if { [llength $args] != 2 } {
750 error "[lindex $args 1]: need one argument"
754 lappend additional_prunes [lindex $args 1]
757 # Remove files matching the pattern from the build machine.
758 proc remove-build-file { pat } {
759 verbose "remove-build-file `$pat'" 2
760 set file_list
"[glob -nocomplain $pat]"
761 verbose
"remove-build-file `$file_list'" 2
762 foreach output_file $file_list
{
763 if [is_remote host
] {
764 # Ensure the host knows the file is gone by deleting there
766 remote_file host
delete $output_file
768 remote_file build
delete $output_file
772 # Remove runtime
-generated profile file
for the current test.
773 proc cleanup
-profile
-file
{ } {
774 remove
-build
-file
"mon.out"
775 remove
-build
-file
"gmon.out"
778 # Remove compiler
-generated coverage files
for the current test.
779 proc cleanup
-coverage
-files
{ } {
780 global additional_sources_used
781 set testcase
[testname
-for-summary
]
782 # The
name might
include a list of options
; extract the file
name.
783 set testcase
[lindex $testcase
0]
784 remove
-build
-file
"[file rootname [file tail $testcase]].gc??"
786 # Clean up coverage files
for additional source files.
787 if [info exists additional_sources_used
] {
788 foreach srcfile $additional_sources_used
{
789 remove
-build
-file
"[file rootname [file tail $srcfile]].gc??"
794 # Remove a final insns dump file
for the current test.
795 proc cleanup
-final
-insns
-dump
{ } {
796 set testcase
[testname
-for-summary
]
797 # The
name might
include a list of options
; extract the file
name.
798 set testcase
[lindex $testcase
0]
799 remove
-build
-file
"[file rootname [file tail $testcase]].s.gkd"
801 # Clean up files
for additional source files.
802 if [info exists additional_sources_used
] {
803 foreach srcfile $additional_sources_used
{
804 remove
-build
-file
"[file rootname [file tail $srcfile]].s.gkd"
809 # Remove a stack usage file
for the current test.
810 proc cleanup
-stack
-usage
{ } {
811 set testcase
[testname
-for-summary
]
812 # The
name might
include a list of options
; extract the file
name.
813 set testcase
[lindex $testcase
0]
814 remove
-build
-file
"[file rootname [file tail $testcase]].su"
816 # Clean up files
for additional source files.
817 if [info exists additional_sources_used
] {
818 foreach srcfile $additional_sources_used
{
819 remove
-build
-file
"[file rootname [file tail $srcfile]].su"
824 # Remove an Ada spec file
for the current test.
825 proc cleanup
-ada
-spec
{ } {
826 global additional_sources_used
827 set testcase
[testname
-for-summary
]
828 remove
-build
-file
"[get_ada_spec_filename $testcase]"
830 # Clean up files
for additional source files.
831 if [info exists additional_sources_used
] {
832 foreach srcfile $additional_sources_used
{
833 remove
-build
-file
"[get_ada_spec_filename $srcfile]"
838 # Remove files kept by
--save
-temps
for the current test.
840 # Currently this is only .i
, .ii
, .s and .o files
, but more can be added
841 #
if there are tests generating them.
842 #
ARGS is a list of suffixes to NOT
delete.
843 proc cleanup
-saved
-temps
{ args } {
844 global additional_sources_used
847 # add the to
-be
-kept suffixes
848 foreach suffix
{".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
849 if {[lsearch $
args $suffix
] < 0} {
850 lappend suffixes $suffix
854 set testcase
[testname
-for-summary
]
855 # The
name might
include a list of options
; extract the file
name.
856 set testcase
[lindex $testcase
0]
857 foreach suffix $suffixes
{
858 remove
-build
-file
"[file rootname [file tail $testcase]]$suffix"
859 remove
-build
-file
"[file rootname [file tail $testcase]].exe$suffix"
860 remove
-build
-file
"[file rootname [file tail $testcase]].exe.ltrans\[0-9\]*$suffix"
861 #
-fcompare
-debug dumps
862 remove
-build
-file
"[file rootname [file tail $testcase]].gk$suffix"
865 # Clean up saved temp files
for additional source files.
866 if [info exists additional_sources_used
] {
867 foreach srcfile $additional_sources_used
{
868 foreach suffix $suffixes
{
869 remove
-build
-file
"[file rootname [file tail $srcfile]]$suffix"
870 remove
-build
-file
"[file rootname [file tail $srcfile]].exe$suffix"
871 remove
-build
-file
"[file rootname [file tail $srcfile]].exe.ltrans\[0-9\]*$suffix"
873 #
-fcompare
-debug dumps
874 remove
-build
-file
"[file rootname [file tail $srcfile]].gk$suffix"
881 # Files to be kept after cleanup of
--save
-temps
for the current test.
882 #
ARGS is a list of suffixes to NOT
delete.
883 proc dg
-keep
-saved
-temps
{ args } {
884 global keep_saved_temps_suffixes
885 set keep_saved_temps_suffixes
{}
887 # add the to
-be
-kept suffixes
888 foreach suffix
{".mii" ".ii" ".i" ".s" ".o" ".gkd" ".res" ".ltrans.out"} {
889 if {[lsearch $
args $suffix
] >= 0} {
890 lappend keep_saved_temps_suffixes $suffix
893 if { [llength keep_saved_temps_suffixes
] < 1 } {
894 error
"dg-keep-saved-temps ${args} did not match any known suffix"
898 # Scan Fortran modules
for a given regexp.
900 #
Argument 0 is the module
name
901 #
Argument 1 is the regexp to match
902 proc scan
-module
{ args } {
903 set modfilename
[string tolower
[lindex $
args 0]].mod
904 set fd
[open
[list | gzip
-dc $modfilename
] r
]
908 set testcase
[testname
-for-summary
]
909 if [regexp
-- [lindex $
args 1] $
text] {
910 pass
"$testcase scan-module [lindex $args 1]"
912 fail
"$testcase scan-module [lindex $args 1]"
916 # Scan Fortran modules
for absence of a given regexp.
918 #
Argument 0 is the module
name
919 #
Argument 1 is the regexp to match
920 proc scan
-module
-absence
{ args } {
921 set modfilename
[string tolower
[lindex $
args 0]].mod
922 set fd
[open
[list | gzip
-dc $modfilename
] r
]
926 set testcase
[testname
-for-summary
]
927 if [regexp
-- [lindex $
args 1] $
text] {
928 fail
"$testcase scan-module [lindex $args 1]"
930 pass
"$testcase scan-module [lindex $args 1]"
934 # Verify that the compiler output file
exists, invoked via dg
-final.
935 proc output
-exists { args } {
936 # Process an optional target or xfail list.
937 if { [llength $
args] >= 1 } {
938 switch [dg
-process
-target
[lindex $
args 0]] {
941 "F" { setup_xfail "*-*-*" }
946 set testcase
[testname
-for-summary
]
947 # Access
variable from gcc
-dg
-test
-1.
948 upvar
2 output_file output_file
950 if [file
exists $output_file
] {
951 pass
"$testcase output-exists $output_file"
953 fail
"$testcase output-exists $output_file"
957 # Verify that the compiler output file does not exist
, invoked via dg
-final.
958 proc output
-exists-not
{ args } {
959 # Process an optional target or xfail list.
960 if { [llength $
args] >= 1 } {
961 switch [dg
-process
-target
[lindex $
args 0]] {
964 "F" { setup_xfail "*-*-*" }
969 set testcase
[testname
-for-summary
]
970 # Access
variable from gcc
-dg
-test
-1.
971 upvar
2 output_file output_file
973 if [file
exists $output_file
] {
974 fail
"$testcase output-exists-not $output_file"
976 pass
"$testcase output-exists-not $output_file"
980 # We need to make sure that additional_
* are cleared out after
every
981 # test. It is not enough to clear them out
*before
* the next test run
982 # because gcc
-target
-compile gets run directly from some .exp files
983 #
(outside of
any test
).
(Those uses should eventually be eliminated.
)
985 # Because the DG framework doesn
't provide a hook that is run at the
986 # end of a test, we must replace dg-test with a wrapper.
988 if { [info procs saved-dg-test] == [list] } {
989 rename dg-test saved-dg-test
991 # Helper function for cleanups that should happen after the call
992 # to the real dg-test, whether or not it returns normally, or
993 # fails with an error.
994 proc cleanup-after-saved-dg-test { } {
995 global additional_files
996 global additional_sources
997 global additional_sources_used
998 global additional_prunes
999 global compiler_conditional_xfail_data
1002 global testname_with_flags
1003 global set_target_env_var
1004 global set_compiler_env_var
1005 global saved_compiler_env_var
1006 global keep_saved_temps_suffixes
1007 global nn_line_numbers_enabled
1008 global multiline_expected_outputs
1009 global freeform_regexps
1010 global save_linenr_varnames
1012 set additional_files ""
1013 set additional_sources ""
1014 set additional_sources_used ""
1015 set additional_prunes ""
1018 if [info exists set_target_env_var] {
1019 unset set_target_env_var
1021 if [info exists set_compiler_env_var] {
1022 restore-compiler-env-var
1023 unset set_compiler_env_var
1024 unset saved_compiler_env_var
1026 if [info exists keep_saved_temps_suffixes] {
1027 unset keep_saved_temps_suffixes
1030 if [info exists compiler_conditional_xfail_data] {
1031 unset compiler_conditional_xfail_data
1033 if [info exists testname_with_flags] {
1034 unset testname_with_flags
1036 set nn_line_numbers_enabled 0
1037 set multiline_expected_outputs []
1038 set freeform_regexps []
1040 if { [info exists save_linenr_varnames] } {
1041 foreach varname $save_linenr_varnames {
1043 eval global $varname
1046 # Cleanup varname_used, or generate defined-but-not-used
1048 set varname_used used_$varname
1049 eval global $varname_used
1050 eval set used [info exists $varname_used]
1052 eval unset $varname_used
1054 regsub {^saved_linenr_} $varname "" org_varname
1055 warning "dg-line var $org_varname defined, but not used"
1058 unset save_linenr_varnames
1061 initialize_prune_notes
1064 proc dg-test { args } {
1067 if { [ catch { eval saved-dg-test $args } errmsg ] } {
1068 set saved_info $errorInfo
1069 cleanup-after-saved-dg-test
1070 error $errmsg $saved_info
1072 cleanup-after-saved-dg-test
1076 if { [info procs saved-dg-warning] == [list] \
1077 && [info exists gcc_warning_prefix] } {
1078 rename dg-warning saved-dg-warning
1080 proc dg-warning { args } {
1081 # Make this variable available here and to the saved proc.
1082 upvar dg-messages dg-messages
1083 global gcc_warning_prefix
1085 process-message saved-dg-warning "$gcc_warning_prefix" "$args"
1089 if { [info procs saved-dg-error] == [list] \
1090 && [info exists gcc_error_prefix] } {
1091 rename dg-error saved-dg-error
1093 proc dg-error { args } {
1094 # Make this variable available here and to the saved proc.
1095 upvar dg-messages dg-messages
1096 global gcc_error_prefix
1098 process-message saved-dg-error "$gcc_error_prefix" "$args"
1101 # Override dg-bogus at the same time. It doesn't handle a prefix
1102 # but its expression should
include a column number. Otherwise the
1103 # line number can match the column number
for other messages
, leading
1105 rename dg
-bogus saved
-dg
-bogus
1107 proc dg
-bogus
{ args } {
1108 upvar dg
-messages dg
-messages
1109 process
-message saved
-dg
-bogus
"" $args
1113 #
Set variable VARNAME to LINENR
1115 proc dg
-line
{ linenr varname
} {
1116 set org_varname $varname
1117 set varname
"saved_linenr_$varname"
1118 eval global $varname
1120 # Generate defined
-but
-previously
-defined error.
1121 eval
set var_defined
[info exists $varname
]
1122 if { $var_defined
} {
1123 eval
set deflinenr \$$varname
1124 error
"dg-line var $org_varname defined at line $linenr, but previously defined at line $deflinenr"
1128 eval
set $varname $linenr
1130 # Schedule cleanup of varname by cleanup
-after
-saved
-dg
-test
1131 global save_linenr_varnames
1132 if { [info exists save_linenr_varnames
] } {
1133 lappend save_linenr_varnames $varname
1135 set save_linenr_varnames
[list $varname
]
1139 #
Get the absolute line number corresponding to
:
1140 #
- a relative line number
(a non
-null useline is required
), or
1141 #
- a line number
variable reference.
1142 #
Argument 0 is the line number
on which line was used
1143 #
Argument 1 is the relative line number or line number
variable reference
1145 proc
get-absolute
-line
{ useline line
} {
1146 if { "$line" == "." } {
1150 if { [regsub
"^\.\[+-\](\[0-9\]+)$" $line "\\1" num] && $useline != "" } {
1151 # Handle relative line specification
, .
+1 or .
-1 etc.
1152 set num
[expr $useline
[string index $line
1] $num
]
1156 if { ! [regsub
"^(\[a-zA-Z\]\[a-zA-Z0-9_\]*)$" $line "\\1" varname] } {
1160 # Handle linenr
variable defined by dg
-line
1161 set org_varname $varname
1162 set varname
"saved_linenr_$varname"
1163 eval global $varname
1165 # Generate used
-but
-not
-defined error.
1166 eval
set var_defined
[info exists $varname
]
1167 if { ! $var_defined
} {
1168 if { "$useline" != "" } {
1169 error
"dg-line var $org_varname used at line $useline, but not defined"
1171 error
"dg-line var $org_varname used, but not defined"
1176 # Note that varname has been used.
1177 set varname_used
"used_$varname"
1178 eval global $varname_used
1179 eval
set $varname_used
1
1181 #
Get line number from var and use it.
1182 eval
set num \$$varname
1186 # Modify the regular expression saved by a DejaGnu message directive to
1187 #
include a prefix and to force the expression to match a single line.
1188 # MSGPROC is the procedure to
call.
1189 # MSGPREFIX is the prefix to prepend.
1190 # DGARGS is the original
argument list.
1192 proc process
-message
{ msgproc msgprefix dgargs
} {
1193 upvar dg
-messages dg
-messages
1195 if { [llength $dgargs
] == 5 } {
1196 set useline
[lindex $dgargs
0]
1198 # Resolve absolute line number.
1199 set line
[get-absolute
-line $useline
[lindex $dgargs
4]]
1200 set dgargs
[lreplace $dgargs
4 4 $line
]
1202 if { $line
!= $useline
} {
1203 # Make sure that we
get unique test names
if different USELINEs
1204 # refer to the same LINE.
1205 set comment
"[lindex $dgargs 2] at line $useline"
1206 set dgargs
[lreplace $dgargs
2 2 $comment
]
1210 # Process the dg
- directive
, including adding the regular expression
1211 # to the new message entry in dg
-messages.
1212 set msgcnt
[llength $
{dg
-messages
}]
1213 eval $msgproc $dgargs
1215 #
If the target expression wasn
't satisfied there is no new message.
1216 if { [llength ${dg-messages}] == $msgcnt } {
1220 # Get the entry for the new message. Prepend the message prefix to
1221 # the regular expression and make it match a single line.
1222 set newentry [lindex ${dg-messages} end]
1223 set expmsg [lindex $newentry 2]
1226 # Handle column numbers from the specified expression (if there is
1227 # one) and set up the search expression that will be used by DejaGnu.
1228 if [regexp {^-:} $expmsg] {
1229 # The expected column is -, so shouldn't appear.
1230 set expmsg
[string range $expmsg
2 end
]
1231 } elseif
[regexp
{^
[0-9]+:} $expmsg column
] {
1232 # The expression in the directive included a column number.
1233 # Remove it from the original expression and
move it
1234 # to the proper place in the search expression.
1235 set expmsg
[string range $expmsg
[string length $column
] end
]
1236 set column
"$column "
1237 } elseif
[string match
"" [lindex $newentry 0]] {
1238 # The specified line number is
0; don
't expect a column number.
1240 # There is no column number in the search expression, but we
1241 # should expect one in the message itself.
1242 set column {[0-9]+: }
1244 set expmsg "$column$msgprefix\[^\n\]*$expmsg"
1245 set newentry [lreplace $newentry 2 2 $expmsg]
1247 set dg-messages [lreplace ${dg-messages} end end $newentry]
1248 verbose "process-message:\n${dg-messages}" 3
1251 # Look for messages that don't have standard prefixes.
1253 proc dg
-message
{ args } {
1254 upvar dg
-messages dg
-messages
1255 process
-message saved
-dg
-warning
"" $args
1258 # Look
for a location marker of the form
1260 # with no extra
text (e.g. a line
-span separator
).
1262 proc dg
-locus
{ args } {
1263 upvar dg
-messages dg
-messages
1265 # Process the dg
- directive
, including adding the regular expression
1266 # to the new message entry in dg
-messages.
1267 set msgcnt
[llength $
{dg
-messages
}]
1268 eval saved
-dg
-warning $
args
1270 #
If the target expression wasn
't satisfied there is no new message.
1271 if { [llength ${dg-messages}] == $msgcnt } {
1275 # Get the entry for the new message. Prepend the message prefix to
1276 # the regular expression and make it match a single line.
1277 set newentry [lindex ${dg-messages} end]
1278 set expmsg [lindex $newentry 2]
1280 set newentry [lreplace $newentry 2 2 $expmsg]
1281 set dg-messages [lreplace ${dg-messages} end end $newentry]
1282 verbose "process-message:\n${dg-messages}" 3
1285 # Handle output from -fopt-info for MSG_OPTIMIZED_LOCATIONS:
1286 # a successful optimization.
1288 proc dg-optimized { args } {
1289 # Make this variable available here and to the saved proc.
1290 upvar dg-messages dg-messages
1292 process-message saved-dg-warning "optimized:" "$args"
1295 # Handle output from -fopt-info for MSG_MISSED_OPTIMIZATION:
1296 # a missed optimization.
1298 proc dg-missed { args } {
1299 # Make this variable available here and to the saved proc.
1300 upvar dg-messages dg-messages
1302 process-message saved-dg-warning "missed:" "$args"
1305 # Look for messages with 'note
: ' prefixes.
1306 # In addition to standard compiler diagnostics ('DK_NOTE
', 'inform
' functions,
1307 # "for additional details on an error message"),
1308 # this also includes output from '-fopt
-info' for 'MSG_NOTE
':
1309 # a general optimization info.
1310 # By default, any *excess* notes are pruned, meaning their appearance doesn't
1311 # trigger
*excess errors
*. However
, if 'dg-note' is used at least once in a
1312 # testcase
, they
're not pruned and instead must *all* be handled explicitly.
1313 # Thus, if looking for just single instances of messages with 'note
: ' prefixes
1314 # without caring for all of them, use 'dg
-message
"note: [...]"' instead of
1315 #
'dg-note', or use
'dg-note' together with
'dg-prune-output "note: "'.
1317 variable prune_notes
1319 proc initialize_prune_notes
{ } {
1324 initialize_prune_notes
1326 proc dg
-note
{ args } {
1327 upvar dg
-messages dg
-messages
1332 process
-message saved
-dg
-warning
"note:" "$args"
1335 # Check the existence of a gdb in the path
, and
return true
if there
1338 #
Set env
(GDB_FOR_GCC_TESTING
) accordingly.
1340 proc gdb
-exists { args } {
1341 if ![info exists ::env
(GDB_FOR_GCC_TESTING
)] {
1343 if ![info exists ::env
(GDB_FOR_GCC_TESTING
)] {
1344 if [info exists GDB
] {
1345 setenv GDB_FOR_GCC_TESTING
"$GDB"
1347 setenv GDB_FOR_GCC_TESTING
"[transform gdb]"
1351 if { [which $
::env
(GDB_FOR_GCC_TESTING
)] != 0 } {
1357 # Helper function
for scan
-symbol and scan
-symbol
-not. It scans a symbol in
1358 # the final executable and
return 1 if present
, otherwise fail.
1360 #
Argument 0 is the regexp to match.
1361 #
Argument 1 handles expected failures and the like
1362 proc scan
-symbol
-common
{ scan_directive
args } {
1366 # Access
variable from gcc
-dg
-test
-1 or lto
-execute.
1367 upvar
3 output_file output_file
1369 if { [llength $
args] >= 2 } {
1370 switch [dg
-process
-target
[lindex $
args 1]] {
1373 "F" { setup_xfail "*-*-*" }
1378 # Find nm like we find g
++ in g
++.exp.
1379 if ![info exists nm
] {
1380 set nm
[findfile $base_dir
/..
/..
/..
/binutils
/nm \
1381 $base_dir
/..
/..
/..
/binutils
/nm \
1382 [findfile $base_dir
/..
/..
/nm $base_dir
/..
/..
/nm \
1383 [findfile $base_dir
/nm $base_dir
/nm \
1385 verbose
-log "nm is $nm"
1388 set output_file
"[glob -nocomplain $output_file]"
1389 if { $output_file
== "" } {
1390 fail
"$scan_directive $args: output file does not exist"
1394 set fd
[open
"| $nm $output_file" r]
1398 if [regexp
-- [lindex $
args 0] $
text] {
1405 # Utility
for scanning a symbol in the final executable
, invoked via dg
-final.
1406 #
Call pass
if pattern is present
, otherwise fail.
1408 #
Argument 0 is the regexp to match.
1409 #
Argument 1 handles expected failures and the like
1410 proc scan
-symbol
{ args } {
1411 set testcase
[testname
-for-summary
]
1412 if { [scan
-symbol
-common
"scan-symbol" $args]} {
1413 pass
"$testcase scan-symbol $args"
1415 fail
"$testcase scan-symbol $args"
1419 # Utility
for scanning a symbol in the final executable
, invoked via dg
-final.
1420 #
Call pass
if pattern is absent
, otherwise fail.
1422 #
Argument 0 is the regexp to match.
1423 #
Argument 1 handles expected failures and the like
1424 proc scan
-symbol
-not
{ args } {
1425 set testcase
[testname
-for-summary
]
1426 if { [scan
-symbol
-common
"scan-symbol-not" $args]} {
1427 fail
"$testcase scan-symbol-not $args"
1429 pass
"$testcase scan-symbol-not $args"
1433 # Transform a tool
-name to its canonical
-target
-name by
"transform"
1434 #
(which may
return the original
name for native targets
) but only
if
1435 # testing out
-of
-tree. When in
-tree
, the tool is expected to be found
1436 # by its original
name, typically with some build
-directory prefix
1437 # prepended by the caller.
1438 proc gcc
-transform
-out
-of
-tree
{ args } {
1439 global TESTING_IN_BUILD_TREE
1440 if { [info exists TESTING_IN_BUILD_TREE
] } {
1443 return [transform $
args]
1446 set additional_prunes
""
1447 set dg_runtest_extra_prunes
""