gas/testsuite/lib/gas-defs.exp

   1 # Copyright (C) 1993-2018 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 3 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,
  16 # MA 02110-1301, USA.
  17
  18 # Please email any bugs, comments, and/or additions to this file to:
  19 # dejagnu@gnu.org
  20
  21 # This file was written by Ken Raeburn (raeburn@cygnus.com).
  22
  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
  30 proc gas_version {} {
  31     global AS
  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
  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 {
  55         return "$which_as (no version number)\n"
  56     }
  57     clone_output "$which_as $number\n"
  58     unset version
  59 }
  60
  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 {
  72         # See PR 5322 for why the following line is used.
  73         regsub ">&" $redir "" output_file
  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
 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
 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     }
 120     set comp_output [prune_warnings $comp_output]
 121     verbose "output was $comp_output"
 122     return [list $comp_output ""]
 123 }
 124
 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
 143 proc all_ones { args } {
 144     foreach x $args { if [expr $x!=1] { return 0 } }
 145     return 1
 146 }
 147
 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
 154 proc gas_start { prog as_opts } {
 155     global AS
 156     global ASFLAGS
 157     global srcdir
 158     global subdir
 159     global spawn_id
 160     global gas_started
 161
 162     set gas_started 1
 163
 164     verbose -log "Starting $AS $ASFLAGS $as_opts $prog" 2
 165     set status [gas_host_run "$AS $ASFLAGS $as_opts $srcdir/$subdir/$prog" ">&gas.out"]
 166     spawn -noecho -nottycopy cat gas.out
 167 }
 168
 169 proc gas_finish { } {
 170     global spawn_id
 171     global gas_started
 172
 173     if { $gas_started == 1 } {
 174         catch "close"
 175         catch "wait"
 176         set gas_started 0
 177     }
 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"
 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 {
 254         pass "$testname"
 255     } else {
 256         fail "$testname"
 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
 270     case "$target_cpu" in {
 271         "m68???"                { set target_cpu_family m68k }
 272         "i[3-7]86"              { set target_cpu_family i386 }
 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
 286 # Internal procedure: return the names of the standard sections
 287 #
 288 proc get_standard_section_names {} {
 289     if [istarget "rx-*-*"] {
 290         return { "P" "D_1" "B_1" }
 291     }
 292     if [istarget "alpha*-*-*vms*"] {
 293         # Double quote: for TCL and for sh.
 294         return { "\\\$CODE\\\$" "\\\$DATA\\\$" "\\\$BSS\\\$" }
 295     }
 296     return
 297 }
 298
 299 # run_dump_tests TESTCASES EXTRA_OPTIONS
 300 # Wrapper for run_dump_test, which is suitable for invoking as
 301 #   run_dump_tests [lsort [glob -nocomplain $srcdir/$subdir/*.d]]
 302 # EXTRA_OPTIONS are passed down to run_dump_test.  Honors runtest_file_p.
 303 # Body cribbed from dg-runtest.
 304
 305 proc run_dump_tests { testcases {extra_options {}} } {
 306     global runtests
 307
 308     foreach testcase $testcases {
 309         # If testing specific files and this isn't one of them, skip it.
 310         if ![runtest_file_p $runtests $testcase] {
 311             continue
 312         }
 313         run_dump_test [file rootname [file tail $testcase]] $extra_options
 314     }
 315 }
 316
 317
 318 # run_dump_test FILE (optional:) EXTRA_OPTIONS
 319 #
 320 # Assemble a .s file, then run some utility on it and check the output.
 321 #
 322 # There should be an assembly language file named FILE.s in the test
 323 # suite directory, and a pattern file called FILE.d.  `run_dump_test'
 324 # will assemble FILE.s, run some tool like `objdump', `objcopy', or
 325 # `nm' on the .o file to produce textual output, and then analyze that
 326 # with regexps.  The FILE.d file specifies what program to run, and
 327 # what to expect in its output.
 328 #
 329 # The FILE.d file begins with zero or more option lines, which specify
 330 # flags to pass to the assembler, the program to run to dump the
 331 # assembler's output, and the options it wants.  The option lines have
 332 # the syntax:
 333 #
 334 #         # OPTION: VALUE
 335 #
 336 # OPTION is the name of some option, like "name" or "objdump", and
 337 # VALUE is OPTION's value.  The valid options are described below.
 338 # Whitespace is ignored everywhere, except within VALUE.  The option
 339 # list ends with the first line that doesn't match the above syntax.
 340 # However, a line within the options that begins with a #, but doesn't
 341 # have a recognizable option name followed by a colon, is considered a
 342 # comment and entirely ignored.
 343 #
 344 # The optional EXTRA_OPTIONS argument to `run_dump_test' is a list of
 345 # two-element lists.  The first element of each is an option name, and
 346 # the second additional arguments to be added on to the end of the
 347 # option list as given in FILE.d.  (If omitted, no additional options
 348 # are added.)
 349 #
 350 # The interesting options are:
 351 #
 352 #   name: TEST-NAME
 353 #       The name of this test, passed to DejaGNU's `pass' and `fail'
 354 #       commands.  If omitted, this defaults to FILE, the root of the
 355 #       .s and .d files' names.
 356 #
 357 #   as: FLAGS
 358 #       When assembling FILE.s, pass FLAGS to the assembler.
 359 #
 360 #   addr2line: FLAGS
 361 #   nm: FLAGS
 362 #   objdump: FLAGS
 363 #   readelf: FLAGS
 364 #       Use the specified program to analyze the .o file, and pass it
 365 #       FLAGS, in addition to the .o file name.  Note that they are run
 366 #       with LC_ALL=C in the environment to give consistent sorting
 367 #       of symbols.  If no FLAGS are needed then use:
 368 #        PROG: [nm objdump readelf addr2line]
 369 #       instead.
 370 #       Note: for objdump, we automatically replaces the standard section
 371 #       names (.text, .data and .bss) by target ones if any (eg. rx-elf
 372 #       uses "P" instead of .text).  The substition is done for both
 373 #       the objdump options (eg: "-j .text" is replaced by "-j P") and the
 374 #       reference file.
 375 #
 376 #   source: SOURCE
 377 #       Assemble the file SOURCE.s.  If omitted, this defaults to FILE.s.
 378 #       This is useful if several .d files want to share a .s file.
 379 #
 380 #   dump: DUMP
 381 #       Match against DUMP.d.  If omitted, this defaults to FILE.d.  This
 382 #       is useful if several .d files differ by options only.  Options are
 383 #       always read from FILE.d.
 384 #
 385 #   target: GLOB|PROC ...
 386 #       Run this test only on a specified list of targets.  More precisely,
 387 #       in the space-separated list each glob is passed to "istarget" and
 388 #       each proc is called as a TCL procedure.  List items are interpreted
 389 #       such that procs are denoted by surrounding square brackets, and any
 390 #       other items are consired globs.  If the call evaluates true for any
 391 #       of them, the test will be run, otherwise it will be marked
 392 #       unsupported.
 393 #
 394 #   notarget: GLOB|PROC ...
 395 #       Do not run this test on a specified list of targets.  Again, each
 396 #       glob in the space-separated list is passed to "istarget" and each
 397 #       proc is called as a TCL procedure, and the test is run if it
 398 #       evaluates *false* for *all* of them.  Otherwise it will be marked
 399 #       unsupported.
 400 #
 401 #   skip: GLOB|PROC ...
 402 #   noskip: GLOB|PROC ...
 403 #       These are exactly the same as "notarget" and "target",
 404 #       respectively, except that they do nothing at all if the check
 405 #       fails.  They should only be used in groups, to construct a single
 406 #       test which is run on all targets but with variant options or
 407 #       expected output on some targets.  (For example, see
 408 #       gas/arm/inst.d and gas/arm/wince_inst.d.)
 409 #
 410 #   xfail: GLOB|PROC ...
 411 #       Run this test and it is is expected to fail on a specified list
 412 #       of targets.
 413 #
 414 #   error: REGEX
 415 #       An error with message matching REGEX must be emitted for the test
 416 #       to pass.  The PROG, addr2line, nm, objdump, and readelf options
 417 #       have no meaning and need not supplied if this is present.
 418 #
 419 #   warning: REGEX
 420 #       Expect a gas warning matching REGEX.  It is an error to issue
 421 #       both "error" and "warning".
 422 #
 423 #   stderr: FILE
 424 #       FILE contains regexp lines to be matched against the diagnostic
 425 #       output of the assembler.  This does not preclude the use of
 426 #       PROG, addr2line, nm, objdump, or readelf.
 427 #
 428 #   error-output: FILE
 429 #       Means the same as 'stderr', but also indicates that the assembler
 430 #       is expected to exit unsuccessfully (therefore PROG, addr2line, nm,
 431 #       objdump, and readelf have no meaning and should not be supplied).
 432 #
 433 #   section-subst: no
 434 #       Means that the section substitution for objdump is disabled.
 435 #
 436 # Each option may occur at most once.
 437 #
 438 # After the option lines come regexp lines.  `run_dump_test' calls
 439 # `regexp_diff' to compare the output of the dumping tool against the
 440 # regexps in FILE.d.  `regexp_diff' is defined in binutils-common.exp;
 441 # see further comments there.
 442
 443 proc run_dump_test { name {extra_options {}} } {
 444     global subdir srcdir
 445     global OBJDUMP NM AS OBJCOPY READELF
 446     global OBJDUMPFLAGS NMFLAGS ASFLAGS OBJCOPYFLAGS READELFFLAGS
 447     global ADDR2LINE ADDR2LINEFLAGS
 448     global host_triplet
 449     global env
 450
 451     if [string match "*/*" $name] {
 452         set file $name
 453         set name [file tail $name]
 454     } else {
 455         set file "$srcdir/$subdir/$name"
 456     }
 457     set opt_array [slurp_options "${file}.d"]
 458     if { $opt_array == -1 } {
 459         perror "error reading options from $file.d"
 460         unresolved $subdir/$name
 461         return
 462     }
 463     set opts(addr2line) {}
 464     set opts(as) {}
 465     set opts(objdump) {}
 466     set opts(nm) {}
 467     set opts(readelf) {}
 468     set opts(name) {}
 469     set opts(PROG) {}
 470     set opts(source) {}
 471     set opts(dump) {}
 472     set opts(stderr) {}
 473     set opts(error) {}
 474     set opts(error-output) {}
 475     set opts(warning) {}
 476     set opts(target) {}
 477     set opts(notarget) {}
 478     set opts(skip) {}
 479     set opts(noskip) {}
 480     set opts(xfail) {}
 481     set opts(section-subst) {}
 482
 483     foreach i $opt_array {
 484         set opt_name [lindex $i 0]
 485         set opt_val [lindex $i 1]
 486         if ![info exists opts($opt_name)] {
 487             perror "unknown option $opt_name in file $file.d"
 488             unresolved $subdir/$name
 489             return
 490         }
 491         if [string length $opts($opt_name)] {
 492             perror "option $opt_name multiply set in $file.d"
 493             unresolved $subdir/$name
 494             return
 495         }
 496         if { $opt_name == "as" } {
 497             set opt_val [subst $opt_val]
 498         }
 499         set opts($opt_name) $opt_val
 500     }
 501
 502     foreach i $extra_options {
 503         set opt_name [lindex $i 0]
 504         set opt_val [lindex $i 1]
 505         if ![info exists opts($opt_name)] {
 506             perror "unknown option $opt_name given in extra_opts"
 507             unresolved $subdir/$name
 508             return
 509         }
 510         # add extra option to end of existing option, adding space
 511         # if necessary.
 512         if [string length $opts($opt_name)] {
 513             append opts($opt_name) " "
 514         }
 515         append opts($opt_name) $opt_val
 516     }
 517
 518     if { $opts(name) == "" } {
 519         set testname "$subdir/$name"
 520     } else {
 521         set testname $opts(name)
 522     }
 523     verbose "Testing $testname"
 524
 525     if { (($opts(warning) != "") && ($opts(error) != "")) \
 526          || (($opts(warning) != "") && ($opts(stderr) != "")) \
 527          || (($opts(error-output) != "") && ($opts(stderr) != "")) \
 528          || (($opts(error-output) != "") && ($opts(error) != "")) \
 529          || (($opts(error-output) != "") && ($opts(warning) != "")) } {
 530         perror "$testname: bad mix of stderr, error-output, error, and warning test-directives"
 531         unresolved $testname
 532         return
 533     }
 534     if { $opts(error-output) != "" } then {
 535         set opts(stderr) $opts(error-output)
 536     }
 537
 538     set program ""
 539     # It's meaningless to require an output-testing method when we
 540     # expect an error.
 541     if { $opts(error) == "" && $opts(error-output) == "" } {
 542         if {$opts(PROG) != ""} {
 543             switch -- $opts(PROG) {
 544                 addr2line { set program addr2line }
 545                 objdump { set program objdump }
 546                 nm      { set program nm }
 547                 readelf { set program readelf }
 548                 default {
 549                     perror "unrecognized program option $opts(PROG) in $file.d"
 550                     unresolved $testname
 551                     return }
 552             }
 553         } else {
 554             # Guess which program to run, by seeing which option was specified.
 555             foreach p {objdump nm readelf addr2line} {
 556                 if {$opts($p) != ""} {
 557                     if {$program != ""} {
 558                         perror "ambiguous dump program in $file.d"
 559                         unresolved $testname
 560                         return
 561                     } else {
 562                         set program $p
 563                     }
 564                 }
 565             }
 566         }
 567         if { $program == "" && $opts(warning) == "" } {
 568             perror "dump program unspecified in $file.d"
 569             unresolved $testname
 570             return
 571         }
 572     }
 573
 574     # Handle skipping the test on specified targets.
 575     # You can have both skip/noskip and target/notarget, but you can't
 576     # have both skip and noskip, or target and notarget, in the same file.
 577     if { $opts(skip) != "" } then {
 578         if { $opts(noskip) != "" } then {
 579             perror "$testname: mixing skip and noskip directives is invalid"
 580             unresolved $testname
 581             return
 582         }
 583         foreach glob $opts(skip) {
 584             if {[match_target $glob]} { return }
 585         }
 586     }
 587     if { $opts(noskip) != "" } then {
 588         set skip 1
 589         foreach glob $opts(noskip) {
 590             if {[match_target $glob]} {
 591                 set skip 0
 592                 break
 593             }
 594         }
 595         if {$skip} { return }
 596     }
 597     if { $opts(target) != "" } then {
 598         if { $opts(notarget) != "" } then {
 599             perror "$testname: mixing target and notarget directives is invalid"
 600             unresolved $testname
 601             return
 602         }
 603         set skip 1
 604         foreach glob $opts(target) {
 605             if {[match_target $glob]} {
 606                 set skip 0
 607                 break
 608             }
 609         }
 610         if {$skip} {
 611             unsupported $testname
 612             return
 613         }
 614     }
 615     if { $opts(notarget) != "" } then {
 616         foreach glob $opts(notarget) {
 617             if {[match_target $glob]} {
 618                 unsupported $testname
 619                 return
 620             }
 621         }
 622     }
 623
 624     # Setup xfailures.
 625     foreach targ $opts(xfail) {
 626         setup_xfail $targ
 627     }
 628
 629     if { $opts(source) == "" } {
 630         set sourcefile ${file}.s
 631     } else {
 632         set sourcefile $srcdir/$subdir/$opts(source)
 633     }
 634
 635     if { $opts(dump) == "" } {
 636         set dumpfile ${file}.d
 637     } else {
 638         set dumpfile $srcdir/$subdir/$opts(dump)
 639     }
 640
 641     set cmd "$AS $ASFLAGS $opts(as) -o dump.o $sourcefile"
 642     send_log "$cmd\n"
 643     set status [gas_host_run $cmd ""]
 644     set cmdret [lindex $status 0]
 645     set comp_output [prune_warnings [lindex $status 1]]
 646
 647     set expmsg $opts(error)
 648     if { $opts(warning) != "" } {
 649         set expmsg $opts(warning)
 650     }
 651     if { $cmdret != 0 || $comp_output != "" || $expmsg != "" } then {
 652         # If the executed program writes to stderr and stderr is not
 653         # redirected, exec *always* returns failure, regardless of the
 654         # program exit code.  Thankfully, we can retrieve the true
 655         # return status from a special variable.  Redirection would
 656         # cause a tcl-specific message to be appended, and we'd rather
 657         # not deal with that if we can help it.
 658         global errorCode
 659         if { $cmdret != 0 && [lindex $errorCode 0] == "NONE" } {
 660             set cmdret 0
 661         }
 662
 663         set exitstat "succeeded"
 664         if { $cmdret != 0 } { set exitstat "failed" }
 665
 666         send_log "$comp_output\n"
 667         verbose "$comp_output" 3
 668         if { $opts(stderr) == "" }  then {
 669             if { [regexp $expmsg $comp_output] \
 670                     && (($cmdret == 0) == ($opts(warning) != "")) } {
 671                 # We have the expected output from gas.
 672                 # Return if there's nothing more to do.
 673                 if { $opts(error) != "" || $program == "" } {
 674                     pass $testname
 675                     return
 676                 }
 677             } else {
 678                 verbose -log "$exitstat with: <$comp_output>, expected: <$expmsg>"
 679
 680                 fail $testname
 681                 return
 682             }
 683         } else {
 684             catch {write_file dump.stderr "$comp_output"} write_output
 685             if ![string match "" $write_output] then {
 686                 send_log "error writing dump.stderr: $write_output\n"
 687                 verbose "error writing dump.stderr: $write_output" 3
 688                 send_log "$comp_output\n"
 689                 verbose "$comp_output" 3
 690                 fail $testname
 691                 return
 692             }
 693             set stderrfile $srcdir/$subdir/$opts(stderr)
 694             verbose "wrote pruned stderr to dump.stderr" 3
 695             if { [regexp_diff "dump.stderr" "$stderrfile"] } then {
 696                 if { $opts(error) != "" } {
 697                     verbose -log "$exitstat with: <$comp_output>, expected: <$opts(error)>"
 698                     if [regexp $opts(error) $comp_output] {
 699                         pass $testname
 700                         return
 701                     }
 702                 }
 703                 fail $testname
 704                 verbose "pruned stderr is [file_contents "dump.stderr"]" 2
 705                 return
 706             } elseif { $opts(error-output) != "" } then {
 707                 pass $testname
 708                 return
 709             }
 710         }
 711     } else {
 712         if { $opts(error) != "" || $opts(error-output) != "" } {
 713             fail $testname
 714         }
 715     }
 716
 717     if { $program == "" } {
 718         return
 719     }
 720     set progopts1 $opts($program)
 721     eval set progopts \$[string toupper $program]FLAGS
 722     eval set binary \$[string toupper $program]
 723
 724     if { ![is_remote host] && [which $binary] == 0 } {
 725         untested $testname
 726         return
 727     }
 728
 729     # For objdump, automatically translate standard section names to the targets one,
 730     # if they are different.
 731     set sect_names [get_standard_section_names]
 732     if { $sect_names != "" && $program == "objdump" && $opts(section-subst) == ""} {
 733         regsub -- "-j \\.text" $progopts1 "-j [lindex $sect_names 0]" progopts1
 734         regsub -- "-j \\.data" $progopts1 "-j [lindex $sect_names 1]" progopts1
 735         regsub -- "-j \\.bss"  $progopts1 "-j [lindex $sect_names 2]" progopts1
 736     }
 737
 738     if { $progopts1 == "" } { set $progopts1 "-r" }
 739     verbose "running $binary $progopts $progopts1" 3
 740
 741     set cmd "$binary $progopts $progopts1 dump.o"
 742     set redir ">dump.out"
 743     send_log "$cmd\n"
 744     set status [gas_host_run "$cmd" "$redir"]
 745     set comp_output [prune_warnings [lindex $status 1]]
 746     set comp_output [prune_warnings $comp_output]
 747     if ![string match "" $comp_output] then {
 748         send_log "$comp_output\n"
 749         fail $testname
 750         return
 751     }
 752
 753     # Create the substition list only for objdump reference.
 754     if { $sect_names != "" && $program == "objdump" } {
 755         # Some testcases use ".text" while others use "\.text".
 756         set regexp_subst [list "\\\\?\\.text" [lindex $sect_names 0] \
 757                            "\\\\?\\.data" [lindex $sect_names 1] \
 758                           "\\\\?\\.bss" [lindex $sect_names 2] ]
 759     } else {
 760         set regexp_subst ""
 761     }
 762
 763     verbose_eval {[file_contents "dump.out"]} 3
 764     if { [regexp_diff "dump.out" "${dumpfile}" $regexp_subst] } then {
 765         fail $testname
 766         verbose "output is [file_contents "dump.out"]" 2
 767         return
 768     }
 769
 770     pass $testname
 771 }
 772
 773 proc slurp_options { file } {
 774     if [catch { set f [open $file r] } x] {
 775         #perror "couldn't open `$file': $x"
 776         perror "$x"
 777         return -1
 778     }
 779     set opt_array {}
 780     # whitespace expression
 781     set ws  {[  ]*}
 782     set nws {[^         ]*}
 783     # whitespace is ignored anywhere except within the options list;
 784     # option names are alphabetic plus dash
 785     set pat "^#${ws}(\[a-zA-Z0-9-\]*)$ws:${ws}(.*)$ws\$"
 786     while { [gets $f line] != -1 } {
 787         set line [string trim $line]
 788         # Whitespace here is space-tab.
 789         if [regexp $pat $line xxx opt_name opt_val] {
 790             # match!
 791             lappend opt_array [list $opt_name $opt_val]
 792         } elseif {![regexp "^#" $line ]} {
 793             break
 794         }
 795     }
 796     close $f
 797     return $opt_array
 798 }
 799
 800 proc objdump { opts } {
 801     global OBJDUMP
 802     global comp_output
 803     global host_triplet
 804
 805     set status [gas_host_run "$OBJDUMP $opts" ""]
 806     set comp_output [prune_warnings [lindex $status 1]]
 807     verbose "objdump output=$comp_output\n" 3
 808 }
 809
 810 proc objdump_start_no_subdir { prog opts } {
 811     global OBJDUMP
 812     global srcdir
 813     global spawn_id
 814
 815     verbose "Starting $OBJDUMP $opts $prog" 2
 816     set status [gas_host_run "$OBJDUMP $opts $prog" ">&gas.out"]
 817     spawn -noecho -nottycopy cat gas.out
 818 }
 819
 820 proc objdump_finish { } {
 821     global spawn_id
 822
 823     catch "close"
 824     catch "wait"
 825 }
 826
 827 # Default timeout is 10 seconds, loses on a slow machine.  But some
 828 # configurations of dejagnu may override it.
 829 if {$timeout<120} then { set timeout 120 }
 830
 831 expect_after -i {
 832     timeout                     { perror "timeout" }
 833     "virtual memory exhausted"  { perror "virtual memory exhausted" }
 834     buffer_full                 { perror "buffer full" }
 835     eof                         { perror "eof" }
 836 }
 837
 838 proc file_contents { filename } {
 839     set file [open $filename r]
 840     set contents [read $file]
 841     close $file
 842     return $contents
 843 }
 844
 845 proc write_file { filename contents } {
 846     set file [open $filename w]
 847     puts $file "$contents"
 848     close $file
 849 }
 850
 851 proc verbose_eval { expr { level 1 } } {
 852     global verbose
 853     if $verbose>$level then { eval verbose "$expr" $level }
 854 }
 855
 856 # This definition is taken from an unreleased version of DejaGnu.  Once
 857 # that version gets released, and has been out in the world for a few
 858 # months at least, it may be safe to delete this copy.
 859 if ![string length [info proc prune_warnings]] {
 860     #
 861     # prune_warnings -- delete various system verbosities from TEXT.
 862     #
 863     # An example is:
 864     # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
 865     #
 866     # Sites with particular verbose os's may wish to override this in site.exp.
 867     #
 868     proc prune_warnings { text } {
 869         # This is from sun4's.  Do it for all machines for now.
 870         # The "\\1" is to try to preserve a "\n" but only if necessary.
 871         regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
 872
 873         # It might be tempting to get carried away and delete blank lines, etc.
 874         # Just delete *exactly* what we're ask to, and that's it.
 875         return $text
 876     }
 877 }
 878
 879 # run_list_test NAME (optional): OPTS TESTNAME
 880 #
 881 # Assemble the file "NAME.s" with command line options OPTS and
 882 # compare the assembler standard error output against the regular
 883 # expressions given in the file "NAME.l".  If TESTNAME is provided,
 884 # it will be used as the name of the test.
 885
 886 proc run_list_test { name {opts {}} {testname {}} } {
 887     global srcdir subdir
 888     if { [string length $testname] == 0 } then {
 889         set testname "[file tail $subdir] $name"
 890     }
 891     set file $srcdir/$subdir/$name
 892     gas_run ${name}.s $opts ">&dump.out"
 893     if { [regexp_diff "dump.out" "${file}.l"] } then {
 894         fail $testname
 895         verbose "output is [file_contents "dump.out"]" 2
 896         return
 897     }
 898     pass $testname
 899 }
 900
 901 # run_list_test_stdin NAME (optional): OPTS TESTNAME
 902 #
 903 # Similar to run_list_test, but use stdin as input.
 904
 905 proc run_list_test_stdin { name {opts {}} {testname {}} } {
 906     global srcdir subdir
 907     if { [string length $testname] == 0 } then {
 908         set testname "[file tail $subdir] $name"
 909     }
 910     set file $srcdir/$subdir/$name
 911     gas_run_stdin ${name}.s $opts ">&dump.out"
 912     if { [regexp_diff "dump.out" "${file}.l"] } then {
 913         fail $testname
 914         verbose "output is [file_contents "dump.out"]" 2
 915         return
 916     }
 917     pass $testname
 918 }