]>
Commit | Line | Data |
---|---|---|
23e27867 | 1 | # Copyright (C) 1997, 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009 |
6354626c | 2 | # Free Software Foundation, Inc. |
912f9e81 | 3 | |
4 | # This program is free software; you can redistribute it and/or modify | |
5 | # it under the terms of the GNU General Public License as published by | |
f63ff66b | 6 | # the Free Software Foundation; either version 3 of the License, or |
912f9e81 | 7 | # (at your option) any later version. |
ccb84981 | 8 | # |
912f9e81 | 9 | # This program is distributed in the hope that it will be useful, |
10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | # GNU General Public License for more details. | |
ccb84981 | 13 | # |
912f9e81 | 14 | # You should have received a copy of the GNU General Public License |
f63ff66b | 15 | # along with GCC; see the file COPYING3. If not see |
16 | # <http://www.gnu.org/licenses/>. | |
912f9e81 | 17 | |
912f9e81 | 18 | load_lib dg.exp |
0f1adac2 | 19 | load_lib file-format.exp |
fbc8985b | 20 | load_lib target-supports.exp |
aaded64c | 21 | load_lib target-supports-dg.exp |
f82ef354 | 22 | load_lib scanasm.exp |
6354626c | 23 | load_lib scanrtl.exp |
4ee9c684 | 24 | load_lib scantree.exp |
ab4b7a8a | 25 | load_lib scanipa.exp |
0557b60a | 26 | load_lib timeout.exp |
27 | load_lib timeout-dg.exp | |
1b28399f | 28 | load_lib prune.exp |
558b3c96 | 29 | load_lib libgloss.exp |
c0e31427 | 30 | load_lib target-libpath.exp |
07e23beb | 31 | load_lib torture-options.exp |
912f9e81 | 32 | |
e899394f | 33 | # We set LC_ALL and LANG to C so that we get the same error messages as expected. |
34 | setenv LC_ALL C | |
35 | setenv LANG C | |
36 | ||
07e23beb | 37 | if [info exists TORTURE_OPTIONS] { |
38 | set DG_TORTURE_OPTIONS $TORTURE_OPTIONS | |
39 | } else { | |
e2d12d23 | 40 | # It is theoretically beneficial to group all of the O2/O3 options together, |
41 | # as in many cases the compiler will generate identical executables for | |
42 | # all of them--and the c-torture testsuite will skip testing identical | |
43 | # executables multiple times. | |
44 | # Also note that -finline-functions is explicitly included in one of the | |
45 | # items below, even though -O3 is also specified, because some ports may | |
46 | # choose to disable inlining functions by default, even when optimizing. | |
07e23beb | 47 | set DG_TORTURE_OPTIONS [list \ |
e2d12d23 | 48 | { -O0 } \ |
49 | { -O1 } \ | |
50 | { -O2 } \ | |
51 | { -O3 -fomit-frame-pointer } \ | |
52 | { -O3 -fomit-frame-pointer -funroll-loops } \ | |
53 | { -O3 -fomit-frame-pointer -funroll-all-loops -finline-functions } \ | |
54 | { -O3 -g } \ | |
e2d12d23 | 55 | { -Os } ] |
56 | } | |
57 | ||
4425e8dc | 58 | if [info exists ADDITIONAL_TORTURE_OPTIONS] { |
59 | set DG_TORTURE_OPTIONS \ | |
60 | [concat $DG_TORTURE_OPTIONS $ADDITIONAL_TORTURE_OPTIONS] | |
61 | } | |
62 | ||
7bfefa9d | 63 | set LTO_TORTURE_OPTIONS "" |
64 | if [check_effective_target_lto] { | |
65 | set LTO_TORTURE_OPTIONS [list \ | |
66 | { -O2 -flto } \ | |
67 | { -O2 -fwhopr } | |
68 | ] | |
69 | } | |
70 | ||
71 | ||
558b3c96 | 72 | global GCC_UNDER_TEST |
73 | if ![info exists GCC_UNDER_TEST] { | |
74 | set GCC_UNDER_TEST "[find_gcc]" | |
75 | } | |
76 | ||
f09e0522 | 77 | global orig_environment_saved |
78 | ||
79 | # This file may be sourced, so don't override environment settings | |
80 | # that have been previously setup. | |
81 | if { $orig_environment_saved == 0 } { | |
82 | append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] | |
83 | set_ld_library_path_env_vars | |
84 | } | |
85 | ||
e2d12d23 | 86 | # Define gcc callbacks for dg.exp. |
87 | ||
8936721c | 88 | proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } { |
912f9e81 | 89 | # Set up the compiler flags, based on what we're going to do. |
90 | ||
8936721c | 91 | set options [list] |
92 | ||
93 | # Tests should be able to use "dg-do repo". However, the dg test | |
94 | # driver checks the argument to dg-do against a list of acceptable | |
95 | # options, and "repo" is not among them. Therefore, we resort to | |
96 | # this ugly approach. | |
97 | if [string match "*-frepo*" $extra_tool_flags] then { | |
98 | set do_what "repo" | |
99 | } | |
100 | ||
912f9e81 | 101 | switch $do_what { |
102 | "preprocess" { | |
103 | set compile_type "preprocess" | |
104 | set output_file "[file rootname [file tail $prog]].i" | |
105 | } | |
106 | "compile" { | |
cb9e826e | 107 | set compile_type "assembly" |
912f9e81 | 108 | set output_file "[file rootname [file tail $prog]].s" |
109 | } | |
110 | "assemble" { | |
cb9e826e | 111 | set compile_type "object" |
912f9e81 | 112 | set output_file "[file rootname [file tail $prog]].o" |
113 | } | |
573aba85 | 114 | "precompile" { |
115 | set compile_type "precompiled_header" | |
eebf4946 | 116 | set output_file "[file tail $prog].gch" |
573aba85 | 117 | } |
912f9e81 | 118 | "link" { |
119 | set compile_type "executable" | |
7df8b555 | 120 | set output_file "[file rootname [file tail $prog]].exe" |
912f9e81 | 121 | # The following line is needed for targets like the i960 where |
122 | # the default output file is b.out. Sigh. | |
123 | } | |
8936721c | 124 | "repo" { |
125 | set compile_type "object" | |
126 | set output_file "[file rootname [file tail $prog]].o" | |
127 | } | |
912f9e81 | 128 | "run" { |
129 | set compile_type "executable" | |
130 | # FIXME: "./" is to cope with "." not being in $PATH. | |
131 | # Should this be handled elsewhere? | |
132 | # YES. | |
7df8b555 | 133 | set output_file "./[file rootname [file tail $prog]].exe" |
912f9e81 | 134 | # This is the only place where we care if an executable was |
135 | # created or not. If it was, dg.exp will try to run it. | |
51f96208 | 136 | catch { remote_file build delete $output_file } |
912f9e81 | 137 | } |
138 | default { | |
139 | perror "$do_what: not a valid dg-do keyword" | |
140 | return "" | |
141 | } | |
142 | } | |
8936721c | 143 | |
912f9e81 | 144 | if { $extra_tool_flags != "" } { |
145 | lappend options "additional_flags=$extra_tool_flags" | |
146 | } | |
147 | ||
d4213587 | 148 | set comp_output [$target_compile "$prog" "$output_file" "$compile_type" $options] |
8936721c | 149 | |
19b92963 | 150 | # Look for an internal compiler error, which sometimes masks the fact |
06cecc47 | 151 | # that we didn't get an expected error message. XFAIL an ICE via |
152 | # dg-xfail-if and use { dg-prune-output ".*internal compiler error.*" } | |
153 | # to avoid a second failure for excess errors. | |
19b92963 | 154 | if [string match "*internal compiler error*" $comp_output] { |
155 | upvar 2 name name | |
156 | fail "$name (internal compiler error)" | |
157 | } | |
158 | ||
8936721c | 159 | if { $do_what == "repo" } { |
160 | set object_file "$output_file" | |
161 | set output_file "[file rootname [file tail $prog]].exe" | |
caa6fdce | 162 | set comp_output \ |
163 | [ concat $comp_output \ | |
164 | [$target_compile "$object_file" "$output_file" \ | |
165 | "executable" $options] ] | |
8936721c | 166 | } |
912f9e81 | 167 | |
168 | return [list $comp_output $output_file] | |
169 | } | |
170 | ||
8936721c | 171 | proc gcc-dg-test { prog do_what extra_tool_flags } { |
172 | return [gcc-dg-test-1 gcc_target_compile $prog $do_what $extra_tool_flags] | |
173 | } | |
174 | ||
912f9e81 | 175 | proc gcc-dg-prune { system text } { |
e3a37c0a | 176 | global additional_prunes |
177 | ||
912f9e81 | 178 | set text [prune_gcc_output $text] |
179 | ||
e3a37c0a | 180 | foreach p $additional_prunes { |
181 | if { [string length $p] > 0 } { | |
182 | # Following regexp matches a complete line containing $p. | |
183 | regsub -all "(^|\n)\[^\n\]*$p\[^\n\]*" $text "" text | |
184 | } | |
185 | } | |
186 | ||
912f9e81 | 187 | # If we see "region xxx is full" then the testcase is too big for ram. |
188 | # This is tricky to deal with in a large testsuite like c-torture so | |
189 | # deal with it here. Just mark the testcase as unsupported. | |
190 | if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] { | |
191 | # The format here is important. See dg.exp. | |
192 | return "::unsupported::memory full" | |
193 | } | |
194 | ||
8af9e72f | 195 | # Likewise, if we see ".text exceeds local store range" or |
196 | # similar. | |
197 | if {[string match "spu-*" $system] && \ | |
332c3552 | 198 | [string match "*exceeds local store*" $text]} { |
8af9e72f | 199 | # The format here is important. See dg.exp. |
200 | return "::unsupported::memory full" | |
201 | } | |
202 | ||
912f9e81 | 203 | return $text |
204 | } | |
e2d12d23 | 205 | |
c7a67206 | 206 | # Replace ${tool}_load with a wrapper to provide for an expected nonzero |
207 | # exit status. Multiple languages include this file so this handles them | |
208 | # all, not just gcc. | |
209 | if { [info procs ${tool}_load] != [list] \ | |
210 | && [info procs saved_${tool}_load] == [list] } { | |
211 | rename ${tool}_load saved_${tool}_load | |
212 | ||
213 | proc ${tool}_load { program args } { | |
214 | global tool | |
215 | global shouldfail | |
33bc0853 | 216 | set result [eval [list saved_${tool}_load $program] $args] |
c7a67206 | 217 | if { $shouldfail != 0 } { |
218 | switch [lindex $result 0] { | |
219 | "pass" { set status "fail" } | |
220 | "fail" { set status "pass" } | |
221 | } | |
222 | set result [list $status [lindex $result 1]] | |
223 | } | |
224 | return $result | |
225 | } | |
226 | } | |
227 | ||
e2d12d23 | 228 | # Utility routines. |
229 | ||
230 | # | |
231 | # search_for -- looks for a string match in a file | |
232 | # | |
233 | proc search_for { file pattern } { | |
234 | set fd [open $file r] | |
235 | while { [gets $fd cur_line]>=0 } { | |
236 | if [string match "*$pattern*" $cur_line] then { | |
237 | close $fd | |
238 | return 1 | |
239 | } | |
240 | } | |
241 | close $fd | |
242 | return 0 | |
243 | } | |
244 | ||
245 | # Modified dg-runtest that can cycle through a list of optimization options | |
246 | # as c-torture does. | |
247 | proc gcc-dg-runtest { testcases default-extra-flags } { | |
248 | global runtests | |
249 | ||
07e23beb | 250 | # Some callers set torture options themselves; don't override those. |
251 | set existing_torture_options [torture-options-exist] | |
252 | if { $existing_torture_options == 0 } { | |
7bfefa9d | 253 | global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS |
07e23beb | 254 | torture-init |
7bfefa9d | 255 | set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS |
07e23beb | 256 | } |
257 | dump-torture-options | |
258 | ||
e2d12d23 | 259 | foreach test $testcases { |
07e23beb | 260 | global torture_with_loops torture_without_loops |
ccb84981 | 261 | # If we're only testing specific files and this isn't one of |
e2d12d23 | 262 | # them, skip it. |
263 | if ![runtest_file_p $runtests $test] { | |
264 | continue | |
265 | } | |
266 | ||
267 | # Look for a loop within the source code - if we don't find one, | |
268 | # don't pass -funroll[-all]-loops. | |
e2d12d23 | 269 | if [expr [search_for $test "for*("]+[search_for $test "while*("]] { |
270 | set option_list $torture_with_loops | |
271 | } else { | |
272 | set option_list $torture_without_loops | |
273 | } | |
274 | ||
275 | set nshort [file tail [file dirname $test]]/[file tail $test] | |
276 | ||
277 | foreach flags $option_list { | |
278 | verbose "Testing $nshort, $flags" 1 | |
279 | dg-test $test $flags ${default-extra-flags} | |
280 | } | |
281 | } | |
07e23beb | 282 | |
283 | if { $existing_torture_options == 0 } { | |
284 | torture-finish | |
285 | } | |
e2d12d23 | 286 | } |
759a7941 | 287 | |
c7410b29 | 288 | proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } { |
759a7941 | 289 | global srcdir subdir |
290 | ||
291 | if ![info exists DEBUG_TORTURE_OPTIONS] { | |
292 | set DEBUG_TORTURE_OPTIONS "" | |
293 | foreach type {-gdwarf-2 -gstabs -gstabs+ -gxcoff -gxcoff+ -gcoff} { | |
294 | set comp_output [$target_compile \ | |
295 | "$srcdir/$subdir/$trivial" "trivial.S" assembly \ | |
296 | "additional_flags=$type"] | |
b0e56fb1 | 297 | if { ! [string match "*: target system does not support the * debug format*" \ |
759a7941 | 298 | $comp_output] } { |
7313051f | 299 | remove-build-file "trivial.S" |
759a7941 | 300 | foreach level {1 "" 3} { |
23e27867 | 301 | if { ($type == "-gdwarf-2") && ($level != "") } { |
302 | lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"] | |
303 | foreach opt $opt_opts { | |
304 | lappend DEBUG_TORTURE_OPTIONS \ | |
305 | [list "${type}" "-g${level}" "$opt" ] | |
306 | } | |
307 | } else { | |
308 | lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"] | |
309 | foreach opt $opt_opts { | |
310 | lappend DEBUG_TORTURE_OPTIONS \ | |
311 | [list "${type}${level}" "$opt" ] | |
312 | } | |
759a7941 | 313 | } |
314 | } | |
315 | } | |
316 | } | |
317 | } | |
318 | ||
319 | verbose -log "Using options $DEBUG_TORTURE_OPTIONS" | |
320 | ||
321 | global runtests | |
322 | ||
323 | foreach test $testcases { | |
ccb84981 | 324 | # If we're only testing specific files and this isn't one of |
759a7941 | 325 | # them, skip it. |
326 | if ![runtest_file_p $runtests $test] { | |
327 | continue | |
328 | } | |
329 | ||
330 | set nshort [file tail [file dirname $test]]/[file tail $test] | |
331 | ||
332 | foreach flags $DEBUG_TORTURE_OPTIONS { | |
333 | set doit 1 | |
89c30811 | 334 | |
335 | # These tests check for information which may be deliberately | |
336 | # suppressed at -g1. | |
337 | if { ([string match {*/debug-[126].c} "$nshort"] \ | |
338 | || [string match {*/enum-1.c} "$nshort"] \ | |
339 | || [string match {*/enum-[12].C} "$nshort"]) \ | |
23e27867 | 340 | && ([string match "*1" [lindex "$flags" 0] ] |
341 | || [lindex "$flags" 1] == "-g1") } { | |
759a7941 | 342 | set doit 0 |
343 | } | |
344 | ||
345 | # High optimization can remove the variable whose existence is tested. | |
346 | # Dwarf debugging with commentary (-dA) preserves the symbol name in the | |
347 | # assembler output, but stabs debugging does not. | |
348 | # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html | |
349 | if { [string match {*/debug-[12].c} "$nshort"] \ | |
a0f2683e | 350 | && [string match "*O*" "$flags"] \ |
759a7941 | 351 | && ( [string match "*coff*" "$flags"] \ |
352 | || [string match "*stabs*" "$flags"] ) } { | |
353 | set doit 0 | |
354 | } | |
355 | ||
356 | if { $doit } { | |
357 | verbose -log "Testing $nshort, $flags" 1 | |
358 | dg-test $test $flags "" | |
359 | } | |
360 | } | |
361 | } | |
362 | } | |
176dca07 | 363 | |
e3a37c0a | 364 | # Prune any messages matching ARGS[1] (a regexp) from test output. |
365 | proc dg-prune-output { args } { | |
366 | global additional_prunes | |
367 | ||
368 | if { [llength $args] != 2 } { | |
369 | error "[lindex $args 1]: need one argument" | |
370 | return | |
371 | } | |
372 | ||
373 | lappend additional_prunes [lindex $args 1] | |
374 | } | |
375 | ||
f3de6034 | 376 | # Remove files matching the pattern from the build machine. |
377 | proc remove-build-file { pat } { | |
378 | verbose "remove-build-file `$pat'" 2 | |
379 | set file_list "[glob -nocomplain $pat]" | |
380 | verbose "remove-build-file `$file_list'" 2 | |
381 | foreach output_file $file_list { | |
644baec3 | 382 | if [is_remote host] { |
383 | # Ensure the host knows the file is gone by deleting there | |
384 | # first. | |
385 | remote_file host delete $output_file | |
386 | } | |
f3de6034 | 387 | remote_file build delete $output_file |
388 | } | |
389 | } | |
390 | ||
eb40a7e2 | 391 | # Remove runtime-generated profile file for the current test. |
392 | proc cleanup-profile-file { } { | |
393 | remove-build-file "mon.out" | |
394 | remove-build-file "gmon.out" | |
395 | } | |
396 | ||
f3de6034 | 397 | # Remove compiler-generated coverage files for the current test. |
398 | proc cleanup-coverage-files { } { | |
9be10dff | 399 | # This assumes that we are two frames down from dg-test or some other proc |
400 | # that stores the filename of the testcase in a local variable "name". | |
f3de6034 | 401 | # A cleaner solution would require a new DejaGnu release. |
402 | upvar 2 name testcase | |
403 | remove-build-file "[file rootname [file tail $testcase]].gc??" | |
404 | ||
405 | # Clean up coverage files for additional source files. | |
406 | if [info exists additional_sources] { | |
407 | foreach srcfile $additional_sources { | |
408 | remove-build-file "[file rootname [file tail $srcfile]].gc??" | |
409 | } | |
410 | } | |
411 | } | |
412 | ||
413 | # Remove compiler-generated files from -repo for the current test. | |
414 | proc cleanup-repo-files { } { | |
9be10dff | 415 | # This assumes that we are two frames down from dg-test or some other proc |
416 | # that stores the filename of the testcase in a local variable "name". | |
f3de6034 | 417 | # A cleaner solution would require a new DejaGnu release. |
418 | upvar 2 name testcase | |
419 | remove-build-file "[file rootname [file tail $testcase]].o" | |
420 | remove-build-file "[file rootname [file tail $testcase]].rpo" | |
421 | ||
422 | # Clean up files for additional source files. | |
423 | if [info exists additional_sources] { | |
424 | foreach srcfile $additional_sources { | |
425 | remove-build-file "[file rootname [file tail $srcfile]].o" | |
426 | remove-build-file "[file rootname [file tail $srcfile]].rpo" | |
427 | } | |
428 | } | |
429 | } | |
430 | ||
431 | # Remove compiler-generated RTL dump files for the current test. | |
432 | # | |
433 | # SUFFIX is the filename suffix pattern. | |
434 | proc cleanup-rtl-dump { suffix } { | |
6354626c | 435 | cleanup-dump "\[0-9\]\[0-9\]\[0-9\]r.$suffix" |
f3de6034 | 436 | } |
437 | ||
438 | # Remove a specific tree dump file for the current test. | |
439 | # | |
ab4b7a8a | 440 | # SUFFIX is the tree dump file suffix pattern. |
f3de6034 | 441 | proc cleanup-tree-dump { suffix } { |
6354626c | 442 | cleanup-dump "\[0-9\]\[0-9\]\[0-9\]t.$suffix" |
f3de6034 | 443 | } |
444 | ||
9be10dff | 445 | # Remove a specific ipa dump file for the current test. |
446 | # | |
ab4b7a8a | 447 | # SUFFIX is the ipa dump file suffix pattern. |
9be10dff | 448 | proc cleanup-ipa-dump { suffix } { |
6354626c | 449 | cleanup-dump "\[0-9\]\[0-9\]\[0-9\]i.$suffix" |
ab4b7a8a | 450 | } |
451 | ||
452 | # Remove all dump files with the provided suffix. | |
453 | proc cleanup-dump { suffix } { | |
454 | # This assumes that we are three frames down from dg-test or some other | |
455 | # proc that stores the filename of the testcase in a local variable | |
456 | # "name". A cleaner solution would require a new DejaGnu release. | |
457 | upvar 3 name testcase | |
a0c4949e | 458 | # The name might include a list of options; extract the file name. |
459 | set src [file tail [lindex $testcase 0]] | |
460 | remove-build-file "[file tail $src].$suffix" | |
9845d120 | 461 | # -fcompare-debug dumps |
462 | remove-build-file "[file tail $src].gk.$suffix" | |
9be10dff | 463 | |
464 | # Clean up dump files for additional source files. | |
465 | if [info exists additional_sources] { | |
466 | foreach srcfile $additional_sources { | |
ab4b7a8a | 467 | remove-build-file "[file tail $srcfile].$suffix" |
9845d120 | 468 | # -fcompare-debug dumps |
469 | remove-build-file "[file tail $srcfile].gk.$suffix" | |
9be10dff | 470 | } |
471 | } | |
472 | } | |
473 | ||
f3de6034 | 474 | # Remove files kept by --save-temps for the current test. |
475 | # | |
0a77b1e6 | 476 | # Currently this is only .i, .ii, .s and .o files, but more can be added |
d98a3884 | 477 | # if there are tests generating them. |
6de6ecaa | 478 | # ARGS is a list of suffixes to NOT delete. |
479 | proc cleanup-saved-temps { args } { | |
f3de6034 | 480 | global additional_sources |
6de6ecaa | 481 | set suffixes {} |
482 | ||
483 | # add the to-be-kept suffixes | |
9845d120 | 484 | foreach suffix {".ii" ".i" ".s" ".o" ".gkd"} { |
6de6ecaa | 485 | if {[lsearch $args $suffix] < 0} { |
486 | lappend suffixes $suffix | |
487 | } | |
488 | } | |
f3de6034 | 489 | |
9be10dff | 490 | # This assumes that we are two frames down from dg-test or some other proc |
491 | # that stores the filename of the testcase in a local variable "name". | |
f3de6034 | 492 | # A cleaner solution would require a new DejaGnu release. |
493 | upvar 2 name testcase | |
6de6ecaa | 494 | foreach suffix $suffixes { |
495 | remove-build-file "[file rootname [file tail $testcase]]$suffix" | |
9845d120 | 496 | # -fcompare-debug dumps |
497 | remove-build-file "[file rootname [file tail $testcase]].gk$suffix" | |
6de6ecaa | 498 | } |
f3de6034 | 499 | |
500 | # Clean up saved temp files for additional source files. | |
501 | if [info exists additional_sources] { | |
502 | foreach srcfile $additional_sources { | |
6de6ecaa | 503 | foreach suffix $suffixes { |
504 | remove-build-file "[file rootname [file tail $srcfile]]$suffix" | |
9845d120 | 505 | # -fcompare-debug dumps |
506 | remove-build-file "[file rootname [file tail $srcfile]].gk$suffix" | |
6de6ecaa | 507 | } |
f3de6034 | 508 | } |
509 | } | |
510 | } | |
511 | ||
7e44283b | 512 | # Remove files for specified Fortran modules. |
513 | proc cleanup-modules { modlist } { | |
514 | foreach modname $modlist { | |
515 | remove-build-file [string tolower $modname].mod | |
516 | } | |
517 | } | |
518 | ||
d98a4832 | 519 | # Scan Fortran modules for a given regexp. |
520 | # | |
521 | # Argument 0 is the module name | |
522 | # Argument 1 is the regexp to match | |
523 | proc scan-module { args } { | |
524 | set modfilename [string tolower [lindex $args 0]].mod | |
525 | set fd [open $modfilename r] | |
526 | set text [read $fd] | |
527 | close $fd | |
528 | ||
529 | upvar 2 name testcase | |
530 | if [regexp -- [lindex $args 1] $text] { | |
531 | pass "$testcase scan-module [lindex $args 1]" | |
532 | } else { | |
533 | fail "$testcase scan-module [lindex $args 1]" | |
534 | } | |
535 | } | |
536 | ||
3dfef819 | 537 | # Verify that the compiler output file exists, invoked via dg-final. |
538 | proc output-exists { args } { | |
539 | # Process an optional target or xfail list. | |
540 | if { [llength $args] >= 1 } { | |
541 | switch [dg-process-target [lindex $args 0]] { | |
542 | "S" { } | |
543 | "N" { return } | |
544 | "F" { setup_xfail "*-*-*" } | |
545 | "P" { } | |
546 | } | |
547 | } | |
548 | ||
549 | # Access variables from gcc-dg-test-1. | |
550 | upvar 2 name testcase | |
551 | upvar 2 output_file output_file | |
552 | ||
553 | if [file exists $output_file] { | |
554 | pass "$testcase output-exists $output_file" | |
555 | } else { | |
556 | fail "$testcase output-exists $output_file" | |
557 | } | |
558 | } | |
559 | ||
560 | # Verify that the compiler output file does not exist, invoked via dg-final. | |
561 | proc output-exists-not { args } { | |
562 | # Process an optional target or xfail list. | |
563 | if { [llength $args] >= 1 } { | |
564 | switch [dg-process-target [lindex $args 0]] { | |
565 | "S" { } | |
566 | "N" { return } | |
567 | "F" { setup_xfail "*-*-*" } | |
568 | "P" { } | |
569 | } | |
570 | } | |
571 | ||
572 | # Access variables from gcc-dg-test-1. | |
573 | upvar 2 name testcase | |
574 | upvar 2 output_file output_file | |
575 | ||
576 | if [file exists $output_file] { | |
577 | fail "$testcase output-exists-not $output_file" | |
578 | } else { | |
579 | pass "$testcase output-exists-not $output_file" | |
580 | } | |
581 | } | |
582 | ||
e3a37c0a | 583 | # We need to make sure that additional_* are cleared out after every |
584 | # test. It is not enough to clear them out *before* the next test run | |
585 | # because gcc-target-compile gets run directly from some .exp files | |
586 | # (outside of any test). (Those uses should eventually be eliminated.) | |
91a385a5 | 587 | |
588 | # Because the DG framework doesn't provide a hook that is run at the | |
589 | # end of a test, we must replace dg-test with a wrapper. | |
590 | ||
591 | if { [info procs saved-dg-test] == [list] } { | |
592 | rename dg-test saved-dg-test | |
593 | ||
594 | proc dg-test { args } { | |
595 | global additional_files | |
596 | global additional_sources | |
e3a37c0a | 597 | global additional_prunes |
91a385a5 | 598 | global errorInfo |
5e36c6f6 | 599 | global compiler_conditional_xfail_data |
c7a67206 | 600 | global shouldfail |
91a385a5 | 601 | |
602 | if { [ catch { eval saved-dg-test $args } errmsg ] } { | |
603 | set saved_info $errorInfo | |
604 | set additional_files "" | |
605 | set additional_sources "" | |
e3a37c0a | 606 | set additional_prunes "" |
c7a67206 | 607 | set shouldfail 0 |
5e36c6f6 | 608 | if [info exists compiler_conditional_xfail_data] { |
609 | unset compiler_conditional_xfail_data | |
610 | } | |
0557b60a | 611 | unset_timeout_vars |
91a385a5 | 612 | error $errmsg $saved_info |
613 | } | |
614 | set additional_files "" | |
615 | set additional_sources "" | |
e3a37c0a | 616 | set additional_prunes "" |
c7a67206 | 617 | set shouldfail 0 |
0557b60a | 618 | unset_timeout_vars |
5e36c6f6 | 619 | if [info exists compiler_conditional_xfail_data] { |
620 | unset compiler_conditional_xfail_data | |
621 | } | |
91a385a5 | 622 | } |
623 | } | |
f347a455 | 624 | |
024ff6a0 | 625 | if { [info procs saved-dg-warning] == [list] \ |
626 | && [info exists gcc_warning_prefix] } { | |
627 | rename dg-warning saved-dg-warning | |
628 | ||
629 | proc dg-warning { args } { | |
630 | # Make this variable available here and to the saved proc. | |
631 | upvar dg-messages dg-messages | |
632 | global gcc_warning_prefix | |
633 | ||
634 | process-message saved-dg-warning "$gcc_warning_prefix" "$args" | |
635 | } | |
636 | } | |
637 | ||
638 | if { [info procs saved-dg-error] == [list] \ | |
639 | && [info exists gcc_error_prefix] } { | |
640 | rename dg-error saved-dg-error | |
641 | ||
642 | proc dg-error { args } { | |
643 | # Make this variable available here and to the saved proc. | |
644 | upvar dg-messages dg-messages | |
645 | global gcc_error_prefix | |
646 | ||
647 | process-message saved-dg-error "$gcc_error_prefix" "$args" | |
648 | } | |
b559b9e2 | 649 | |
650 | # Override dg-bogus at the same time. It doesn't handle a prefix | |
651 | # but its expression should include a column number. Otherwise the | |
652 | # line number can match the column number for other messages, leading | |
653 | # to insanity. | |
654 | rename dg-bogus saved-dg-bogus | |
655 | ||
656 | proc dg-bogus { args } { | |
657 | upvar dg-messages dg-messages | |
658 | process-message saved-dg-bogus "" $args | |
659 | } | |
024ff6a0 | 660 | } |
661 | ||
5130af5f | 662 | # Modify the regular expression saved by a DejaGnu message directive to |
663 | # include a prefix and to force the expression to match a single line. | |
664 | # MSGPROC is the procedure to call. | |
665 | # MSGPREFIX is the prefix to prepend. | |
666 | # DGARGS is the original argument list. | |
667 | ||
668 | proc process-message { msgproc msgprefix dgargs } { | |
669 | upvar dg-messages dg-messages | |
670 | ||
671 | # Process the dg- directive, including adding the regular expression | |
672 | # to the new message entry in dg-messages. | |
673 | set msgcnt [llength ${dg-messages}] | |
674 | catch { eval $msgproc $dgargs } | |
675 | ||
676 | # If the target expression wasn't satisfied there is no new message. | |
677 | if { [llength ${dg-messages}] == $msgcnt } { | |
678 | return; | |
679 | } | |
680 | ||
b559b9e2 | 681 | # Get the entry for the new message. Prepend the message prefix to |
682 | # the regular expression and make it match a single line. | |
5130af5f | 683 | set newentry [lindex ${dg-messages} end] |
684 | set expmsg [lindex $newentry 2] | |
d520c1f2 | 685 | |
b559b9e2 | 686 | # Handle column numbers from the specified expression (if there is |
687 | # one) and set up the search expression that will be used by DejaGnu. | |
d520c1f2 | 688 | if [regexp "^(\[0-9\]+):" $expmsg "" column] { |
b559b9e2 | 689 | # The expression in the directive included a column number. |
690 | # Remove "COLUMN:" from the original expression and move it | |
691 | # to the proper place in the search expression. | |
d520c1f2 | 692 | regsub "^\[0-9\]+:" $expmsg "" expmsg |
b559b9e2 | 693 | set expmsg "$column: $msgprefix\[^\n\]*$expmsg" |
694 | } elseif [string match "" [lindex $newentry 0]] { | |
695 | # The specified line number is 0; don't expect a column number. | |
696 | set expmsg "$msgprefix\[^\n\]*$expmsg" | |
d520c1f2 | 697 | } else { |
b559b9e2 | 698 | # There is no column number in the search expression, but we |
699 | # should expect one in the message itself. | |
700 | set expmsg "\[0-9\]+: $msgprefix\[^\n\]*$expmsg" | |
d520c1f2 | 701 | } |
702 | ||
5130af5f | 703 | set newentry [lreplace $newentry 2 2 $expmsg] |
704 | set dg-messages [lreplace ${dg-messages} end end $newentry] | |
705 | verbose "process-message:\n${dg-messages}" 2 | |
706 | } | |
707 | ||
708 | # Look for messages that don't have standard prefixes. | |
709 | ||
710 | proc dg-message { args } { | |
711 | upvar dg-messages dg-messages | |
024ff6a0 | 712 | process-message saved-dg-warning "" $args |
5130af5f | 713 | } |
714 | ||
e3a37c0a | 715 | set additional_prunes "" |