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