@@ -24,6 +24,183 @@ load_lib libgloss.exp
24
24
load_gcc_lib target-libpath.exp
25
25
load_gcc_lib wrapper.exp
26
26
27<
8000
/code>
+ proc check_effective_target_gccbug { } {
28
+ global has_gccbug
29
+ return $has_gccbug
30
+ }
31
+
32
+ # Return 1 if the target matches the effective target 'arg', 0 otherwise.
33
+ # This can be used with any check_* proc that takes no argument and
34
+ # returns only 1 or 0. It could be used with check_* procs that take
35
+ # arguments with keywords that pass particular arguments.
36
+
37
+ proc is-effective-target { arg } {
38
+ global et_index
39
+ set selected 0
40
+ if { ![info exists et_index] } {
41
+ # Initialize the effective target index that is used in some
42
+ # check_effective_target_* procs.
43
+ set et_index 0
44
+ }
45
+ if { [info procs check_effective_target_${arg}] != [list] } {
46
+ set selected [check_effective_target_${arg}]
47
+ } else {
48
+ error "unknown effective target keyword `$arg'"
49
+ }
50
+ verbose "is-effective-target: $arg $selected" 2
51
+ return $selected
52
+ }
53
+
54
+ proc is-effective-target-keyword { arg } {
55
+ if { [info procs check_effective_target_${arg}] != [list] } {
56
+ return 1
57
+ } else {
58
+ return 0
59
+ }
60
+ }
61
+
62
+ # Intercept the call to the DejaGnu version of dg-process-target to
63
+ # support use of an effective-target keyword in place of a list of
64
+ # target triplets to xfail or skip a test.
65
+ #
66
+ # The argument to dg-process-target is the keyword "target" or "xfail"
67
+ # followed by a selector:
68
+ # target-triplet-1 ...
69
+ # effective-target-keyword
70
+ # selector-expression
71
+ #
72
+ # For a target list the result is "S" if the target is selected, "N" otherwise.
73
+ # For an xfail list the result is "F" if the target is affected, "P" otherwise.
74
+
75
+ # In contexts that allow either "target" or "xfail" the argument can be
76
+ # target selector1 xfail selector2
77
+ # which returns "N" if selector1 is not selected, otherwise the result of
78
+ # "xfail selector2".
79
+ #
80
+ # A selector expression appears within curly braces and uses a single logical
81
+ # operator: !, &&, or ||. An operand is another selector expression, an
82
+ # effective-target keyword, or a list of target triplets within quotes or
83
+ # curly braces.
84
+
85
+ if { [info procs saved-dg-process-target] == [list] } {
86
+ rename dg-process-target saved-dg-process-target
87
+
88
+ # Evaluate an operand within a selector expression.
89
+ proc selector_opd { op } {
90
+ set selector "target"
91
+ lappend selector $op
92
+ set answer [ expr { [dg-process-target $selector] == "S" } ]
93
+ verbose "selector_opd: `$op' $answer" 2
94
+ return $answer
95
+ }
96
+
97
+ # Evaluate a target triplet list within a selector expression.
98
+ # Unlike other operands, this needs to be expanded from a list to
99
+ # the same string as "target".
100
+ proc selector_list { op } {
101
+ set selector "target [join $op]"
102
+ set answer [ expr { [dg-process-target $selector] == "S" } ]
103
+ verbose "selector_list: `$op' $answer" 2
104
+ return $answer
105
+ }
106
+
107
+ # Evaluate a selector expression.
108
+ proc selector_expression { exp } {
109
+ if { [llength $exp] == 2 } {
110
+ if [string match "!" [lindex $exp 0]] {
111
+ set op1 [lindex $exp 1]
112
+ set answer [expr { ! [selector_opd $op1] }]
113
+ } else {
114
+ # Assume it's a list of target triplets.
115
+ set answer [selector_list $exp]
116
+ }
117
+ } elseif { [llength $exp] == 3 } {
118
+ set op1 [lindex $exp 0]
119
+ set opr [lindex $exp 1]
120
+ set op2 [lindex $exp 2]
121
+ if [string match "&&" $opr] {
122
+ set answer [expr { [selector_opd $op1] && [selector_opd $op2] }]
123
+ } elseif [string match "||" $opr] {
124
+ set answer [expr { [selector_opd $op1] || [selector_opd $op2] }]
125
+ } else {
126
+ # Assume it's a list of target triplets.
127
+ set answer [selector_list $exp]
128
+ }
129
+ } else {
130
+ # Assume it's a list of target triplets.
131
+ set answer [selector_list $exp]
132
+ }
133
+
134
+ verbose "selector_expression: `$exp' $answer" 2
135
+ return $answer
136
+ }
137
+
138
+ # Evaluate "target selector" or "xfail selector".
139
+
140
+ proc dg-process-target-1 { args } {
141
+ verbose "dg-process-target-1: `$args'" 2
142
+
143
+ # Extract the 'what' keyword from the argument list.
144
+ set selector [string trim [lindex $args 0]]
145
+ if [regexp "^xfail " $selector] {
146
+ set what "xfail"
147
+ } elseif [regexp "^target " $selector] {
148
+ set what "target"
149
+ } else {
150
+ error "syntax error in target selector \"$selector\""
151
+ }
152
+
153
+ # Extract the rest of the list, which might be a keyword.
154
+ regsub "^${what}" $selector "" rest
155
+ set rest [string trim $rest]
156
+
157
+ if [is-effective-target-keyword $rest] {
158
+ # The selector is an effective target keyword.
159
+ if [is-effective-target $rest] {
160
+ return [expr { $what == "xfail" ? "F" : "S" }]
161
+ } else {
162
+ return [expr { $what == "xfail" ? "P" : "N" }]
163
+ }
164
+ }
165
+
166
+ if [string match "{*}" $rest] {
167
+ if [selector_expression [lindex $rest 0]] {
168
+ return [expr { $what == "xfail" ? "F" : "S" }]
169
+ } else {
170
+ return [expr { $what == "xfail" ? "P" : "N" }]
171
+ }
172
+ }
173
+
174
+ # The selector is not an effective-target keyword, so process
175
+ # the list of target triplets.
176
+ return [saved-dg-process-target $selector]
177
+ }
178
+
179
+ # Intercept calls to the DejaGnu function. In addition to
180
+ # processing "target selector" or "xfail selector", handle
181
+ # "target selector1 xfail selector2".
182
+
183
+ proc dg-process-target { args } {
184
+ verbose "replacement dg-process-target: `$args'" 2
185
+
186
+ set selector [string trim [lindex $args 0]]
187
+
188
+ # If the argument list contains both 'target' and 'xfail',
189
+ # process 'target' and, if that succeeds, process 'xfail'.
190
+ if [regexp "^target .* xfail .*" $selector] {
191
+ set xfail_index [string first "xfail" $selector]
192
+ set xfail_selector [string range $selector $xfail_index end]
193
+ set target_selector [string range $selector 0 [expr $xfail_index-1]]
194
+ set target_selector [string trim $target_selector]
195
+ if { [dg-process-target-1 $target_selector] == "N" } {
196
+ return "N"
197
+ }
198
+ return [dg-process-target-1 $xfail_selector]
199
+
200
+ }
201
+ return [dg-process-target-1 $selector]
202
+ }
203
+ }
27
204
28
205
# Define libffi callbacks for dg.exp.
29
206
@@ -299,6 +476,7 @@ proc libffi-dg-runtest { testcases default-extra-flags } {
299
476
300
477
proc run-many-tests { testcases extra_flags } {
301
478
global compiler_vendor
479
+ global has_gccbug
302
480
switch $compiler_vendor {
303
481
"clang" {
304
482
set common "-W -Wall"
@@ -329,7 +507,7 @@ proc run-many-tests { testcases extra_flags } {
329
507
&& !defined __i386__"] } {
330
508
set targetabis {
331
509
""
332
- "-DABI_NUM=FFI_WIN64 -DABI_ATTR=__MSABI__"
510
+ "-DABI_NUM=FFI_GNUW64 -DABI_ATTR=__MSABI__"
333
511
}
334
512
}
335
513
}
@@ -345,6 +523,17 @@ proc run-many-tests { testcases extra_flags } {
345
523
foreach opt $optimizations {
346
524
foreach abi $abis {
347
525
set options [concat $common $opt $abi]
526
+ set has_gccbug false;
527
+ if { [string match $compiler_vendor "gnu"] \
528
+ && [string match "*MSABI*" $abi] \
529
+ && ( ( [string match "*DGTEST=57 *" $common] \
530
+ && [string match "*call.c*" $testname] ) \
531
+ || ( [string match "*DGTEST=54 *" $common] \
532
+ && [string match "*callback*" $testname] ) \
533
+ || [string match "*DGTEST=55 *" $common] \
534
+ || [string match "*DGTEST=56 *" $common] ) } then {
535
+ set has_gccbug true;
536
+ }
348
537
verbose "Testing $testname, $options" 1
349
538
dg-test $test $options ""
350
539
}
0 commit comments