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