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