ld/testsuite/lib/ld-lib.exp

   1 # Support routines for LD testsuite.
   2 #   Copyright 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3 #   Free Software Foundation, Inc.
   4 #
   5 # This file is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  18 #
  19 #
  20 # default_ld_version
  21 #       extract and print the version number of ld
  22 #
  23 proc default_ld_version { ld } {
  24     global host_triplet
  25
  26     if { [which $ld] == 0 } then {
  27         perror "$ld does not exist"
  28         exit 1
  29     }
  30
  31     catch "exec $ld --version" tmp
  32     set tmp [prune_warnings $tmp]
  33     regexp "\[^\n\]* (cygnus-|)(\[-0-9.a-zA-Z-\]+)\[\r\n\].*" $tmp version cyg number
  34     if [info exists number] then {
  35         clone_output "$ld $number\n"
  36     }
  37 }
  38
  39 #
  40 # default_ld_relocate
  41 #       link an object using relocation
  42 #
  43 proc default_ld_relocate { ld target objects } {
  44     global HOSTING_EMU
  45     global host_triplet
  46
  47     if { [which $ld] == 0 } then {
  48         perror "$ld does not exist"
  49         return 0
  50     }
  51
  52     verbose -log "$ld $HOSTING_EMU -o $target -r $objects"
  53
  54     catch "exec $ld $HOSTING_EMU -o $target -r $objects" exec_output
  55     set exec_output [prune_warnings $exec_output]
  56     if [string match "" $exec_output] then {
  57         return 1
  58     } else {
  59         verbose -log "$exec_output"
  60         return 0
  61     }
  62 }
  63
  64 # Check to see if ld is being invoked with a non-endian output format
  65
  66 proc is_endian_output_format { object_flags } {
  67
  68     if {[string match "*-oformat binary*" $object_flags] ||      \
  69         [string match "*-oformat ieee*" $object_flags] ||        \
  70         [string match "*-oformat ihex*" $object_flags] ||        \
  71         [string match "*-oformat netbsd-core*" $object_flags] || \
  72         [string match "*-oformat srec*" $object_flags] ||        \
  73         [string match "*-oformat tekhex*" $object_flags] ||      \
  74         [string match "*-oformat trad-core*" $object_flags] } then {
  75         return 0
  76     } else {
  77         return 1
  78     }
  79 }
  80
  81 # Look for big-endian or little-endian switches in the multlib
  82 # options and translate these into a -EB or -EL switch.  Note
  83 # we cannot rely upon proc process_multilib_options to do this
  84 # for us because for some targets the compiler does not support
  85 # -EB/-EL but it does support -mbig-endian/-mlittle-endian, and
  86 # the site.exp file will include the switch "-mbig-endian"
  87 # (rather than "big-endian") which is not detected by proc
  88 # process_multilib_options.
  89
  90 proc big_or_little_endian {} {
  91
  92     if [board_info [target_info name] exists multilib_flags] {
  93         set tmp_flags " [board_info [target_info name] multilib_flags]";
  94
  95         foreach x $tmp_flags {
  96             case $x in {
  97                 {*big*endian eb EB -eb -EB} {
  98                     set flags " -EB"
  99                     return $flags
 100                 }
 101                 {*little*endian el EL -el -EL} {
 102                     set flags " -EL"
 103                     return $flags
 104                 }
 105             }
 106         }
 107     }
 108
 109     set flags ""
 110     return $flags
 111 }
 112
 113 #
 114 # default_ld_link
 115 #       link a program using ld
 116 #
 117 proc default_ld_link { ld target objects } {
 118     global HOSTING_EMU
 119     global HOSTING_CRT0
 120     global HOSTING_LIBS
 121     global LIBS
 122     global host_triplet
 123     global link_output
 124
 125     set objs "$HOSTING_CRT0 $objects"
 126     set libs "$LIBS $HOSTING_LIBS"
 127
 128     if { [which $ld] == 0 } then {
 129         perror "$ld does not exist"
 130         return 0
 131     }
 132
 133     if [is_endian_output_format $objects] then {
 134         set flags [big_or_little_endian]
 135     } else {
 136         set flags ""
 137     }
 138     verbose -log "$ld $HOSTING_EMU $flags -o $target $objs $libs"
 139
 140     catch "exec $ld $HOSTING_EMU $flags -o $target $objs $libs" link_output
 141     set exec_output [prune_warnings $link_output]
 142     if [string match "" $link_output] then {
 143         return 1
 144     } else {
 145         verbose -log "$link_output"
 146         return 0
 147     }
 148 }
 149
 150 #
 151 # default_ld_simple_link
 152 #       link a program using ld, without including any libraries
 153 #
 154 proc default_ld_simple_link { ld target objects } {
 155     global host_triplet
 156     global link_output
 157
 158     if { [which $ld] == 0 } then {
 159         perror "$ld does not exist"
 160         return 0
 161     }
 162
 163     if [is_endian_output_format $objects] then {
 164         set flags [big_or_little_endian]
 165     } else {
 166         set flags ""
 167     }
 168
 169     verbose -log "$ld $flags -o $target $objects"
 170
 171     catch "exec $ld $flags -o $target $objects" link_output
 172     set exec_output [prune_warnings $link_output]
 173
 174     # We don't care if we get a warning about a non-existent start
 175     # symbol, since the default linker script might use ENTRY.
 176     regsub -all "(^|\n)(\[^\n\]*: warning: cannot find entry symbol\[^\n\]*\n?)" $exec_output "\\1" exec_output
 177
 178     if [string match "" $exec_output] then {
 179         return 1
 180     } else {
 181         verbose -log "$exec_output"
 182         return 0
 183     }
 184 }
 185
 186 #
 187 # default_ld_compile
 188 #       compile an object using cc
 189 #
 190 proc default_ld_compile { cc source object } {
 191     global CFLAGS
 192     global srcdir
 193     global subdir
 194     global host_triplet
 195     global gcc_gas_flag
 196
 197     set cc_prog $cc
 198     if {[llength $cc_prog] > 1} then {
 199         set cc_prog [lindex $cc_prog 0]
 200     }
 201     if {[which $cc_prog] == 0} then {
 202         perror "$cc_prog does not exist"
 203         return 0
 204     }
 205
 206     catch "exec rm -f $object" exec_output
 207
 208     set flags "-I$srcdir/$subdir $CFLAGS"
 209
 210     # If we are compiling with gcc, we want to add gcc_gas_flag to
 211     # flags.  Rather than determine this in some complex way, we guess
 212     # based on the name of the compiler.
 213     if {[string match "*gcc*" $cc] || [string match "*++*" $cc]} then {
 214         set flags "$gcc_gas_flag $flags"
 215     }
 216
 217     if [board_info [target_info name] exists multilib_flags] {
 218         append flags " [board_info [target_info name] multilib_flags]";
 219     }
 220
 221     verbose -log "$cc $flags -c $source -o $object"
 222
 223     catch "exec $cc $flags -c $source -o $object" exec_output
 224     set exec_output [prune_warnings $exec_output]
 225     if [string match "" $exec_output] then {
 226         if {![file exists $object]} then {
 227             regexp ".*/(\[^/\]*)$" $source all dobj
 228             regsub "\\.c" $dobj ".o" realobj
 229             verbose "looking for $realobj"
 230             if {[file exists $realobj]} then {
 231                 verbose -log "mv $realobj $object"
 232                 catch "exec mv $realobj $object" exec_output
 233                 set exec_output [prune_warnings $exec_output]
 234                 if {![string match "" $exec_output]} then {
 235                     verbose -log "$exec_output"
 236                     perror "could not move $realobj to $object"
 237                     return 0
 238                 }
 239             } else {
 240                 perror "$object not found after compilation"
 241                 return 0
 242             }
 243         }
 244         return 1
 245     } else {
 246         verbose -log "$exec_output"
 247         perror "$source: compilation failed"
 248         return 0
 249     }
 250 }
 251
 252 #
 253 # default_ld_assemble
 254 #       assemble a file
 255 #
 256 proc default_ld_assemble { as source object } {
 257     global ASFLAGS
 258     global host_triplet
 259
 260     if {[which $as] == 0} then {
 261         perror "$as does not exist"
 262         return 0
 263     }
 264
 265     if ![info exists ASFLAGS] { set ASFLAGS "" }
 266
 267     set flags [big_or_little_endian]
 268
 269     verbose -log "$as $flags $ASFLAGS -o $object $source"
 270
 271     catch "exec $as $flags $ASFLAGS -o $object $source" exec_output
 272     set exec_output [prune_warnings $exec_output]
 273     if [string match "" $exec_output] then {
 274         return 1
 275     } else {
 276         verbose -log "$exec_output"
 277         perror "$source: assembly failed"
 278         return 0
 279     }
 280 }
 281
 282 #
 283 # default_ld_nm
 284 #       run nm on a file, putting the result in the array nm_output
 285 #
 286 proc default_ld_nm { nm nmflags object } {
 287     global NMFLAGS
 288     global nm_output
 289     global host_triplet
 290
 291     if {[which $nm] == 0} then {
 292         perror "$nm does not exist"
 293         return 0
 294     }
 295
 296     if {[info exists nm_output]} {
 297       unset nm_output
 298     }
 299
 300     if ![info exists NMFLAGS] { set NMFLAGS "" }
 301
 302     verbose -log "$nm $NMFLAGS $nmflags $object >tmpdir/nm.out"
 303
 304     catch "exec $nm $NMFLAGS $nmflags $object >tmpdir/nm.out" exec_output
 305     set exec_output [prune_warnings $exec_output]
 306     if [string match "" $exec_output] then {
 307         set file [open tmpdir/nm.out r]
 308         while { [gets $file line] != -1 } {
 309             verbose "$line" 2
 310             if [regexp "^(\[0-9a-fA-F\]+) \[a-zA-Z0-9\] (.+)$" $line whole value name] {
 311                 set name [string trimleft $name "_"]
 312                 verbose "Setting nm_output($name) to 0x$value" 2
 313                 set nm_output($name) 0x$value
 314             }
 315         }
 316         close $file
 317         return 1
 318     } else {
 319         verbose -log "$exec_output"
 320         perror "$object: nm failed"
 321         return 0
 322     }
 323 }
 324
 325 #
 326 # simple_diff
 327 #       compares two files line-by-line
 328 #       returns differences if exist
 329 #       returns null if file(s) cannot be opened
 330 #
 331 proc simple_diff { file_1 file_2 } {
 332     global target
 333
 334     set eof -1
 335     set differences 0
 336
 337     if [file exists $file_1] then {
 338         set file_a [open $file_1 r]
 339     } else {
 340         warning "$file_1 doesn't exist"
 341         return
 342     }
 343
 344     if [file exists $file_2] then {
 345         set file_b [open $file_2 r]
 346     } else {
 347         fail "$file_2 doesn't exist"
 348         return
 349     }
 350
 351     verbose "# Diff'ing: $file_1 $file_2\n" 2
 352
 353     while { [gets $file_a line] != $eof } {
 354         if [regexp "^#.*$" $line] then {
 355             continue
 356         } else {
 357             lappend list_a $line
 358         }
 359     }
 360     close $file_a
 361
 362     while { [gets $file_b line] != $eof } {
 363         if [regexp "^#.*$" $line] then {
 364             continue
 365         } else {
 366             lappend list_b $line
 367         }
 368     }
 369     close $file_b
 370
 371     for { set i 0 } { $i < [llength $list_a] } { incr i } {
 372         set line_a [lindex $list_a $i]
 373         set line_b [lindex $list_b $i]
 374
 375         verbose "\t$file_1: $i: $line_a\n" 3
 376         verbose "\t$file_2: $i: $line_b\n" 3
 377         if [string compare $line_a $line_b] then {
 378             verbose -log "\t$file_1: $i: $line_a\n"
 379             verbose -log "\t$file_2: $i: $line_b\n"
 380
 381             fail "Test: $target"
 382             return
 383         }
 384     }
 385
 386     if { [llength $list_a] != [llength $list_b] } {
 387         fail "Test: $target"
 388         return
 389     }
 390
 391     if $differences<1 then {
 392         pass "Test: $target"
 393     }
 394 }
 395
 396 # run_dump_test FILE
 397 # Copied from gas testsuite, tweaked and further extended.
 398 #
 399 # Assemble a .s file, then run some utility on it and check the output.
 400 #
 401 # There should be an assembly language file named FILE.s in the test
 402 # suite directory, and a pattern file called FILE.d.  `run_dump_test'
 403 # will assemble FILE.s, run some tool like `objdump', `objcopy', or
 404 # `nm' on the .o file to produce textual output, and then analyze that
 405 # with regexps.  The FILE.d file specifies what program to run, and
 406 # what to expect in its output.
 407 #
 408 # The FILE.d file begins with zero or more option lines, which specify
 409 # flags to pass to the assembler, the program to run to dump the
 410 # assembler's output, and the options it wants.  The option lines have
 411 # the syntax:
 412 #
 413 #         # OPTION: VALUE
 414 #
 415 # OPTION is the name of some option, like "name" or "objdump", and
 416 # VALUE is OPTION's value.  The valid options are described below.
 417 # Whitespace is ignored everywhere, except within VALUE.  The option
 418 # list ends with the first line that doesn't match the above syntax
 419 # (hmm, not great for error detection).
 420 #
 421 # The interesting options are:
 422 #
 423 #   name: TEST-NAME
 424 #       The name of this test, passed to DejaGNU's `pass' and `fail'
 425 #       commands.  If omitted, this defaults to FILE, the root of the
 426 #       .s and .d files' names.
 427 #
 428 #   as: FLAGS
 429 #       When assembling, pass FLAGS to the assembler.
 430 #       If assembling several files, you can pass different assembler
 431 #       options in the "source" directives.  See below.
 432 #
 433 #   ld: FLAGS
 434 #       Link assembled files using FLAGS, in the order of the "source"
 435 #       directives, when using multiple files.
 436 #
 437 #   objcopy_linked_file: FLAGS
 438 #       Run objcopy on the linked file with the specified flags.
 439 #       This lets you transform the linked file using objcopy, before the
 440 #       result is analyzed by an analyzer program specified below (which
 441 #       may in turn *also* be objcopy).
 442 #
 443 #   PROG: PROGRAM-NAME
 444 #       The name of the program to run to analyze the .o file produced
 445 #       by the assembler or the linker output.  This can be omitted;
 446 #       run_dump_test will guess which program to run by seeing which of
 447 #       the flags options below is present.
 448 #
 449 #   objdump: FLAGS
 450 #   nm: FLAGS
 451 #   objcopy: FLAGS
 452 #       Use the specified program to analyze the assembler or linker
 453 #       output file, and pass it FLAGS, in addition to the output name.
 454 #
 455 #   source: SOURCE [FLAGS]
 456 #       Assemble the file SOURCE.s using the flags in the "as" directive
 457 #       and the (optional) FLAGS.  If omitted, the source defaults to
 458 #       FILE.s.
 459 #       This is useful if several .d files want to share a .s file.
 460 #       More than one "source" directive can be given, which is useful
 461 #       when testing linking.
 462 #
 463 #   xfail: TARGET
 464 #       The test is expected to fail on TARGET.  This may occur more than
 465 #       once.
 466 #
 467 #   target: TARGET
 468 #       Only run the test for TARGET.  This may occur more than once; the
 469 #       target being tested must match at least one.
 470 #
 471 #   notarget: TARGET
 472 #       Do not run the test for TARGET.  This may occur more than once;
 473 #       the target being tested must not match any of them.
 474 #
 475 #   error: REGEX
 476 #       An error with message matching REGEX must be emitted for the test
 477 #       to pass.  The PROG, objdump, nm and objcopy options have no
 478 #       meaning and need not supplied if this is present.
 479 #
 480 # Each option may occur at most once unless otherwise mentioned.
 481 #
 482 # After the option lines come regexp lines.  `run_dump_test' calls
 483 # `regexp_diff' to compare the output of the dumping tool against the
 484 # regexps in FILE.d.  `regexp_diff' is defined later in this file; see
 485 # further comments there.
 486
 487 proc run_dump_test { name } {
 488     global subdir srcdir
 489     global OBJDUMP NM AS OBJCOPY READELF LD
 490     global OBJDUMPFLAGS NMFLAGS ASFLAGS OBJCOPYFLAGS READELFFLAGS LDFLAGS
 491     global host_triplet runtests
 492
 493     if [string match "*/*" $name] {
 494         set file $name
 495         set name [file tail $name]
 496     } else {
 497         set file "$srcdir/$subdir/$name"
 498     }
 499
 500     if ![runtest_file_p $runtests $name] then {
 501         return
 502     }
 503
 504     set opt_array [slurp_options "${file}.d"]
 505     if { $opt_array == -1 } {
 506         perror "error reading options from $file.d"
 507         unresolved $subdir/$name
 508         return
 509     }
 510     set dumpfile tmpdir/dump.out
 511     set run_ld 0
 512     set run_objcopy 0
 513     set opts(as) {}
 514     set opts(ld) {}
 515     set opts(xfail) {}
 516     set opts(target) {}
 517     set opts(notarget) {}
 518     set opts(objdump) {}
 519     set opts(nm) {}
 520     set opts(objcopy) {}
 521     set opts(readelf) {}
 522     set opts(name) {}
 523     set opts(PROG) {}
 524     set opts(source) {}
 525     set opts(error) {}
 526     set opts(objcopy_linked_file) {}
 527     set asflags(${file}.s) {}
 528
 529     foreach i $opt_array {
 530         set opt_name [lindex $i 0]
 531         set opt_val [lindex $i 1]
 532         if ![info exists opts($opt_name)] {
 533             perror "unknown option $opt_name in file $file.d"
 534             unresolved $subdir/$name
 535             return
 536         }
 537
 538         switch -- $opt_name {
 539             xfail {}
 540             target {}
 541             notarget {}
 542             source {
 543                 # Move any source-specific as-flags to a separate array to
 544                 # simplify processing.
 545                 if { [llength $opt_val] > 1 } {
 546                     set asflags([lindex $opt_val 0]) [lrange $opt_val 1 end]
 547                     set opt_val [lindex $opt_val 0]
 548                 } else {
 549                     set asflags($opt_val) {}
 550                 }
 551             }
 552             default {
 553                 if [string length $opts($opt_name)] {
 554                     perror "option $opt_name multiply set in $file.d"
 555                     unresolved $subdir/$name
 556                     return
 557                 }
 558
 559                 # A single "# ld:" with no options should do the right thing.
 560                 if { $opt_name == "ld" } {
 561                     set run_ld 1
 562                 }
 563                 # Likewise objcopy_linked_file.
 564                 if { $opt_name == "objcopy_linked_file" } {
 565                     set run_objcopy 1
 566                 }
 567             }
 568         }
 569         set opts($opt_name) [concat $opts($opt_name) $opt_val]
 570     }
 571
 572     # Decide early whether we should run the test for this target.
 573     if { [llength $opts(target)] > 0 } {
 574         set targmatch 0
 575         foreach targ $opts(target) {
 576             if [istarget $targ] {
 577                 set targmatch 1
 578                 break
 579             }
 580         }
 581         if { $targmatch == 0 } {
 582             return
 583         }
 584     }
 585     foreach targ $opts(notarget) {
 586         if [istarget $targ] {
 587             return
 588         }
 589     }
 590
 591     if {$opts(PROG) != ""} {
 592         switch -- $opts(PROG) {
 593             objdump
 594                 { set program objdump }
 595             nm
 596                 { set program nm }
 597             objcopy
 598                 { set program objcopy }
 599             readelf
 600                 { set program readelf }
 601             default
 602                 { perror "unrecognized program option $opts(PROG) in $file.d"
 603                   unresolved $subdir/$name
 604                   return }
 605         }
 606     } elseif { $opts(error) != "" } {
 607         # It's meaningless to require an output-testing method when we
 608         # expect an error.  For simplicity, we fake an arbitrary method.
 609         set program "nm"
 610     } else {
 611         # Guess which program to run, by seeing which option was specified.
 612         set program ""
 613         foreach p {objdump objcopy nm readelf} {
 614             if {$opts($p) != ""} {
 615                 if {$program != ""} {
 616                     perror "ambiguous dump program in $file.d"
 617                     unresolved $subdir/$name
 618                     return
 619                 } else {
 620                     set program $p
 621                 }
 622             }
 623         }
 624         if {$program == ""} {
 625             perror "dump program unspecified in $file.d"
 626             unresolved $subdir/$name
 627             return
 628         }
 629     }
 630
 631     set progopts1 $opts($program)
 632     eval set progopts \$[string toupper $program]FLAGS
 633     eval set binary \$[string toupper $program]
 634     if { $opts(name) == "" } {
 635         set testname "$subdir/$name"
 636     } else {
 637         set testname $opts(name)
 638     }
 639
 640     if { $opts(source) == "" } {
 641         set sourcefiles [list ${file}.s]
 642     } else {
 643         set sourcefiles {}
 644         foreach sf $opts(source) {
 645             lappend sourcefiles "$srcdir/$subdir/$sf"
 646             # Must have asflags indexed on source name.
 647             set asflags($srcdir/$subdir/$sf) $asflags($sf)
 648         }
 649     }
 650
 651     # Time to setup xfailures.
 652     foreach targ $opts(xfail) {
 653         setup_xfail $targ
 654     }
 655
 656     # Assemble each file.
 657     set objfiles {}
 658     for { set i 0 } { $i < [llength $sourcefiles] } { incr i } {
 659         set sourcefile [lindex $sourcefiles $i]
 660
 661         set objfile "tmpdir/dump$i.o"
 662         lappend objfiles $objfile
 663         set cmd "$AS $ASFLAGS $opts(as) $asflags($sourcefile) -o $objfile $sourcefile"
 664
 665         send_log "$cmd\n"
 666         set cmdret [catch "exec $cmd" comp_output]
 667         set comp_output [prune_warnings $comp_output]
 668
 669         # We accept errors at assembly stage too, unless we're supposed to
 670         # link something.
 671         if { $cmdret != 0 || ![string match "" $comp_output] } then {
 672             send_log "$comp_output\n"
 673             verbose "$comp_output" 3
 674             if { $opts(error) != "" && $run_ld == 0 } {
 675                 if [regexp $opts(error) $comp_output] {
 676                     pass $testname
 677                     return
 678                 }
 679             }
 680             fail $testname
 681             return
 682         }
 683     }
 684
 685     # Perhaps link the file(s).
 686     if { $run_ld } {
 687         set objfile "tmpdir/dump"
 688         set cmd "$LD $LDFLAGS $opts(ld) -o $objfile $objfiles"
 689
 690         send_log "$cmd\n"
 691         set cmdret [catch "exec $cmd" comp_output]
 692         set comp_output [prune_warnings $comp_output]
 693
 694         if { $cmdret != 0 || ![string match "" $comp_output] } then {
 695             verbose -log "failed with: <$comp_output>, expected: <$opts(error)>"
 696             send_log "$comp_output\n"
 697             verbose "$comp_output" 3
 698             if { $opts(error) != "" && $run_objcopy == 0 } {
 699                 if [regexp $opts(error) $comp_output] {
 700                     pass $testname
 701                     return
 702                 }
 703             }
 704             fail $testname
 705             return
 706         }
 707
 708         if { $run_objcopy } {
 709             set infile $objfile
 710             set objfile "tmpdir/dump1"
 711
 712             # Note that we don't use OBJCOPYFLAGS here; any flags must be
 713             # explicitly specified.
 714             set cmd "$OBJCOPY $opts(objcopy_linked_file) $infile $objfile"
 715
 716             send_log "$cmd\n"
 717             set cmdret [catch "exec $cmd" comp_output]
 718             set comp_output [prune_warnings $comp_output]
 719
 720             if { $cmdret != 0 || ![string match "" $comp_output] } then {
 721                 verbose -log "failed with: <$comp_output>, expected: <$opts(error)>"
 722                 send_log "$comp_output\n"
 723                 verbose "$comp_output" 3
 724                 if { $opts(error) != "" } {
 725                     if [regexp $opts(error) $comp_output] {
 726                         pass $testname
 727                         return
 728                     }
 729                 }
 730                 fail $testname
 731                 return
 732             }
 733         }
 734     } else {
 735         set objfile "tmpdir/dump0.o"
 736     }
 737
 738     # We must not have expected failure if we get here.
 739     if { $opts(error) != "" } {
 740         fail $testname
 741         return
 742     }
 743
 744     if { [which $binary] == 0 } {
 745         untested $testname
 746         return
 747     }
 748
 749     if { $progopts1 == "" } { set $progopts1 "-r" }
 750     verbose "running $binary $progopts $progopts1" 3
 751
 752     # Objcopy, unlike the other two, won't send its output to stdout,
 753     # so we have to run it specially.
 754     if { $program == "objcopy" } {
 755         set cmd "$binary $progopts $progopts1 $objfile $dumpfile"
 756         send_log "$cmd\n"
 757         catch "exec $cmd" comp_output
 758         set comp_output [prune_warnings $comp_output]
 759         if ![string match "" $comp_output] then {
 760             send_log "$comp_output\n"
 761             fail $testname
 762             return
 763         }
 764     } else {
 765         set cmd "$binary $progopts $progopts1 $objfile > $dumpfile"
 766         send_log "$cmd\n"
 767         catch "exec $cmd" comp_output
 768         set comp_output [prune_warnings $comp_output]
 769         if ![string match "" $comp_output] then {
 770             send_log "$comp_output\n"
 771             fail $testname
 772             return
 773         }
 774     }
 775
 776     verbose_eval {[file_contents $dumpfile]} 3
 777     if { [regexp_diff $dumpfile "${file}.d"] } then {
 778         fail $testname
 779         verbose "output is [file_contents $dumpfile]" 2
 780         return
 781     }
 782
 783     pass $testname
 784 }
 785
 786 proc slurp_options { file } {
 787     if [catch { set f [open $file r] } x] {
 788         #perror "couldn't open `$file': $x"
 789         perror "$x"
 790         return -1
 791     }
 792     set opt_array {}
 793     # whitespace expression
 794     set ws  {[  ]*}
 795     set nws {[^         ]*}
 796     # whitespace is ignored anywhere except within the options list;
 797     # option names are alphabetic plus underscore only.
 798     set pat "^#${ws}(\[a-zA-Z_\]*)$ws:${ws}(.*)$ws\$"
 799     while { [gets $f line] != -1 } {
 800         set line [string trim $line]
 801         # Whitespace here is space-tab.
 802         if [regexp $pat $line xxx opt_name opt_val] {
 803             # match!
 804             lappend opt_array [list $opt_name $opt_val]
 805         } else {
 806             break
 807         }
 808     }
 809     close $f
 810     return $opt_array
 811 }
 812
 813 # regexp_diff, copied from gas, based on simple_diff above.
 814 #       compares two files line-by-line
 815 #       file1 contains strings, file2 contains regexps and #-comments
 816 #       blank lines are ignored in either file
 817 #       returns non-zero if differences exist
 818 #
 819 proc regexp_diff { file_1 file_2 } {
 820
 821     set eof -1
 822     set end_1 0
 823     set end_2 0
 824     set differences 0
 825     set diff_pass 0
 826
 827     if [file exists $file_1] then {
 828         set file_a [open $file_1 r]
 829     } else {
 830         warning "$file_1 doesn't exist"
 831         return 1
 832     }
 833
 834     if [file exists $file_2] then {
 835         set file_b [open $file_2 r]
 836     } else {
 837         fail "$file_2 doesn't exist"
 838         close $file_a
 839         return 1
 840     }
 841
 842     verbose " Regexp-diff'ing: $file_1 $file_2" 2
 843
 844     while { 1 } {
 845         set line_a ""
 846         set line_b ""
 847         while { [string length $line_a] == 0 } {
 848             if { [gets $file_a line_a] == $eof } {
 849                 set end_1 1
 850                 break
 851             }
 852         }
 853         while { [string length $line_b] == 0 || [string match "#*" $line_b] } {
 854             if [ string match "#pass" $line_b ] {
 855                 set end_2 1
 856                 set diff_pass 1
 857                 break
 858             } elseif [ string match "#..." $line_b ] {
 859                 if { [gets $file_b line_b] == $eof } {
 860                     set end_2 1
 861                     break
 862                 }
 863                 verbose "looking for \"^$line_b$\"" 3
 864                 while { ![regexp "^$line_b$" "$line_a"] } {
 865                     verbose "skipping    \"$line_a\"" 3
 866                     if { [gets $file_a line_a] == $eof } {
 867                         set end_1 1
 868                         break
 869                     }
 870                 }
 871                 break
 872             }
 873             if { [gets $file_b line_b] == $eof } {
 874                 set end_2 1
 875                 break
 876             }
 877         }
 878
 879         if { $diff_pass } {
 880             break
 881         } elseif { $end_1 && $end_2 } {
 882             break
 883         } elseif { $end_1 } {
 884             send_log "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1\n"
 885             verbose "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1" 3
 886             set differences 1
 887             break
 888         } elseif { $end_2 } {
 889             send_log "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n"
 890             verbose "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 3
 891             set differences 1
 892             break
 893         } else {
 894             verbose "regexp \"^$line_b$\"\nline   \"$line_a\"" 3
 895             if ![regexp "^$line_b$" "$line_a"] {
 896                 send_log "regexp_diff match failure\n"
 897                 send_log "regexp \"^$line_b$\"\nline   \"$line_a\"\n"
 898                 set differences 1
 899             }
 900         }
 901     }
 902
 903     if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } {
 904         send_log "$file_1 and $file_2 are different lengths\n"
 905         verbose "$file_1 and $file_2 are different lengths" 3
 906         set differences 1
 907     }
 908
 909     close $file_a
 910     close $file_b
 911
 912     return $differences
 913 }
 914
 915 proc file_contents { filename } {
 916     set file [open $filename r]
 917     set contents [read $file]
 918     close $file
 919     return $contents
 920 }
 921
 922 proc verbose_eval { expr { level 1 } } {
 923     global verbose
 924     if $verbose>$level then { eval verbose "$expr" $level }
 925 }
 926
 927 # This definition is taken from an unreleased version of DejaGnu.  Once
 928 # that version gets released, and has been out in the world for a few
 929 # months at least, it may be safe to delete this copy.
 930 if ![string length [info proc prune_warnings]] {
 931     #
 932     # prune_warnings -- delete various system verbosities from TEXT
 933     #
 934     # An example is:
 935     # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
 936     #
 937     # Sites with particular verbose os's may wish to override this in site.exp.
 938     #
 939     proc prune_warnings { text } {
 940         # This is from sun4's.  Do it for all machines for now.
 941         # The "\\1" is to try to preserve a "\n" but only if necessary.
 942         regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
 943
 944         # It might be tempting to get carried away and delete blank lines, etc.
 945         # Just delete *exactly* what we're ask to, and that's it.
 946         return $text
 947     }
 948 }