Commit | Line | Data |
---|---|---|
b3adc24a | 1 | # Copyright (C) 1993-2020 Free Software Foundation, Inc. |
252b5132 RH |
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 | |
ec2655a6 | 5 | # the Free Software Foundation; either version 3 of the License, or |
252b5132 | 6 | # (at your option) any later version. |
139e4a70 | 7 | # |
252b5132 RH |
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. | |
139e4a70 | 12 | # |
252b5132 RH |
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 | |
ec2655a6 NC |
15 | # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, |
16 | # MA 02110-1301, USA. | |
252b5132 RH |
17 | |
18 | # Please email any bugs, comments, and/or additions to this file to: | |
fc697c14 | 19 | # dejagnu@gnu.org |
252b5132 RH |
20 | |
21 | # This file was written by Ken Raeburn (raeburn@cygnus.com). | |
22 | ||
f3097f33 RS |
23 | proc load_common_lib { name } { |
24 | global srcdir | |
25 | load_file $srcdir/../../binutils/testsuite/lib/$name | |
26 | } | |
27 | ||
28 | load_common_lib binutils-common.exp | |
29 | ||
252b5132 RH |
30 | proc gas_version {} { |
31 | global AS | |
7f6a71ff JM |
32 | if [is_remote host] then { |
33 | remote_exec host "$AS -version < /dev/null" "" "" "gas.version" | |
34 | remote_exec host "which $AS" "" "" "gas.which" | |
35 | ||
36 | remote_upload host "gas.version" | |
37 | remote_upload host "gas.which" | |
38 | ||
39 | set which_as [file_contents "gas.which"] | |
40 | set tmp [file_contents "gas.version"] | |
41 | ||
42 | remote_file build delete "gas.version" | |
43 | remote_file build delete "gas.which" | |
44 | remote_file host delete "gas.version" | |
45 | remote_file host delete "gas.which" | |
46 | } else { | |
47 | set which_as [which $AS] | |
48 | catch "exec $AS -version < /dev/null" tmp | |
49 | } | |
50 | ||
252b5132 RH |
51 | # Should find a way to discard constant parts, keep whatever's |
52 | # left, so the version string could be almost anything at all... | |
53 | regexp "\[^\n\]* (cygnus-|)(\[-0-9.a-zA-Z-\]+)\[\r\n\].*" $tmp version cyg number | |
54 | if ![info exists number] then { | |
7f6a71ff | 55 | return "$which_as (no version number)\n" |
252b5132 | 56 | } |
7f6a71ff | 57 | clone_output "$which_as $number\n" |
252b5132 RH |
58 | unset version |
59 | } | |
60 | ||
7f6a71ff JM |
61 | proc gas_host_run { cmd redir } { |
62 | verbose "Executing $cmd $redir" | |
63 | set return_contents_of "" | |
64 | if [regexp ">& */dev/null" $redir] then { | |
65 | set output_file "" | |
66 | set command "$cmd $redir" | |
67 | } elseif [regexp "> */dev/null" $redir] then { | |
68 | set output_file "" | |
69 | set command "$cmd 2>gas.stderr" | |
70 | set return_contents_of "gas.stderr" | |
71 | } elseif [regexp ">&.*" $redir] then { | |
9396508d | 72 | # See PR 5322 for why the following line is used. |
65951855 | 73 | regsub ">&" $redir "" output_file |
7f6a71ff JM |
74 | set command "$cmd 2>&1" |
75 | } elseif [regexp "2>.*" $redir] then { | |
76 | set output_file "gas.out" | |
77 | set command "$cmd $redir" | |
78 | set return_contents_of "gas.out" | |
79 | } elseif [regexp ">.*" $redir] then { | |
80 | set output_file "" | |
81 | set command "$cmd $redir 2>gas.stderr" | |
82 | set return_contents_of "gas.stderr" | |
83 | } elseif { "$redir" == "" } then { | |
84 | set output_file "gas.out" | |
85 | set command "$cmd 2>&1" | |
86 | set return_contents_of "gas.out" | |
87 | } else { | |
88 | fail "gas_host_run: unknown form of redirection string" | |
89 | } | |
90 | ||
91 | set status [remote_exec host [concat sh -c [list $command]] "" "/dev/null" "$output_file"] | |
92 | set to_return "" | |
93 | if { "$return_contents_of" != "" } then { | |
94 | remote_upload host "$return_contents_of" | |
95 | set to_return [file_contents "$return_contents_of"] | |
96 | regsub "\n$" $to_return "" to_return | |
97 | } | |
98 | ||
99 | if { [lindex $status 0] == 0 && "$output_file" != "" | |
100 | && "$output_file" != "$return_contents_of" } then { | |
101 | remote_upload host "$output_file" | |
102 | } | |
103 | ||
104 | return [list [lindex $status 0] "$to_return"] | |
105 | } | |
106 | ||
252b5132 RH |
107 | proc gas_run { prog as_opts redir } { |
108 | global AS | |
109 | global ASFLAGS | |
110 | global comp_output | |
111 | global srcdir | |
112 | global subdir | |
113 | global host_triplet | |
114 | ||
7f6a71ff JM |
115 | set status [gas_host_run "$AS $ASFLAGS $as_opts $srcdir/$subdir/$prog" "$redir"] |
116 | set comp_output [lindex $status 1] | |
117 | if { [lindex $status 0] != 0 && [regexp "2>.*" $redir] } then { | |
118 | append comp_output "child process exited abnormally" | |
119 | } | |
252b5132 RH |
120 | set comp_output [prune_warnings $comp_output] |
121 | verbose "output was $comp_output" | |
c0b22597 | 122 | return [list $comp_output ""] |
252b5132 RH |
123 | } |
124 | ||
cea10409 L |
125 | proc gas_run_stdin { prog as_opts redir } { |
126 | global AS | |
127 | global ASFLAGS | |
128 | global comp_output | |
129 | global srcdir | |
130 | global subdir | |
131 | global host_triplet | |
132 | ||
133 | set status [gas_host_run "$AS $ASFLAGS $as_opts < $srcdir/$subdir/$prog" "$redir"] | |
134 | set comp_output [lindex $status 1] | |
135 | if { [lindex $status 0] != 0 && [regexp "2>.*" $redir] } then { | |
136 | append comp_output "child process exited abnormally" | |
137 | } | |
138 | set comp_output [prune_warnings $comp_output] | |
139 | verbose "output was $comp_output" | |
140 | return [list $comp_output ""] | |
141 | } | |
142 | ||
252b5132 RH |
143 | proc all_ones { args } { |
144 | foreach x $args { if [expr $x!=1] { return 0 } } | |
145 | return 1 | |
146 | } | |
147 | ||
412cc54e L |
148 | # ${tool}_finish (gas_finish) will be called by runtest.exp. But |
149 | # gas_finish should only be used with gas_start. We use gas_started | |
150 | # to tell gas_finish if gas_start has been called so that runtest.exp | |
151 | # can call gas_finish without closing the wrong fd. | |
152 | set gas_started 0 | |
153 | ||
252b5132 RH |
154 | proc gas_start { prog as_opts } { |
155 | global AS | |
156 | global ASFLAGS | |
157 | global srcdir | |
158 | global subdir | |
159 | global spawn_id | |
412cc54e L |
160 | global gas_started |
161 | ||
162 | set gas_started 1 | |
252b5132 | 163 | |
04248055 | 164 | verbose -log "Starting $AS $ASFLAGS $as_opts $prog" 2 |
7f6a71ff JM |
165 | set status [gas_host_run "$AS $ASFLAGS $as_opts $srcdir/$subdir/$prog" ">&gas.out"] |
166 | spawn -noecho -nottycopy cat gas.out | |
252b5132 RH |
167 | } |
168 | ||
169 | proc gas_finish { } { | |
170 | global spawn_id | |
412cc54e | 171 | global gas_started |
252b5132 | 172 | |
412cc54e L |
173 | if { $gas_started == 1 } { |
174 | catch "close" | |
175 | catch "wait" | |
176 | set gas_started 0 | |
177 | } | |
252b5132 RH |
178 | } |
179 | ||
180 | proc want_no_output { testname } { | |
181 | global comp_output | |
182 | ||
183 | if ![string match "" $comp_output] then { | |
184 | send_log "$comp_output\n" | |
185 | verbose "$comp_output" 3 | |
186 | } | |
187 | if [string match "" $comp_output] then { | |
188 | pass "$testname" | |
189 | return 1 | |
190 | } else { | |
191 | fail "$testname" | |
192 | return 0 | |
193 | } | |
194 | } | |
195 | ||
196 | proc gas_test_old { file as_opts testname } { | |
197 | gas_run $file $as_opts "" | |
198 | return [want_no_output $testname] | |
199 | } | |
200 | ||
201 | proc gas_test { file as_opts var_opts testname } { | |
202 | global comp_output | |
203 | ||
204 | set i 0 | |
205 | foreach word $var_opts { | |
206 | set ignore_stdout($i) [string match "*>" $word] | |
207 | set opt($i) [string trim $word {>}] | |
208 | incr i | |
209 | } | |
210 | set max [expr 1<<$i] | |
211 | for {set i 0} {[expr $i<$max]} {incr i} { | |
212 | set maybe_ignore_stdout "" | |
213 | set extra_opts "" | |
214 | for {set bit 0} {(1<<$bit)<$max} {incr bit} { | |
215 | set num [expr 1<<$bit] | |
216 | if [expr $i&$num] then { | |
217 | set extra_opts "$extra_opts $opt($bit)" | |
218 | if $ignore_stdout($bit) then { | |
219 | set maybe_ignore_stdout ">/dev/null" | |
220 | } | |
221 | } | |
222 | } | |
223 | set extra_opts [string trim $extra_opts] | |
224 | gas_run $file "$as_opts $extra_opts" $maybe_ignore_stdout | |
225 | ||
226 | # Should I be able to use a conditional expression here? | |
227 | if [string match "" $extra_opts] then { | |
228 | want_no_output $testname | |
229 | } else { | |
230 | want_no_output "$testname ($extra_opts)" | |
231 | } | |
232 | } | |
233 | if [info exists errorInfo] then { | |
234 | unset errorInfo | |
235 | } | |
236 | } | |
237 | ||
238 | proc gas_test_ignore_stdout { file as_opts testname } { | |
239 | global comp_output | |
240 | ||
241 | gas_run $file $as_opts ">/dev/null" | |
242 | want_no_output $testname | |
243 | } | |
244 | ||
245 | proc gas_test_error { file as_opts testname } { | |
246 | global comp_output | |
247 | ||
248 | gas_run $file $as_opts ">/dev/null" | |
943fef64 MR |
249 | send_log "$comp_output\n" |
250 | verbose "$comp_output" 3 | |
251 | if { ![string match "" $comp_output] | |
252 | && ![string match "*Assertion failure*" $comp_output] | |
253 | && ![string match "*Internal error*" $comp_output] } then { | |
252b5132 | 254 | pass "$testname" |
943fef64 MR |
255 | } else { |
256 | fail "$testname" | |
252b5132 RH |
257 | } |
258 | } | |
259 | ||
260 | proc gas_exit {} {} | |
261 | ||
262 | proc gas_init { args } { | |
263 | global target_cpu | |
264 | global target_cpu_family | |
265 | global target_family | |
266 | global target_vendor | |
267 | global target_os | |
268 | global stdoptlist | |
269 | ||
e3696f67 | 270 | switch -glob "$target_cpu" { |
252b5132 | 271 | "m68???" { set target_cpu_family m68k } |
80c7c40a | 272 | "i[3-7]86" { set target_cpu_family i386 } |
252b5132 RH |
273 | default { set target_cpu_family $target_cpu } |
274 | } | |
275 | ||
276 | set target_family "$target_cpu_family-$target_vendor-$target_os" | |
277 | set stdoptlist "-a>" | |
278 | ||
279 | if ![istarget "*-*-*"] { | |
280 | perror "Target name [istarget] is not a triple." | |
281 | } | |
282 | # Need to return an empty string. | |
283 | return | |
284 | } | |
285 | ||
9a5c4b9e PB |
286 | # run_dump_tests TESTCASES EXTRA_OPTIONS |
287 | # Wrapper for run_dump_test, which is suitable for invoking as | |
288 | # run_dump_tests [lsort [glob -nocomplain $srcdir/$subdir/*.d]] | |
289 | # EXTRA_OPTIONS are passed down to run_dump_test. Honors runtest_file_p. | |
290 | # Body cribbed from dg-runtest. | |
291 | ||
292 | proc run_dump_tests { testcases {extra_options {}} } { | |
293 | global runtests | |
294 | ||
295 | foreach testcase $testcases { | |
296 | # If testing specific files and this isn't one of them, skip it. | |
297 | if ![runtest_file_p $runtests $testcase] { | |
298 | continue | |
299 | } | |
300 | run_dump_test [file rootname [file tail $testcase]] $extra_options | |
301 | } | |
302 | } | |
303 | ||
252b5132 RH |
304 | proc objdump { opts } { |
305 | global OBJDUMP | |
306 | global comp_output | |
307 | global host_triplet | |
308 | ||
7f6a71ff JM |
309 | set status [gas_host_run "$OBJDUMP $opts" ""] |
310 | set comp_output [prune_warnings [lindex $status 1]] | |
252b5132 RH |
311 | verbose "objdump output=$comp_output\n" 3 |
312 | } | |
313 | ||
314 | proc objdump_start_no_subdir { prog opts } { | |
315 | global OBJDUMP | |
316 | global srcdir | |
317 | global spawn_id | |
318 | ||
319 | verbose "Starting $OBJDUMP $opts $prog" 2 | |
7f6a71ff JM |
320 | set status [gas_host_run "$OBJDUMP $opts $prog" ">&gas.out"] |
321 | spawn -noecho -nottycopy cat gas.out | |
252b5132 RH |
322 | } |
323 | ||
324 | proc objdump_finish { } { | |
325 | global spawn_id | |
326 | ||
327 | catch "close" | |
328 | catch "wait" | |
329 | } | |
330 | ||
331 | # Default timeout is 10 seconds, loses on a slow machine. But some | |
332 | # configurations of dejagnu may override it. | |
333 | if {$timeout<120} then { set timeout 120 } | |
334 | ||
335 | expect_after -i { | |
336 | timeout { perror "timeout" } | |
337 | "virtual memory exhausted" { perror "virtual memory exhausted" } | |
338 | buffer_full { perror "buffer full" } | |
339 | eof { perror "eof" } | |
340 | } | |
341 | ||
252b5132 RH |
342 | proc file_contents { filename } { |
343 | set file [open $filename r] | |
344 | set contents [read $file] | |
345 | close $file | |
346 | return $contents | |
347 | } | |
348 | ||
ff970196 CD |
349 | proc write_file { filename contents } { |
350 | set file [open $filename w] | |
351 | puts $file "$contents" | |
352 | close $file | |
353 | } | |
354 | ||
252b5132 RH |
355 | proc verbose_eval { expr { level 1 } } { |
356 | global verbose | |
357 | if $verbose>$level then { eval verbose "$expr" $level } | |
358 | } | |
359 | ||
360 | # This definition is taken from an unreleased version of DejaGnu. Once | |
361 | # that version gets released, and has been out in the world for a few | |
362 | # months at least, it may be safe to delete this copy. | |
363 | if ![string length [info proc prune_warnings]] { | |
364 | # | |
365 | # prune_warnings -- delete various system verbosities from TEXT. | |
366 | # | |
367 | # An example is: | |
368 | # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9 | |
369 | # | |
370 | # Sites with particular verbose os's may wish to override this in site.exp. | |
371 | # | |
372 | proc prune_warnings { text } { | |
373 | # This is from sun4's. Do it for all machines for now. | |
374 | # The "\\1" is to try to preserve a "\n" but only if necessary. | |
375 | regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text | |
376 | ||
377 | # It might be tempting to get carried away and delete blank lines, etc. | |
378 | # Just delete *exactly* what we're ask to, and that's it. | |
379 | return $text | |
380 | } | |
381 | } | |
dfeb0666 | 382 | |
dc89df6a | 383 | # run_list_test NAME (optional): OPTS TESTNAME |
dfeb0666 | 384 | # |
6dfe79a3 NC |
385 | # Assemble the file "NAME.s" with command line options OPTS and |
386 | # compare the assembler standard error output against the regular | |
dfeb0666 NC |
387 | # expressions given in the file "NAME.l". If TESTNAME is provided, |
388 | # it will be used as the name of the test. | |
389 | ||
dc89df6a | 390 | proc run_list_test { name {opts {}} {testname {}} } { |
dfeb0666 NC |
391 | global srcdir subdir |
392 | if { [string length $testname] == 0 } then { | |
393 | set testname "[file tail $subdir] $name" | |
394 | } | |
395 | set file $srcdir/$subdir/$name | |
396 | gas_run ${name}.s $opts ">&dump.out" | |
eb22018c | 397 | if { [regexp_diff "dump.out" "${file}.l"] } then { |
dfeb0666 NC |
398 | fail $testname |
399 | verbose "output is [file_contents "dump.out"]" 2 | |
400 | return | |
401 | } | |
402 | pass $testname | |
403 | } | |
cea10409 L |
404 | |
405 | # run_list_test_stdin NAME (optional): OPTS TESTNAME | |
406 | # | |
407 | # Similar to run_list_test, but use stdin as input. | |
408 | ||
409 | proc run_list_test_stdin { name {opts {}} {testname {}} } { | |
410 | global srcdir subdir | |
411 | if { [string length $testname] == 0 } then { | |
412 | set testname "[file tail $subdir] $name" | |
413 | } | |
414 | set file $srcdir/$subdir/$name | |
415 | gas_run_stdin ${name}.s $opts ">&dump.out" | |
eb22018c | 416 | if { [regexp_diff "dump.out" "${file}.l"] } then { |
cea10409 L |
417 | fail $testname |
418 | verbose "output is [file_contents "dump.out"]" 2 | |
419 | return | |
420 | } | |
421 | pass $testname | |
422 | } |