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 #   PROG: PROGRAM-NAME
 438 #       The name of the program to run to analyze the .o file produced
 439 #       by the assembler or the linker output.  This can be omitted;
 440 #       run_dump_test will guess which program to run by seeing which of
 441 #       the flags options below is present.
 442 #
 443 #   objdump: FLAGS
 444 #   nm: FLAGS
 445 #   objcopy: FLAGS
 446 #       Use the specified program to analyze the assembler or linker
 447 #       output file, and pass it FLAGS, in addition to the output name.
 448 #
 449 #   source: SOURCE [FLAGS]
 450 #       Assemble the file SOURCE.s using the flags in the "as" directive
 451 #       and the (optional) FLAGS.  If omitted, the source defaults to
 452 #       FILE.s.
 453 #       This is useful if several .d files want to share a .s file.
 454 #       More than one "source" directive can be given, which is useful
 455 #       when testing linking.
 456 #
 457 #   xfail: TARGET
 458 #       The test is expected to fail on TARGET.  This may occur more than
 459 #       once.
 460 #
 461 #   target: TARGET
 462 #       Only run the test for TARGET.  This may occur more than once; the
 463 #       target being tested must match at least one.
 464 #
 465 #   notarget: TARGET
 466 #       Do not run the test for TARGET.  This may occur more than once;
 467 #       the target being tested must not match any of them.
 468 #
 469 #   error: REGEX
 470 #       An error with message matching REGEX must be emitted for the test
 471 #       to pass.  The PROG, objdump, nm and objcopy options have no
 472 #       meaning and need not supplied if this is present.
 473 #
 474 # Each option may occur at most once unless otherwise mentioned.
 475 #
 476 # After the option lines come regexp lines.  `run_dump_test' calls
 477 # `regexp_diff' to compare the output of the dumping tool against the
 478 # regexps in FILE.d.  `regexp_diff' is defined later in this file; see
 479 # further comments there.
 480
 481 proc run_dump_test { name } {
 482     global subdir srcdir
 483     global OBJDUMP NM AS OBJCOPY READELF LD
 484     global OBJDUMPFLAGS NMFLAGS ASFLAGS OBJCOPYFLAGS READELFFLAGS LDFLAGS
 485     global host_triplet runtests
 486
 487     if [string match "*/*" $name] {
 488         set file $name
 489         set name [file tail $name]
 490     } else {
 491         set file "$srcdir/$subdir/$name"
 492     }
 493
 494     if ![runtest_file_p $runtests $name] then {
 495         return
 496     }
 497
 498     set opt_array [slurp_options "${file}.d"]
 499     if { $opt_array == -1 } {
 500         perror "error reading options from $file.d"
 501         unresolved $subdir/$name
 502         return
 503     }
 504     set dumpfile tmpdir/dump.out
 505     set run_ld 0
 506     set opts(as) {}
 507     set opts(ld) {}
 508     set opts(xfail) {}
 509     set opts(target) {}
 510     set opts(notarget) {}
 511     set opts(objdump) {}
 512     set opts(nm) {}
 513     set opts(objcopy) {}
 514     set opts(readelf) {}
 515     set opts(name) {}
 516     set opts(PROG) {}
 517     set opts(source) {}
 518     set opts(error) {}
 519     set asflags{${file}.s} {}
 520
 521     foreach i $opt_array {
 522         set opt_name [lindex $i 0]
 523         set opt_val [lindex $i 1]
 524         if ![info exists opts($opt_name)] {
 525             perror "unknown option $opt_name in file $file.d"
 526             unresolved $subdir/$name
 527             return
 528         }
 529
 530         switch -- $opt_name {
 531             xfail {}
 532             target {}
 533             notarget {}
 534             source {
 535                 # Move any source-specific as-flags to a separate array to
 536                 # simplify processing.
 537                 if { [llength $opt_val] > 1 } {
 538                     set asflags([lindex $opt_val 0]) [lrange $opt_val 1 end]
 539                     set opt_val [lindex $opt_val 0]
 540                 } else {
 541                     set asflags($opt_val) {}
 542                 }
 543             }
 544             default {
 545                 if [string length $opts($opt_name)] {
 546                     perror "option $opt_name multiply set in $file.d"
 547                     unresolved $subdir/$name
 548                     return
 549                 }
 550
 551                 # A single "# ld:" with no options should do the right thing.
 552                 if { $opt_name == "ld" } {
 553                     set run_ld 1
 554                 }
 555             }
 556         }
 557         set opts($opt_name) [concat $opts($opt_name) $opt_val]
 558     }
 559
 560     # Decide early whether we should run the test for this target.
 561     if { [llength $opts(target)] > 0 } {
 562         set targmatch 0
 563         foreach targ $opts(target) {
 564             if [istarget $targ] {
 565                 set targmatch 1
 566                 break
 567             }
 568         }
 569         if { $targmatch == 0 } {
 570             return
 571         }
 572     }
 573     foreach targ $opts(notarget) {
 574         if [istarget $targ] {
 575             return
 576         }
 577     }
 578
 579     if {$opts(PROG) != ""} {
 580         switch -- $opts(PROG) {
 581             objdump
 582                 { set program objdump }
 583             nm
 584                 { set program nm }
 585             objcopy
 586                 { set program objcopy }
 587             readelf
 588                 { set program readelf }
 589             default
 590                 { perror "unrecognized program option $opts(PROG) in $file.d"
 591                   unresolved $subdir/$name
 592                   return }
 593         }
 594     } elseif { $opts(error) != "" } {
 595         # It's meaningless to require an output-testing method when we
 596         # expect an error.  For simplicity, we fake an arbitrary method.
 597         set program "nm"
 598     } else {
 599         # Guess which program to run, by seeing which option was specified.
 600         set program ""
 601         foreach p {objdump objcopy nm readelf} {
 602             if {$opts($p) != ""} {
 603                 if {$program != ""} {
 604                     perror "ambiguous dump program in $file.d"
 605                     unresolved $subdir/$name
 606                     return
 607                 } else {
 608                     set program $p
 609                 }
 610             }
 611         }
 612         if {$program == ""} {
 613             perror "dump program unspecified in $file.d"
 614             unresolved $subdir/$name
 615             return
 616         }
 617     }
 618
 619     set progopts1 $opts($program)
 620     eval set progopts \$[string toupper $program]FLAGS
 621     eval set binary \$[string toupper $program]
 622     if { $opts(name) == "" } {
 623         set testname "$subdir/$name"
 624     } else {
 625         set testname $opts(name)
 626     }
 627
 628     if { $opts(source) == "" } {
 629         set sourcefiles [list ${file}.s]
 630     } else {
 631         set sourcefiles {}
 632         foreach sf $opts(source) {
 633             lappend sourcefiles "$srcdir/$subdir/$sf"
 634             # Must have asflags indexed on source name.
 635             set asflags($srcdir/$subdir/$sf) $asflags($sf)
 636         }
 637     }
 638
 639     # Time to setup xfailures.
 640     foreach targ $opts(xfail) {
 641         setup_xfail $targ
 642     }
 643
 644     # Assemble each file.
 645     set objfiles {}
 646     for { set i 0 } { $i < [llength $sourcefiles] } { incr i } {
 647         set sourcefile [lindex $sourcefiles $i]
 648
 649         set objfile "tmpdir/dump$i.o"
 650         lappend objfiles $objfile
 651         set cmd "$AS $ASFLAGS $opts(as) $asflags($sourcefile) -o $objfile $sourcefile"
 652
 653         send_log "$cmd\n"
 654         set cmdret [catch "exec $cmd" comp_output]
 655         set comp_output [prune_warnings $comp_output]
 656
 657         # We accept errors at assembly stage too, unless we're supposed to
 658         # link something.
 659         if { $cmdret != 0 || ![string match "" $comp_output] } then {
 660             send_log "$comp_output\n"
 661             verbose "$comp_output" 3
 662             if { $opts(error) != "" && $run_ld == 0 } {
 663                 if [regexp $opts(error) $comp_output] {
 664                     pass $testname
 665                     return
 666                 }
 667             }
 668             fail $testname
 669             return
 670         }
 671     }
 672
 673     # Perhaps link the file(s).
 674     if { $run_ld } {
 675         set objfile "tmpdir/dump"
 676         set cmd "$LD $LDFLAGS $opts(ld) -o $objfile $objfiles"
 677
 678         send_log "$cmd\n"
 679         set cmdret [catch "exec $cmd" comp_output]
 680         set comp_output [prune_warnings $comp_output]
 681
 682         if { $cmdret != 0 || ![string match "" $comp_output] } then {
 683             verbose -log "failed with: <$comp_output>, expected: <$opts(error)>"
 684             send_log "$comp_output\n"
 685             verbose "$comp_output" 3
 686             if { $opts(error) != "" } {
 687                 if [regexp $opts(error) $comp_output] {
 688                     pass $testname
 689                     return
 690                 }
 691             }
 692             fail $testname
 693             return
 694         }
 695     } else {
 696         set objfile "tmpdir/dump0.o"
 697     }
 698
 699     # We must not have expected failure if we get here.
 700     if { $opts(error) != "" } {
 701         fail $testname
 702     }
 703
 704     if { [which $binary] == 0 } {
 705         untested $testname
 706         return
 707     }
 708
 709     if { $progopts1 == "" } { set $progopts1 "-r" }
 710     verbose "running $binary $progopts $progopts1" 3
 711
 712     # Objcopy, unlike the other two, won't send its output to stdout,
 713     # so we have to run it specially.
 714     if { $program == "objcopy" } {
 715         set cmd "$binary $progopts $progopts1 $objfile $dumpfile"
 716         send_log "$cmd\n"
 717         catch "exec $cmd" comp_output
 718         set comp_output [prune_warnings $comp_output]
 719         if ![string match "" $comp_output] then {
 720             send_log "$comp_output\n"
 721             fail $testname
 722             return
 723         }
 724     } else {
 725         set cmd "$binary $progopts $progopts1 $objfile > $dumpfile"
 726         send_log "$cmd\n"
 727         catch "exec $cmd" comp_output
 728         set comp_output [prune_warnings $comp_output]
 729         if ![string match "" $comp_output] then {
 730             send_log "$comp_output\n"
 731             fail $testname
 732             return
 733         }
 734     }
 735
 736     verbose_eval {[file_contents $dumpfile]} 3
 737     if { [regexp_diff $dumpfile "${file}.d"] } then {
 738         fail $testname
 739         verbose "output is [file_contents $dumpfile]" 2
 740         return
 741     }
 742
 743     pass $testname
 744 }
 745
 746 proc slurp_options { file } {
 747     if [catch { set f [open $file r] } x] {
 748         #perror "couldn't open `$file': $x"
 749         perror "$x"
 750         return -1
 751     }
 752     set opt_array {}
 753     # whitespace expression
 754     set ws  {[  ]*}
 755     set nws {[^         ]*}
 756     # whitespace is ignored anywhere except within the options list;
 757     # option names are alphabetic only
 758     set pat "^#${ws}(\[a-zA-Z\]*)$ws:${ws}(.*)$ws\$"
 759     while { [gets $f line] != -1 } {
 760         set line [string trim $line]
 761         # Whitespace here is space-tab.
 762         if [regexp $pat $line xxx opt_name opt_val] {
 763             # match!
 764             lappend opt_array [list $opt_name $opt_val]
 765         } else {
 766             break
 767         }
 768     }
 769     close $f
 770     return $opt_array
 771 }
 772
 773 # regexp_diff, copied from gas, based on simple_diff above.
 774 #       compares two files line-by-line
 775 #       file1 contains strings, file2 contains regexps and #-comments
 776 #       blank lines are ignored in either file
 777 #       returns non-zero if differences exist
 778 #
 779 proc regexp_diff { file_1 file_2 } {
 780
 781     set eof -1
 782     set end_1 0
 783     set end_2 0
 784     set differences 0
 785     set diff_pass 0
 786
 787     if [file exists $file_1] then {
 788         set file_a [open $file_1 r]
 789     } else {
 790         warning "$file_1 doesn't exist"
 791         return 1
 792     }
 793
 794     if [file exists $file_2] then {
 795         set file_b [open $file_2 r]
 796     } else {
 797         fail "$file_2 doesn't exist"
 798         close $file_a
 799         return 1
 800     }
 801
 802     verbose " Regexp-diff'ing: $file_1 $file_2" 2
 803
 804     while { 1 } {
 805         set line_a ""
 806         set line_b ""
 807         while { [string length $line_a] == 0 } {
 808             if { [gets $file_a line_a] == $eof } {
 809                 set end_1 1
 810                 break
 811             }
 812         }
 813         while { [string length $line_b] == 0 || [string match "#*" $line_b] } {
 814             if [ string match "#pass" $line_b ] {
 815                 set end_2 1
 816                 set diff_pass 1
 817                 break
 818             } elseif [ string match "#..." $line_b ] {
 819                 if { [gets $file_b line_b] == $eof } {
 820                     set end_2 1
 821                     break
 822                 }
 823                 verbose "looking for \"^$line_b$\"" 3
 824                 while { ![regexp "^$line_b$" "$line_a"] } {
 825                     verbose "skipping    \"$line_a\"" 3
 826                     if { [gets $file_a line_a] == $eof } {
 827                         set end_1 1
 828                         break
 829                     }
 830                 }
 831                 break
 832             }
 833             if { [gets $file_b line_b] == $eof } {
 834                 set end_2 1
 835                 break
 836             }
 837         }
 838
 839         if { $diff_pass } {
 840             break
 841         } elseif { $end_1 && $end_2 } {
 842             break
 843         } elseif { $end_1 } {
 844             send_log "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1\n"
 845             verbose "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1" 3
 846             set differences 1
 847             break
 848         } elseif { $end_2 } {
 849             send_log "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n"
 850             verbose "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 3
 851             set differences 1
 852             break
 853         } else {
 854             verbose "regexp \"^$line_b$\"\nline   \"$line_a\"" 3
 855             if ![regexp "^$line_b$" "$line_a"] {
 856                 send_log "regexp_diff match failure\n"
 857                 send_log "regexp \"^$line_b$\"\nline   \"$line_a\"\n"
 858                 set differences 1
 859             }
 860         }
 861     }
 862
 863     if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } {
 864         send_log "$file_1 and $file_2 are different lengths\n"
 865         verbose "$file_1 and $file_2 are different lengths" 3
 866         set differences 1
 867     }
 868
 869     close $file_a
 870     close $file_b
 871
 872     return $differences
 873 }
 874
 875 proc file_contents { filename } {
 876     set file [open $filename r]
 877     set contents [read $file]
 878     close $file
 879     return $contents
 880 }
 881
 882 proc verbose_eval { expr { level 1 } } {
 883     global verbose
 884     if $verbose>$level then { eval verbose "$expr" $level }
 885 }
 886
 887 # This definition is taken from an unreleased version of DejaGnu.  Once
 888 # that version gets released, and has been out in the world for a few
 889 # months at least, it may be safe to delete this copy.
 890 if ![string length [info proc prune_warnings]] {
 891     #
 892     # prune_warnings -- delete various system verbosities from TEXT
 893     #
 894     # An example is:
 895     # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
 896     #
 897     # Sites with particular verbose os's may wish to override this in site.exp.
 898     #
 899     proc prune_warnings { text } {
 900         # This is from sun4's.  Do it for all machines for now.
 901         # The "\\1" is to try to preserve a "\n" but only if necessary.
 902         regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
 903
 904         # It might be tempting to get carried away and delete blank lines, etc.
 905         # Just delete *exactly* what we're ask to, and that's it.
 906         return $text
 907     }
 908 }