]>
Commit | Line | Data |
---|---|---|
40f1bdd9 | 1 | # Copyright (C) 1997, 1999, 2000, 2003, 2004, 2005, 2007, 2008, 2009, 2010 |
cd976c16 | 2 | # Free Software Foundation, Inc. |
a29c731d JJ |
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 |
a29c731d JJ |
7 | # (at your option) any later version. |
8 | # | |
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. | |
13 | # | |
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/>. | |
a29c731d | 17 | |
30af0edb JJ |
18 | # DejaGnu's dg-test defines extra flags that are used to compile a test. |
19 | # Access them for directives that need to examine all options that are | |
20 | # used for a test, including checks for non-cached effective targets. | |
21 | # We don't know how far up the call chain it is but we know we'll hit | |
22 | # it eventually, and that we're at least 3 calls down. | |
23 | ||
24 | proc current_compiler_flags { } { | |
25 | set frames 2 | |
26 | while { ![info exists flags1] } { | |
27 | set frames [expr $frames + 1] | |
28 | upvar $frames dg-extra-tool-flags flags1 | |
29 | } | |
30 | upvar $frames tool_flags flags2 | |
31 | return "$flags1 $flags2" | |
32 | } | |
33 | ||
a29c731d JJ |
34 | # If this target does not support weak symbols, skip this test. |
35 | ||
36 | proc dg-require-weak { args } { | |
37 | set weak_available [ check_weak_available ] | |
38 | if { $weak_available == -1 } { | |
39 | upvar name name | |
40 | unresolved "$name" | |
41 | } | |
42 | if { $weak_available != 1 } { | |
43 | upvar dg-do-what dg-do-what | |
44 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
45 | } | |
46 | } | |
47 | ||
8a0963c3 JM |
48 | # If this target does not support overriding weak symbols, skip this |
49 | # test. | |
50 | ||
51 | proc dg-require-weak-override { args } { | |
52 | set weak_override_available [ check_weak_override_available ] | |
53 | if { $weak_override_available == -1 } { | |
54 | upvar name name | |
55 | unresolved "$name" | |
56 | } | |
57 | if { $weak_override_available != 1 } { | |
58 | upvar dg-do-what dg-do-what | |
59 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
60 | } | |
61 | } | |
62 | ||
a29c731d JJ |
63 | # If this target does not support the "visibility" attribute, skip this |
64 | # test. | |
65 | ||
66 | proc dg-require-visibility { args } { | |
d3d9a67f | 67 | set visibility_available [ check_visibility_available [lindex $args 1 ] ] |
a29c731d JJ |
68 | if { $visibility_available == -1 } { |
69 | upvar name name | |
70 | unresolved "$name" | |
71 | } | |
72 | if { $visibility_available != 1 } { | |
73 | upvar dg-do-what dg-do-what | |
74 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
75 | } | |
76 | } | |
77 | ||
78 | # If this target does not support the "alias" attribute, skip this | |
79 | # test. | |
80 | ||
81 | proc dg-require-alias { args } { | |
82 | set alias_available [ check_alias_available ] | |
83 | if { $alias_available == -1 } { | |
84 | upvar name name | |
85 | unresolved "$name" | |
86 | } | |
87 | if { $alias_available < 2 } { | |
88 | upvar dg-do-what dg-do-what | |
89 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
90 | } | |
91 | } | |
92 | ||
ba885ec5 NS |
93 | # If this target does not support the "ifunc" attribute, skip this |
94 | # test. | |
95 | ||
96 | proc dg-require-ifunc { args } { | |
f6c5fbfd | 97 | if { ![ check_ifunc_available ] } { |
ba885ec5 NS |
98 | upvar dg-do-what dg-do-what |
99 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
100 | } | |
101 | } | |
102 | ||
a29c731d JJ |
103 | # If this target's linker does not support the --gc-sections flag, |
104 | # skip this test. | |
105 | ||
106 | proc dg-require-gc-sections { args } { | |
107 | if { ![ check_gc_sections_available ] } { | |
108 | upvar dg-do-what dg-do-what | |
109 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
110 | } | |
111 | } | |
112 | ||
113 | # If this target does not support profiling, skip this test. | |
114 | ||
115 | proc dg-require-profiling { args } { | |
116 | if { ![ check_profiling_available ${args} ] } { | |
117 | upvar dg-do-what dg-do-what | |
118 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
119 | } | |
120 | } | |
121 | ||
122 | # If this target does not support DLL attributes skip this test. | |
123 | ||
124 | proc dg-require-dll { args } { | |
125 | global target_triplet | |
126 | # As a special case, the mcore-*-elf supports these attributes. | |
127 | # All Symbian OS targets also support these attributes. | |
128 | if { [string match "mcore-*-elf" $target_triplet] | |
129 | || [string match "*-*-symbianelf" $target_triplet]} { | |
130 | return | |
131 | } | |
132 | # PE/COFF targets support dllimport/dllexport. | |
133 | if { [gcc_target_object_format] == "pe" } { | |
134 | return | |
135 | } | |
136 | ||
137 | upvar dg-do-what dg-do-what | |
138 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
139 | } | |
140 | ||
141 | proc dg-require-iconv { args } { | |
142 | if { ![ check_iconv_available ${args} ] } { | |
143 | upvar dg-do-what dg-do-what | |
144 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
145 | } | |
146 | } | |
147 | ||
148 | # If this target does not support named sections skip this test. | |
149 | ||
150 | proc dg-require-named-sections { args } { | |
151 | if { ![ check_named_sections_available ] } { | |
152 | upvar dg-do-what dg-do-what | |
153 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
154 | } | |
155 | } | |
156 | ||
157 | # If the target does not match the required effective target, skip this test. | |
40f1bdd9 | 158 | # Only apply this if the optional selector matches. |
a29c731d JJ |
159 | |
160 | proc dg-require-effective-target { args } { | |
161 | set args [lreplace $args 0 0] | |
40f1bdd9 RO |
162 | # Verify the number of arguments. The last is optional. |
163 | if { [llength $args] < 1 || [llength $args] > 2 } { | |
164 | error "syntax error, need a single effective-target keyword with optional selector" | |
57647020 | 165 | } |
40f1bdd9 RO |
166 | |
167 | # Evaluate selector if present. | |
168 | if { [llength $args] == 2 } { | |
169 | switch [dg-process-target [lindex $args 1]] { | |
170 | "S" { } | |
171 | "N" { return } | |
172 | } | |
173 | } | |
174 | ||
a29c731d JJ |
175 | if { ![is-effective-target [lindex $args 0]] } { |
176 | upvar dg-do-what dg-do-what | |
177 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
178 | } | |
179 | } | |
180 | ||
34f4edf8 MM |
181 | # If this target does not have fork, skip this test. |
182 | ||
183 | proc dg-require-fork { args } { | |
184 | if { ![check_fork_available] } { | |
185 | upvar dg-do-what dg-do-what | |
186 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
187 | } | |
188 | } | |
189 | ||
190 | # If this target does not have mkfifo, skip this test. | |
191 | ||
192 | proc dg-require-mkfifo { args } { | |
193 | if { ![check_mkfifo_available] } { | |
194 | upvar dg-do-what dg-do-what | |
195 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
196 | } | |
197 | } | |
198 | ||
21f638b9 SE |
199 | # If this target does not use __cxa_atexit, skip this test. |
200 | ||
201 | proc dg-require-cxa-atexit { args } { | |
202 | if { ![ check_cxa_atexit_available ] } { | |
203 | upvar dg-do-what dg-do-what | |
204 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
205 | } | |
206 | } | |
207 | ||
7cff41e8 JM |
208 | # If the host is remote rather than the same as the build system, skip |
209 | # this test. Some tests are incompatible with DejaGnu's handling of | |
210 | # remote hosts, which involves copying the source file to the host and | |
211 | # compiling it with a relative path and "-o a.out". | |
212 | ||
213 | proc dg-require-host-local { args } { | |
214 | if [ is_remote host ] { | |
215 | upvar dg-do-what dg-do-what | |
216 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
3cf8ccdf RG |
217 | } |
218 | } | |
219 | ||
220 | proc dg-require-linker-plugin { args } { | |
221 | set linker_plugin_available [ check_linker_plugin_available ] | |
222 | if { $linker_plugin_available == 0 } { | |
223 | upvar dg-do-what dg-do-what | |
224 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
7cff41e8 JM |
225 | } |
226 | } | |
227 | ||
db9a0df0 RS |
228 | # Add any target-specific flags needed for accessing the given list |
229 | # of features. This must come after all dg-options. | |
230 | ||
231 | proc dg-add-options { args } { | |
232 | upvar dg-extra-tool-flags extra-tool-flags | |
233 | ||
234 | foreach arg [lrange $args 1 end] { | |
235 | if { [info procs add_options_for_$arg] != "" } { | |
236 | set extra-tool-flags \ | |
237 | [eval [list add_options_for_$arg ${extra-tool-flags}]] | |
238 | } else { | |
239 | error "Unrecognized option type: $arg" | |
240 | } | |
241 | } | |
242 | } | |
243 | ||
65c3758b JJ |
244 | # Compare flags for a test directive against flags that will be used to |
245 | # compile the test: multilib flags, flags for torture options, and either | |
246 | # the default flags for this group of tests or flags specified with a | |
247 | # previous dg-options directive. | |
248 | ||
249 | proc check-flags { args } { | |
250 | global compiler_flags | |
2094534c | 251 | global TOOL_OPTIONS |
65c3758b JJ |
252 | |
253 | # The args are within another list; pull them out. | |
254 | set args [lindex $args 0] | |
255 | ||
256 | # Start the list with a dummy tool name so the list will match "*" | |
257 | # if there are no flags. | |
258 | set compiler_flags " toolname " | |
30af0edb | 259 | append compiler_flags [current_compiler_flags] |
2094534c MS |
260 | # If running a subset of the test suite, $TOOL_OPTIONS may not exist. |
261 | catch {append compiler_flags " $TOOL_OPTIONS "} | |
65c3758b JJ |
262 | set dest [target_info name] |
263 | if [board_info $dest exists multilib_flags] { | |
264 | append compiler_flags "[board_info $dest multilib_flags] " | |
265 | } | |
266 | ||
8ec49cff JJ |
267 | # The next two arguments are optional. If they were not specified, |
268 | # use the defaults. | |
269 | if { [llength $args] == 2 } { | |
270 | lappend $args [list "*"] | |
271 | } | |
272 | if { [llength $args] == 3 } { | |
273 | lappend $args [list ""] | |
274 | } | |
275 | ||
276 | # If the option strings are the defaults, or the same as the | |
277 | # defaults, there is no need to call check_conditional_xfail to | |
278 | # compare them to the actual options. | |
279 | if { [string compare [lindex $args 2] "*"] == 0 | |
280 | && [string compare [lindex $args 3] "" ] == 0 } { | |
281 | set result 1 | |
282 | } else { | |
283 | # The target list might be an effective-target keyword, so replace | |
284 | # the original list with "*-*-*", since we already know it matches. | |
285 | set result [check_conditional_xfail [lreplace $args 1 1 "*-*-*"]] | |
286 | } | |
65c3758b JJ |
287 | |
288 | # Any value in this variable was left over from an earlier test. | |
289 | set compiler_flags "" | |
290 | ||
291 | return $result | |
292 | } | |
293 | ||
a29c731d JJ |
294 | # Skip the test (report it as UNSUPPORTED) if the target list and |
295 | # included flags are matched and the excluded flags are not matched. | |
296 | # | |
297 | # The first argument is the line number of the dg-skip-if directive | |
298 | # within the test file. Remaining arguments are as for xfail lists: | |
299 | # message { targets } { include } { exclude } | |
300 | # | |
301 | # This tests against multilib flags plus either the default flags for this | |
302 | # group of tests or flags specified with a previous dg-options command. | |
303 | ||
304 | proc dg-skip-if { args } { | |
8ec49cff JJ |
305 | # Verify the number of arguments. The last two are optional. |
306 | set args [lreplace $args 0 0] | |
307 | if { [llength $args] < 2 || [llength $args] > 4 } { | |
308 | error "dg-skip-if 2: need 2, 3, or 4 arguments" | |
309 | } | |
310 | ||
65c3758b JJ |
311 | # Don't bother if we're already skipping the test. |
312 | upvar dg-do-what dg-do-what | |
313 | if { [lindex ${dg-do-what} 1] == "N" } { | |
314 | return | |
315 | } | |
316 | ||
c44ca162 | 317 | set selector [list target [lindex $args 1]] |
a29c731d | 318 | if { [dg-process-target $selector] == "S" } { |
65c3758b | 319 | if [check-flags $args] { |
a29c731d JJ |
320 | upvar dg-do-what dg-do-what |
321 | set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] | |
322 | } | |
a29c731d JJ |
323 | } |
324 | } | |
325 | ||
326 | # Like check_conditional_xfail, but callable from a dg test. | |
327 | ||
328 | proc dg-xfail-if { args } { | |
8ec49cff JJ |
329 | # Verify the number of arguments. The last three are optional. |
330 | set args [lreplace $args 0 0] | |
331 | if { [llength $args] < 2 || [llength $args] > 4 } { | |
332 | error "dg-xfail-if: need 2, 3, or 4 arguments" | |
333 | } | |
334 | ||
a29c731d JJ |
335 | # Don't change anything if we're already skipping the test. |
336 | upvar dg-do-what dg-do-what | |
337 | if { [lindex ${dg-do-what} 1] == "N" } { | |
338 | return | |
339 | } | |
340 | ||
c44ca162 | 341 | set selector [list target [lindex $args 1]] |
a29c731d JJ |
342 | if { [dg-process-target $selector] == "S" } { |
343 | global compiler_conditional_xfail_data | |
8ec49cff JJ |
344 | |
345 | # The target list might be an effective-target keyword. Replace | |
346 | # the original list with "*-*-*", since we already know it matches. | |
347 | set args [lreplace $args 1 1 "*-*-*"] | |
348 | ||
349 | # Supply default values for unspecified optional arguments. | |
350 | if { [llength $args] == 2 } { | |
351 | lappend $args [list "*"] | |
352 | } | |
353 | if { [llength $args] == 3 } { | |
354 | lappend $args [list ""] | |
355 | } | |
356 | ||
357 | set compiler_conditional_xfail_data $args | |
a29c731d JJ |
358 | } |
359 | } | |
360 | ||
00a25a2d JJ |
361 | # Like dg-xfail-if but for the execute step. |
362 | ||
363 | proc dg-xfail-run-if { args } { | |
8ec49cff JJ |
364 | # Verify the number of arguments. The last two are optional. |
365 | set args [lreplace $args 0 0] | |
366 | if { [llength $args] < 2 || [llength $args] > 4 } { | |
367 | error "dg-xfail-run-if: need 2, 3, or 4 arguments" | |
368 | } | |
369 | ||
00a25a2d JJ |
370 | # Don't bother if we're already skipping the test. |
371 | upvar dg-do-what dg-do-what | |
372 | if { [lindex ${dg-do-what} 1] == "N" } { | |
373 | return | |
374 | } | |
375 | ||
00a25a2d JJ |
376 | set selector [list target [lindex $args 1]] |
377 | if { [dg-process-target $selector] == "S" } { | |
00a25a2d JJ |
378 | if [check-flags $args] { |
379 | upvar dg-do-what dg-do-what | |
380 | set dg-do-what [list [lindex ${dg-do-what} 0] "S" "F"] | |
381 | } | |
382 | } | |
383 | } | |
384 | ||
263108e1 JJ |
385 | # Record whether the program is expected to return a nonzero status. |
386 | ||
387 | set shouldfail 0 | |
388 | ||
389 | proc dg-shouldfail { args } { | |
390 | # Don't bother if we're already skipping the test. | |
391 | upvar dg-do-what dg-do-what | |
392 | if { [lindex ${dg-do-what} 1] == "N" } { | |
393 | return | |
394 | } | |
395 | ||
396 | global shouldfail | |
397 | ||
398 | set args [lreplace $args 0 0] | |
399 | if { [llength $args] > 1 } { | |
400 | set selector [list target [lindex $args 1]] | |
401 | if { [dg-process-target $selector] == "S" } { | |
30af0edb | 402 | # The target matches, now check the flags. |
263108e1 JJ |
403 | if [check-flags $args] { |
404 | set shouldfail 1 | |
405 | } | |
406 | } | |
407 | } else { | |
408 | set shouldfail 1 | |
409 | } | |
410 | } | |
411 | ||
a29c731d JJ |
412 | # Intercept the call to the DejaGnu version of dg-process-target to |
413 | # support use of an effective-target keyword in place of a list of | |
414 | # target triplets to xfail or skip a test. | |
415 | # | |
416 | # selector is one of: | |
417 | # xfail target-triplet-1 ... | |
418 | # xfail effective-target-keyword | |
419 | # xfail selector-expression | |
420 | # target target-triplet-1 ... | |
421 | # target effective-target-keyword | |
422 | # target selector-expression | |
423 | # | |
424 | # For a target list the result is "S" if the target is selected, "N" otherwise. | |
425 | # For an xfail list the result is "F" if the target is affected, "P" otherwise. | |
426 | # | |
427 | # A selector expression appears within curly braces and uses a single logical | |
428 | # operator: !, &&, or ||. An operand is another selector expression, an | |
429 | # effective-target keyword, or a list of target triplets within quotes or | |
430 | # curly braces. | |
431 | ||
432 | if { [info procs saved-dg-process-target] == [list] } { | |
433 | rename dg-process-target saved-dg-process-target | |
434 | ||
435 | # Evaluate an operand within a selector expression. | |
436 | proc selector_opd { op } { | |
437 | set selector "target" | |
438 | lappend selector $op | |
439 | set answer [ expr { [dg-process-target $selector] == "S" } ] | |
440 | verbose "selector_opd: `$op' $answer" 2 | |
441 | return $answer | |
442 | } | |
443 | ||
444 | # Evaluate a target triplet list within a selector expression. | |
445 | # Unlike other operands, this needs to be expanded from a list to | |
446 | # the same string as "target". | |
447 | proc selector_list { op } { | |
448 | set selector "target [join $op]" | |
449 | set answer [ expr { [dg-process-target $selector] == "S" } ] | |
450 | verbose "selector_list: `$op' $answer" 2 | |
451 | return $answer | |
452 | } | |
453 | ||
454 | # Evaluate a selector expression. | |
455 | proc selector_expression { exp } { | |
456 | if { [llength $exp] == 2 } { | |
457 | if [string match "!" [lindex $exp 0]] { | |
458 | set op1 [lindex $exp 1] | |
459 | set answer [expr { ! [selector_opd $op1] }] | |
460 | } else { | |
461 | # Assume it's a list of target triplets. | |
462 | set answer [selector_list $exp] | |
463 | } | |
464 | } elseif { [llength $exp] == 3 } { | |
465 | set op1 [lindex $exp 0] | |
466 | set opr [lindex $exp 1] | |
467 | set op2 [lindex $exp 2] | |
468 | if [string match "&&" $opr] { | |
469 | set answer [expr { [selector_opd $op1] && [selector_opd $op2] }] | |
470 | } elseif [string match "||" $opr] { | |
471 | set answer [expr { [selector_opd $op1] || [selector_opd $op2] }] | |
472 | } else { | |
473 | # Assume it's a list of target triplets. | |
474 | set answer [selector_list $exp] | |
475 | } | |
476 | } else { | |
477 | # Assume it's a list of target triplets. | |
478 | set answer [selector_list $exp] | |
479 | } | |
480 | ||
481 | verbose "selector_expression: `$exp' $answer" 2 | |
482 | return $answer | |
483 | } | |
484 | ||
485 | proc dg-process-target { args } { | |
486 | verbose "replacement dg-process-target: `$args'" 2 | |
487 | ||
488 | # Extract the 'what' keyword from the argument list. | |
489 | set selector [string trim [lindex $args 0]] | |
490 | if [regexp "^xfail " $selector] { | |
491 | set what "xfail" | |
492 | } elseif [regexp "^target " $selector] { | |
493 | set what "target" | |
494 | } else { | |
495 | error "syntax error in target selector \"$selector\"" | |
496 | } | |
497 | ||
498 | # Extract the rest of the list, which might be a keyword. | |
499 | regsub "^${what}" $selector "" rest | |
500 | set rest [string trim $rest] | |
501 | ||
502 | if [is-effective-target-keyword $rest] { | |
503 | # The selector is an effective target keyword. | |
504 | if [is-effective-target $rest] { | |
505 | return [expr { $what == "xfail" ? "F" : "S" }] | |
506 | } else { | |
507 | return [expr { $what == "xfail" ? "P" : "N" }] | |
508 | } | |
509 | } | |
510 | ||
511 | if [string match "{*}" $rest] { | |
512 | if [selector_expression [lindex $rest 0]] { | |
513 | return [expr { $what == "xfail" ? "F" : "S" }] | |
514 | } else { | |
515 | return [expr { $what == "xfail" ? "P" : "N" }] | |
516 | } | |
517 | } | |
518 | ||
519 | # The selector is not an effective-target keyword, so process | |
520 | # the list of target triplets. | |
521 | return [saved-dg-process-target $selector] | |
522 | } | |
523 | } |