OSDN Git Service

* lib/target-supports-dg.exp (check-flags): New.
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / lib / target-supports-dg.exp
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
15 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
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 } {
35     set visibility_available [ check_visibility_available [lindex $args 1 ] ]
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
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
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
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
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
189     # These variables are from DejaGnu's dg-test.
190     upvar dg-extra-tool-flags extra_tool_flags
191     upvar tool_flags tool_flags
192
193     # The args are within another list; pull them out.
194     set args [lindex $args 0]
195
196     # Start the list with a dummy tool name so the list will match "*"
197     # if there are no flags.
198     set compiler_flags " toolname "
199     append compiler_flags $extra_tool_flags
200     append compiler_flags $tool_flags
201     set dest [target_info name]
202     if [board_info $dest exists multilib_flags] {
203         append compiler_flags "[board_info $dest multilib_flags] "
204     }
205
206     # The target list might be an effective-target keyword, so replace
207     # the original list with "*-*-*", since we already know it matches.
208     set result [check_conditional_xfail [lreplace $args 1 1 "*-*-*"]]
209
210     # Any value in this variable was left over from an earlier test.
211     set compiler_flags ""
212
213     return $result
214 }
215
216 # Skip the test (report it as UNSUPPORTED) if the target list and
217 # included flags are matched and the excluded flags are not matched.
218 #
219 # The first argument is the line number of the dg-skip-if directive
220 # within the test file.   Remaining arguments are as for xfail lists:
221 # message { targets } { include } { exclude }
222 #
223 # This tests against multilib flags plus either the default flags for this
224 # group of tests or flags specified with a previous dg-options command.
225
226 proc dg-skip-if { args } {
227     # Don't bother if we're already skipping the test.
228     upvar dg-do-what dg-do-what
229     if { [lindex ${dg-do-what} 1] == "N" } {
230       return
231     }
232
233     set args [lreplace $args 0 0]
234
235     set selector [list target [lindex $args 1]]
236     if { [dg-process-target $selector] == "S" } {
237         # These are defined in DejaGnu's dg-test, needed by check-flags.
238         upvar dg-extra-tool-flags dg-extra-tool-flags
239         upvar tool_flags tool_flags
240
241         if [check-flags $args] {
242             upvar dg-do-what dg-do-what
243             set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"]
244         }
245     }
246 }
247
248 # Like check_conditional_xfail, but callable from a dg test.
249
250 proc dg-xfail-if { args } {
251     # Don't change anything if we're already skipping the test.
252     upvar dg-do-what dg-do-what
253     if { [lindex ${dg-do-what} 1] == "N" } {
254       return
255     }
256
257     set args [lreplace $args 0 0]
258     set selector [list target [lindex $args 1]]
259     if { [dg-process-target $selector] == "S" } {
260         global compiler_conditional_xfail_data
261         set compiler_conditional_xfail_data [lreplace $args 1 1 "*-*-*"]
262     }
263 }
264
265 # Intercept the call to the DejaGnu version of dg-process-target to
266 # support use of an effective-target keyword in place of a list of
267 # target triplets to xfail or skip a test.
268 #
269 # selector is one of:
270 #    xfail target-triplet-1 ...
271 #    xfail effective-target-keyword
272 #    xfail selector-expression
273 #    target target-triplet-1 ...
274 #    target effective-target-keyword
275 #    target selector-expression
276 #
277 # For a target list the result is "S" if the target is selected, "N" otherwise.
278 # For an xfail list the result is "F" if the target is affected, "P" otherwise.
279 #
280 # A selector expression appears within curly braces and uses a single logical
281 # operator: !, &&, or ||.  An operand is another selector expression, an
282 # effective-target keyword, or a list of target triplets within quotes or
283 # curly braces.
284
285 if { [info procs saved-dg-process-target] == [list] } {
286     rename dg-process-target saved-dg-process-target
287
288     # Evaluate an operand within a selector expression.
289     proc selector_opd { op } {
290         set selector "target"
291         lappend selector $op
292         set answer [ expr { [dg-process-target $selector] == "S" } ]
293         verbose "selector_opd: `$op' $answer" 2
294         return $answer
295     }
296
297     # Evaluate a target triplet list within a selector expression.
298     # Unlike other operands, this needs to be expanded from a list to
299     # the same string as "target".
300     proc selector_list { op } {
301         set selector "target [join $op]"
302         set answer [ expr { [dg-process-target $selector] == "S" } ]
303         verbose "selector_list: `$op' $answer" 2
304         return $answer
305     }
306
307     # Evaluate a selector expression.
308     proc selector_expression { exp } {
309         if { [llength $exp] == 2 } {
310             if [string match "!" [lindex $exp 0]] {
311                 set op1 [lindex $exp 1]
312                 set answer [expr { ! [selector_opd $op1] }]
313             } else {
314                 # Assume it's a list of target triplets.
315                 set answer [selector_list $exp]
316             }
317         } elseif { [llength $exp] == 3 } {
318             set op1 [lindex $exp 0]
319             set opr [lindex $exp 1]
320             set op2 [lindex $exp 2]
321             if [string match "&&" $opr] {
322                 set answer [expr { [selector_opd $op1] && [selector_opd $op2] }]
323             } elseif [string match "||" $opr] {
324                 set answer [expr { [selector_opd $op1] || [selector_opd $op2] }]
325             } else {
326                 # Assume it's a list of target triplets.
327                 set answer [selector_list $exp]
328             }
329         } else {
330             # Assume it's a list of target triplets.
331             set answer [selector_list $exp]
332         }
333
334         verbose "selector_expression: `$exp' $answer" 2
335         return $answer
336     }
337
338     proc dg-process-target { args } {
339         verbose "replacement dg-process-target: `$args'" 2
340         
341         # Extract the 'what' keyword from the argument list.
342         set selector [string trim [lindex $args 0]]
343         if [regexp "^xfail " $selector] {
344             set what "xfail"
345         } elseif [regexp "^target " $selector] {
346             set what "target"
347         } else {
348             error "syntax error in target selector \"$selector\""
349         }
350
351         # Extract the rest of the list, which might be a keyword.
352         regsub "^${what}" $selector "" rest
353         set rest [string trim $rest]
354
355         if [is-effective-target-keyword $rest] {
356             # The selector is an effective target keyword.
357             if [is-effective-target $rest] {
358                 return [expr { $what == "xfail" ? "F" : "S" }]
359             } else {
360                 return [expr { $what == "xfail" ? "P" : "N" }]
361             }
362         }
363
364         if [string match "{*}" $rest] {
365             if [selector_expression [lindex $rest 0]] {
366                 return [expr { $what == "xfail" ? "F" : "S" }]
367             } else {
368                 return [expr { $what == "xfail" ? "P" : "N" }]
369             }
370         }
371
372         # The selector is not an effective-target keyword, so process
373         # the list of target triplets.
374         return [saved-dg-process-target $selector]
375     }
376 }