OSDN Git Service

Update FSF address.
[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 # Check the flags with which the test will be run against options in
144 # a test directive that will skip or xfail that test.  The DejaGnu proc
145 # check_conditional_xfail will look at the options in compiler_flags, so
146 # set that up for this test based on flags we know about.
147
148 proc check_test_flags { args } {
149     global compiler_flags
150     upvar 2 dg-extra-tool-flags extra_tool_flags
151
152     # Pull the args out of the enclosing list.
153     set args [lindex $args 0]
154
155     # Start the list with a dummy tool name so the list will match "*"
156     # if there are no flags.
157     set compiler_flags " toolname "
158     append compiler_flags $extra_tool_flags
159     set dest [target_info name]
160     if [board_info $dest exists multilib_flags] {
161         append compiler_flags "[board_info $dest multilib_flags] "
162     }
163
164     set answer [check_conditional_xfail $args]
165
166     # Any value in this variable originally was left over from an earlier test.
167     set compiler_flags ""
168
169     verbose "check_test_flags: $args $answer" 2
170     return $answer
171 }
172
173 # Skip the test (report it as UNSUPPORTED) if the target list and
174 # included flags are matched and the excluded flags are not matched.
175 #
176 # The first argument is the line number of the dg-skip-if directive
177 # within the test file.   Remaining arguments are as for xfail lists:
178 # message { targets } { include } { exclude }
179 #
180 # This tests against multilib flags plus either the default flags for this
181 # group of tests or flags specified with a previous dg-options command.
182
183 proc dg-skip-if { args } {
184     set args [lreplace $args 0 0]
185
186     set selector "target [join [lindex $args 1]]"
187     if { [dg-process-target $selector] == "S" } {
188         # The target list matched; now check the flags.  The DejaGnu proc
189         # check_conditional_xfail will look at the options in compiler_flags,
190         # so set that up for this test based on flags we know about.  Start
191         # the list with a dummy tool name so the list will match "*" if
192         # there are no flags.
193
194         global compiler_flags
195         upvar dg-extra-tool-flags extra_tool_flags
196
197         set compiler_flags " toolname "
198         append compiler_flags $extra_tool_flags
199         set dest [target_info name]
200         if [board_info $dest exists multilib_flags] {
201             append compiler_flags "[board_info $dest multilib_flags] "
202         }
203
204         # The target list might be an effective-target keyword, so replace
205         # the original list with "*-*-*".
206         if [check_conditional_xfail [lreplace $args 1 1 "*-*-*"]] {
207             upvar dg-do-what dg-do-what
208             set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"]
209         }
210
211         # Any value in this variable was left over from an earlier test.
212         set compiler_flags ""
213     }
214 }
215
216 # Like check_conditional_xfail, but callable from a dg test.
217
218 proc dg-xfail-if { args } {
219     # Don't change anything if we're already skipping the test.
220     upvar dg-do-what dg-do-what
221     if { [lindex ${dg-do-what} 1] == "N" } {
222       return
223     }
224
225     set args [lreplace $args 0 0]
226     set selector "target [join [lindex $args 1]]"
227     if { [dg-process-target $selector] == "S" } {
228         global compiler_conditional_xfail_data
229         set compiler_conditional_xfail_data [lreplace $args 1 1 "*-*-*"]
230     }
231 }
232
233 # Intercept the call to the DejaGnu version of dg-process-target to
234 # support use of an effective-target keyword in place of a list of
235 # target triplets to xfail or skip a test.
236 #
237 # selector is one of:
238 #    xfail target-triplet-1 ...
239 #    xfail effective-target-keyword
240 #    xfail selector-expression
241 #    target target-triplet-1 ...
242 #    target effective-target-keyword
243 #    target selector-expression
244 #
245 # For a target list the result is "S" if the target is selected, "N" otherwise.
246 # For an xfail list the result is "F" if the target is affected, "P" otherwise.
247 #
248 # A selector expression appears within curly braces and uses a single logical
249 # operator: !, &&, or ||.  An operand is another selector expression, an
250 # effective-target keyword, or a list of target triplets within quotes or
251 # curly braces.
252
253 if { [info procs saved-dg-process-target] == [list] } {
254     rename dg-process-target saved-dg-process-target
255
256     # Evaluate an operand within a selector expression.
257     proc selector_opd { op } {
258         set selector "target"
259         lappend selector $op
260         set answer [ expr { [dg-process-target $selector] == "S" } ]
261         verbose "selector_opd: `$op' $answer" 2
262         return $answer
263     }
264
265     # Evaluate a target triplet list within a selector expression.
266     # Unlike other operands, this needs to be expanded from a list to
267     # the same string as "target".
268     proc selector_list { op } {
269         set selector "target [join $op]"
270         set answer [ expr { [dg-process-target $selector] == "S" } ]
271         verbose "selector_list: `$op' $answer" 2
272         return $answer
273     }
274
275     # Evaluate a selector expression.
276     proc selector_expression { exp } {
277         if { [llength $exp] == 2 } {
278             if [string match "!" [lindex $exp 0]] {
279                 set op1 [lindex $exp 1]
280                 set answer [expr { ! [selector_opd $op1] }]
281             } else {
282                 # Assume it's a list of target triplets.
283                 set answer [selector_list $exp]
284             }
285         } elseif { [llength $exp] == 3 } {
286             set op1 [lindex $exp 0]
287             set opr [lindex $exp 1]
288             set op2 [lindex $exp 2]
289             if [string match "&&" $opr] {
290                 set answer [expr { [selector_opd $op1] && [selector_opd $op2] }]
291             } elseif [string match "||" $opr] {
292                 set answer [expr { [selector_opd $op1] || [selector_opd $op2] }]
293             } else {
294                 # Assume it's a list of target triplets.
295                 set answer [selector_list $exp]
296             }
297         } else {
298             # Assume it's a list of target triplets.
299             set answer [selector_list $exp]
300         }
301
302         verbose "selector_expression: `$exp' $answer" 2
303         return $answer
304     }
305
306     proc dg-process-target { args } {
307         verbose "replacement dg-process-target: `$args'" 2
308         
309         # Extract the 'what' keyword from the argument list.
310         set selector [string trim [lindex $args 0]]
311         if [regexp "^xfail " $selector] {
312             set what "xfail"
313         } elseif [regexp "^target " $selector] {
314             set what "target"
315         } else {
316             error "syntax error in target selector \"$selector\""
317         }
318
319         # Extract the rest of the list, which might be a keyword.
320         regsub "^${what}" $selector "" rest
321         set rest [string trim $rest]
322
323         if [is-effective-target-keyword $rest] {
324             # The selector is an effective target keyword.
325             if [is-effective-target $rest] {
326                 return [expr { $what == "xfail" ? "F" : "S" }]
327             } else {
328                 return [expr { $what == "xfail" ? "P" : "N" }]
329             }
330         }
331
332         if [string match "{*}" $rest] {
333             if [selector_expression [lindex $rest 0]] {
334                 return [expr { $what == "xfail" ? "F" : "S" }]
335             } else {
336                 return [expr { $what == "xfail" ? "P" : "N" }]
337             }
338         }
339
340         # The selector is not an effective-target keyword, so process
341         # the list of target triplets.
342         return [saved-dg-process-target $selector]
343     }
344 }