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