1# Copyright (C) 1993, 1994, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2# 2004, 2005 Free Software Foundation, Inc. 3 4# This program is free software; you can redistribute it and/or modify 5# it under the terms of the GNU General Public License as published by 6# the Free Software Foundation; either version 2 of the License, or 7# (at your option) any later version. 8# 9# This program is distributed in the hope that it will be useful, 10# but WITHOUT ANY WARRANTY; without even the implied warranty of 11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12# GNU General Public License for more details. 13# 14# You should have received a copy of the GNU General Public License 15# along with this program; if not, write to the Free Software 16# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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 23proc gas_version {} { 24 global AS 25 catch "exec $AS -version < /dev/null" tmp 26 # Should find a way to discard constant parts, keep whatever's 27 # left, so the version string could be almost anything at all... 28 regexp "\[^\n\]* (cygnus-|)(\[-0-9.a-zA-Z-\]+)\[\r\n\].*" $tmp version cyg number 29 if ![info exists number] then { 30 return "[which $AS] (no version number)\n" 31 } 32 clone_output "[which $AS] $number\n" 33 unset version 34} 35 36proc gas_run { prog as_opts redir } { 37 global AS 38 global ASFLAGS 39 global comp_output 40 global srcdir 41 global subdir 42 global host_triplet 43 44 verbose -log "Executing $srcdir/lib/run $AS $ASFLAGS $as_opts $srcdir/$subdir/$prog $redir" 45 catch "exec $srcdir/lib/run $AS $ASFLAGS $as_opts $srcdir/$subdir/$prog $redir" comp_output 46 set comp_output [prune_warnings $comp_output] 47 verbose "output was $comp_output" 48 return [list $comp_output ""] 49} 50 51proc all_ones { args } { 52 foreach x $args { if [expr $x!=1] { return 0 } } 53 return 1 54} 55 56proc gas_start { prog as_opts } { 57 global AS 58 global ASFLAGS 59 global srcdir 60 global subdir 61 global spawn_id 62 63 verbose -log "Starting $AS $ASFLAGS $as_opts $prog" 2 64 catch { 65 spawn -noecho -nottycopy $srcdir/lib/run $AS $ASFLAGS $as_opts $srcdir/$subdir/$prog 66 } foo 67 if ![regexp {^[0-9]+} $foo] then { 68 perror "Can't run $subdir/$prog: $foo" 69 } 70} 71 72proc gas_finish { } { 73 global spawn_id 74 75 catch "close" 76 catch "wait" 77} 78 79proc want_no_output { testname } { 80 global comp_output 81 82 if ![string match "" $comp_output] then { 83 send_log "$comp_output\n" 84 verbose "$comp_output" 3 85 } 86 if [string match "" $comp_output] then { 87 pass "$testname" 88 return 1 89 } else { 90 fail "$testname" 91 return 0 92 } 93} 94 95proc gas_test_old { file as_opts testname } { 96 gas_run $file $as_opts "" 97 return [want_no_output $testname] 98} 99 100proc gas_test { file as_opts var_opts testname } { 101 global comp_output 102 103 set i 0 104 foreach word $var_opts { 105 set ignore_stdout($i) [string match "*>" $word] 106 set opt($i) [string trim $word {>}] 107 incr i 108 } 109 set max [expr 1<<$i] 110 for {set i 0} {[expr $i<$max]} {incr i} { 111 set maybe_ignore_stdout "" 112 set extra_opts "" 113 for {set bit 0} {(1<<$bit)<$max} {incr bit} { 114 set num [expr 1<<$bit] 115 if [expr $i&$num] then { 116 set extra_opts "$extra_opts $opt($bit)" 117 if $ignore_stdout($bit) then { 118 set maybe_ignore_stdout ">/dev/null" 119 } 120 } 121 } 122 set extra_opts [string trim $extra_opts] 123 gas_run $file "$as_opts $extra_opts" $maybe_ignore_stdout 124 125 # Should I be able to use a conditional expression here? 126 if [string match "" $extra_opts] then { 127 want_no_output $testname 128 } else { 129 want_no_output "$testname ($extra_opts)" 130 } 131 } 132 if [info exists errorInfo] then { 133 unset errorInfo 134 } 135} 136 137proc gas_test_ignore_stdout { file as_opts testname } { 138 global comp_output 139 140 gas_run $file $as_opts ">/dev/null" 141 want_no_output $testname 142} 143 144proc gas_test_error { file as_opts testname } { 145 global comp_output 146 147 gas_run $file $as_opts ">/dev/null" 148 if ![string match "" $comp_output] then { 149 send_log "$comp_output\n" 150 verbose "$comp_output" 3 151 } 152 if [string match "" $comp_output] then { 153 fail "$testname" 154 } else { 155 pass "$testname" 156 } 157} 158 159proc gas_exit {} {} 160 161proc gas_init { args } { 162 global target_cpu 163 global target_cpu_family 164 global target_family 165 global target_vendor 166 global target_os 167 global stdoptlist 168 169 case "$target_cpu" in { 170 "m68???" { set target_cpu_family m68k } 171 "i[3-7]86" { set target_cpu_family i386 } 172 default { set target_cpu_family $target_cpu } 173 } 174 175 set target_family "$target_cpu_family-$target_vendor-$target_os" 176 set stdoptlist "-a>" 177 178 if ![istarget "*-*-*"] { 179 perror "Target name [istarget] is not a triple." 180 } 181 # Need to return an empty string. 182 return 183} 184 185# 186# is_elf_format 187# true if the object format is known to be ELF 188# 189proc is_elf_format {} { 190 if { ![istarget *-*-sysv4*] \ 191 && ![istarget *-*-unixware*] \ 192 && ![istarget *-*-elf*] \ 193 && ![istarget *-*-eabi*] \ 194 && ![istarget hppa*64*-*-hpux*] \ 195 && ![istarget *-*-linux*] \ 196 && ![istarget frv-*-uclinux*] \ 197 && ![istarget *-*-irix5*] \ 198 && ![istarget *-*-irix6*] \ 199 && ![istarget *-*-netbsd*] \ 200 && ![istarget *-*-openbsd*] \ 201 && ![istarget *-*-solaris2*] } { 202 return 0 203 } 204 205 if { [istarget *-*-linux*aout*] \ 206 || [istarget *-*-linux*oldld*] } { 207 return 0 208 } 209 210 if { ![istarget *-*-netbsdelf*] \ 211 && ([istarget *-*-netbsd*aout*] \ 212 || [istarget *-*-netbsdpe*] \ 213 || [istarget arm*-*-netbsd*] \ 214 || [istarget sparc-*-netbsd*] \ 215 || [istarget i*86-*-netbsd*] \ 216 || [istarget m68*-*-netbsd*] \ 217 || [istarget vax-*-netbsd*] \ 218 || [istarget ns32k-*-netbsd*]) } { 219 return 0 220 } 221 222 if { [istarget arm-*-openbsd*] \ 223 || [istarget i386-*-openbsd\[0-2\].*] \ 224 || [istarget i386-*-openbsd3.\[0-3\]] \ 225 || [istarget m68*-*-openbsd*] \ 226 || [istarget ns32k-*-openbsd*] \ 227 || [istarget sparc-*-openbsd\[0-2\].*] \ 228 || [istarget sparc-*-openbsd3.\[0-1\]] \ 229 || [istarget vax-*-openbsd*] } { 230 return 0 231 } 232 233 return 1 234} 235 236 237# run_dump_test FILE (optional:) EXTRA_OPTIONS 238# 239# Assemble a .s file, then run some utility on it and check the output. 240# 241# There should be an assembly language file named FILE.s in the test 242# suite directory, and a pattern file called FILE.d. `run_dump_test' 243# will assemble FILE.s, run some tool like `objdump', `objcopy', or 244# `nm' on the .o file to produce textual output, and then analyze that 245# with regexps. The FILE.d file specifies what program to run, and 246# what to expect in its output. 247# 248# The FILE.d file begins with zero or more option lines, which specify 249# flags to pass to the assembler, the program to run to dump the 250# assembler's output, and the options it wants. The option lines have 251# the syntax: 252# 253# # OPTION: VALUE 254# 255# OPTION is the name of some option, like "name" or "objdump", and 256# VALUE is OPTION's value. The valid options are described below. 257# Whitespace is ignored everywhere, except within VALUE. The option 258# list ends with the first line that doesn't match the above syntax 259# (hmm, not great for error detection). 260# 261# The optional EXTRA_OPTIONS argument to `run_dump_test' is a list of 262# two-element lists. The first element of each is an option name, and 263# the second additional arguments to be added on to the end of the 264# option list as given in FILE.d. (If omitted, no additional options 265# are added.) 266# 267# The interesting options are: 268# 269# name: TEST-NAME 270# The name of this test, passed to DejaGNU's `pass' and `fail' 271# commands. If omitted, this defaults to FILE, the root of the 272# .s and .d files' names. 273# 274# as: FLAGS 275# When assembling FILE.s, pass FLAGS to the assembler. 276# 277# PROG: PROGRAM-NAME 278# The name of the program to run to analyze the .o file produced 279# by the assembler. This can be omitted; run_dump_test will guess 280# which program to run by seeing which of the flags options below 281# is present. 282# 283# objdump: FLAGS 284# nm: FLAGS 285# objcopy: FLAGS 286# Use the specified program to analyze the .o file, and pass it 287# FLAGS, in addition to the .o file name. Note that they are run 288# with LC_ALL=C in the environment to give consistent sorting 289# of symbols. 290# 291# source: SOURCE 292# Assemble the file SOURCE.s. If omitted, this defaults to FILE.s. 293# This is useful if several .d files want to share a .s file. 294# 295# error: REGEX 296# An error with message matching REGEX must be emitted for the test 297# to pass. The PROG, objdump, nm and objcopy options have no 298# meaning and need not supplied if this is present. 299# 300# warning: REGEX 301# Expect a gas warning matching REGEX. It is an error to issue 302# both "error" and "warning". 303# 304# Each option may occur at most once. 305# 306# After the option lines come regexp lines. `run_dump_test' calls 307# `regexp_diff' to compare the output of the dumping tool against the 308# regexps in FILE.d. `regexp_diff' is defined later in this file; see 309# further comments there. 310 311proc run_dump_test { name {extra_options {}} } { 312 global subdir srcdir 313 global OBJDUMP NM AS OBJCOPY READELF 314 global OBJDUMPFLAGS NMFLAGS ASFLAGS OBJCOPYFLAGS READELFFLAGS 315 global host_triplet 316 global env 317 318 if [string match "*/*" $name] { 319 set file $name 320 set name [file tail $name] 321 } else { 322 set file "$srcdir/$subdir/$name" 323 } 324 set opt_array [slurp_options "${file}.d"] 325 if { $opt_array == -1 } { 326 perror "error reading options from $file.d" 327 unresolved $subdir/$name 328 return 329 } 330 set opts(as) {} 331 set opts(objdump) {} 332 set opts(nm) {} 333 set opts(objcopy) {} 334 set opts(readelf) {} 335 set opts(name) {} 336 set opts(PROG) {} 337 set opts(source) {} 338 set opts(stderr) {} 339 set opts(error) {} 340 set opts(warning) {} 341 342 foreach i $opt_array { 343 set opt_name [lindex $i 0] 344 set opt_val [lindex $i 1] 345 if ![info exists opts($opt_name)] { 346 perror "unknown option $opt_name in file $file.d" 347 unresolved $subdir/$name 348 return 349 } 350 if [string length $opts($opt_name)] { 351 perror "option $opt_name multiply set in $file.d" 352 unresolved $subdir/$name 353 return 354 } 355 set opts($opt_name) $opt_val 356 } 357 358 foreach i $extra_options { 359 set opt_name [lindex $i 0] 360 set opt_val [lindex $i 1] 361 if ![info exists opts($opt_name)] { 362 perror "unknown option $opt_name given in extra_opts" 363 unresolved $subdir/$name 364 return 365 } 366 # add extra option to end of existing option, adding space 367 # if necessary. 368 if [string length $opts($opt_name)] { 369 append opts($opt_name) " " 370 } 371 append opts($opt_name) $opt_val 372 } 373 374 if { (($opts(warning) != "") && ($opts(error) != "")) \ 375 || (($opts(warning) != "") && ($opts(stderr) != "")) } { 376 perror "$testname: bad mix of stderr, error and warning test-directives" 377 return 378 } 379 380 set program "" 381 # It's meaningless to require an output-testing method when we 382 # expect an error. 383 if { $opts(error) == "" } { 384 if {$opts(PROG) != ""} { 385 switch -- $opts(PROG) { 386 objdump { set program objdump } 387 nm { set program nm } 388 objcopy { set program objcopy } 389 readelf { set program readelf } 390 default { 391 perror "unrecognized program option $opts(PROG) in $file.d" 392 unresolved $subdir/$name 393 return } 394 } 395 } else { 396 # Guess which program to run, by seeing which option was specified. 397 foreach p {objdump objcopy nm readelf} { 398 if {$opts($p) != ""} { 399 if {$program != ""} { 400 perror "ambiguous dump program in $file.d" 401 unresolved $subdir/$name 402 return 403 } else { 404 set program $p 405 } 406 } 407 } 408 } 409 if { $program == "" && $opts(warning) == "" } { 410 perror "dump program unspecified in $file.d" 411 unresolved $subdir/$name 412 return 413 } 414 } 415 416 if { $opts(name) == "" } { 417 set testname "$subdir/$name" 418 } else { 419 set testname $opts(name) 420 } 421 422 if { $opts(source) == "" } { 423 set sourcefile ${file}.s 424 } else { 425 set sourcefile $srcdir/$subdir/$opts(source) 426 } 427 428 set cmd "$srcdir/lib/run $AS $ASFLAGS $opts(as) -o dump.o $sourcefile" 429 send_log "$cmd\n" 430 set cmdret [catch "exec $cmd" comp_output] 431 set comp_output [prune_warnings $comp_output] 432 433 set expmsg $opts(error) 434 if { $opts(warning) != "" } { 435 set expmsg $opts(warning) 436 } 437 if { $cmdret != 0 || $comp_output != "" || $expmsg != "" } then { 438 # If the executed program writes to stderr and stderr is not 439 # redirected, exec *always* returns failure, regardless of the 440 # program exit code. Thankfully, we can retrieve the true 441 # return status from a special variable. Redirection would 442 # cause a tcl-specific message to be appended, and we'd rather 443 # not deal with that if we can help it. 444 global errorCode 445 if { $cmdret != 0 && [lindex $errorCode 0] == "NONE" } { 446 set cmdret 0 447 } 448 449 set exitstat "succeeded" 450 if { $cmdret != 0 } { set exitstat "failed" } 451 452 if { $opts(stderr) == "" } then { 453 send_log "$comp_output\n" 454 verbose "$comp_output" 3 455 456 if { [regexp $expmsg $comp_output] \ 457 && (($cmdret == 0) == ($opts(warning) != "")) } { 458 # We have the expected output from gas. 459 # Return if there's nothing more to do. 460 if { $opts(error) != "" || $program == "" } { 461 pass $testname 462 return 463 } 464 } else { 465 verbose -log "$exitstat with: <$comp_output>, expected: <$expmsg>" 466 467 fail $testname 468 return 469 } 470 } else { 471 catch {write_file dump.stderr "$comp_output"} write_output 472 if ![string match "" $write_output] then { 473 send_log "error writing dump.stderr: $write_output\n" 474 verbose "error writing dump.stderr: $write_output" 3 475 send_log "$comp_output\n" 476 verbose "$comp_output" 3 477 fail $testname 478 return 479 } 480 set stderrfile $srcdir/$subdir/$opts(stderr) 481 send_log "wrote pruned stderr to dump.stderr\n" 482 verbose "wrote pruned stderr to dump.stderr" 3 483 if { [regexp_diff "dump.stderr" "$stderrfile"] } then { 484 if { $opts(error) != "" } { 485 verbose -log "$exitstat with: <$comp_output>, expected: <$opts(error)>" 486 if [regexp $opts(error) $comp_output] { 487 pass $testname 488 return 489 } 490 } 491 fail $testname 492 verbose "pruned stderr is [file_contents "dump.stderr"]" 2 493 return 494 } 495 } 496 } 497 498 if { $program == "" } { 499 return 500 } 501 set progopts1 $opts($program) 502 eval set progopts \$[string toupper $program]FLAGS 503 eval set binary \$[string toupper $program] 504 505 if { [which $binary] == 0 } { 506 untested $testname 507 return 508 } 509 510 if { $progopts1 == "" } { set $progopts1 "-r" } 511 verbose "running $binary $progopts $progopts1" 3 512 513 # Objcopy, unlike the other two, won't send its output to stdout, 514 # so we have to run it specially. 515 set cmd "$binary $progopts $progopts1 dump.o > dump.out" 516 if { $program == "objcopy" } { 517 set cmd "$binary $progopts $progopts1 dump.o dump.out" 518 } 519 520 # Ensure consistent sorting of symbols 521 if {[info exists env(LC_ALL)]} { 522 set old_lc_all $env(LC_ALL) 523 } 524 set env(LC_ALL) "C" 525 send_log "$cmd\n" 526 catch "exec $cmd" comp_output 527 if {[info exists old_lc_all]} { 528 set env(LC_ALL) $old_lc_all 529 } else { 530 unset env(LC_ALL) 531 } 532 set comp_output [prune_warnings $comp_output] 533 if ![string match "" $comp_output] then { 534 send_log "$comp_output\n" 535 fail $testname 536 return 537 } 538 539 verbose_eval {[file_contents "dump.out"]} 3 540 if { [regexp_diff "dump.out" "${file}.d"] } then { 541 fail $testname 542 verbose "output is [file_contents "dump.out"]" 2 543 return 544 } 545 546 pass $testname 547} 548 549proc slurp_options { file } { 550 if [catch { set f [open $file r] } x] { 551 #perror "couldn't open `$file': $x" 552 perror "$x" 553 return -1 554 } 555 set opt_array {} 556 # whitespace expression 557 set ws {[ ]*} 558 set nws {[^ ]*} 559 # whitespace is ignored anywhere except within the options list; 560 # option names are alphabetic only 561 set pat "^#${ws}(\[a-zA-Z\]*)$ws:${ws}(.*)$ws\$" 562 while { [gets $f line] != -1 } { 563 set line [string trim $line] 564 # Whitespace here is space-tab. 565 if [regexp $pat $line xxx opt_name opt_val] { 566 # match! 567 lappend opt_array [list $opt_name $opt_val] 568 } else { 569 break 570 } 571 } 572 close $f 573 return $opt_array 574} 575 576proc objdump { opts } { 577 global OBJDUMP 578 global comp_output 579 global host_triplet 580 581 catch "exec $OBJDUMP $opts" comp_output 582 set comp_output [prune_warnings $comp_output] 583 verbose "objdump output=$comp_output\n" 3 584} 585 586proc objdump_start_no_subdir { prog opts } { 587 global OBJDUMP 588 global srcdir 589 global spawn_id 590 591 verbose "Starting $OBJDUMP $opts $prog" 2 592 catch { 593 spawn -noecho -nottyinit $srcdir/lib/run $OBJDUMP $opts $prog 594 } foo 595 if ![regexp {^[0-9]+} $foo] then { 596 perror "Can't run $prog: $foo" 597 } 598} 599 600proc objdump_finish { } { 601 global spawn_id 602 603 catch "close" 604 catch "wait" 605} 606 607# Default timeout is 10 seconds, loses on a slow machine. But some 608# configurations of dejagnu may override it. 609if {$timeout<120} then { set timeout 120 } 610 611expect_after -i { 612 timeout { perror "timeout" } 613 "virtual memory exhausted" { perror "virtual memory exhausted" } 614 buffer_full { perror "buffer full" } 615 eof { perror "eof" } 616} 617 618# regexp_diff, based on simple_diff taken from ld test suite 619# compares two files line-by-line 620# file1 contains strings, file2 contains regexps and #-comments 621# blank lines are ignored in either file 622# returns non-zero if differences exist 623# 624proc regexp_diff { file_1 file_2 } { 625 626 set eof -1 627 set end_1 0 628 set end_2 0 629 set differences 0 630 set diff_pass 0 631 632 if [file exists $file_1] then { 633 set file_a [open $file_1 r] 634 } else { 635 perror "$file_1 doesn't exist" 636 return 1 637 } 638 639 if [file exists $file_2] then { 640 set file_b [open $file_2 r] 641 } else { 642 perror "$file_2 doesn't exist" 643 close $file_a 644 return 1 645 } 646 647 verbose " Regexp-diff'ing: $file_1 $file_2" 2 648 649 while { 1 } { 650 set line_a "" 651 set line_b "" 652 while { [string length $line_a] == 0 } { 653 if { [gets $file_a line_a] == $eof } { 654 set end_1 1 655 break 656 } 657 } 658 while { [string length $line_b] == 0 || [string match "#*" $line_b] } { 659 if [ string match "#pass" $line_b ] { 660 set end_2 1 661 set diff_pass 1 662 break 663 } elseif [ string match "#..." $line_b ] { 664 if { [gets $file_b line_b] == $eof } { 665 set end_2 1 666 break 667 } 668 verbose "looking for \"^$line_b$\"" 3 669 while { ![regexp "^$line_b$" "$line_a"] } { 670 verbose "skipping \"$line_a\"" 3 671 if { [gets $file_a line_a] == $eof } { 672 set end_1 1 673 break 674 } 675 } 676 break 677 } 678 if { [gets $file_b line_b] == $eof } { 679 set end_2 1 680 break 681 } 682 } 683 684 if { $diff_pass } { 685 break 686 } elseif { $end_1 && $end_2 } { 687 break 688 } elseif { $end_1 } { 689 send_log "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1\n" 690 verbose "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1" 3 691 set differences 1 692 break 693 } elseif { $end_2 } { 694 send_log "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 695 verbose "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 3 696 set differences 1 697 break 698 } else { 699 verbose "regexp \"^$line_b$\"\nline \"$line_a\"" 3 700 if ![regexp "^$line_b$" "$line_a"] { 701 send_log "regexp_diff match failure\n" 702 send_log "regexp \"^$line_b$\"\nline \"$line_a\"\n" 703 verbose "regexp_diff match failure\n" 3 704 set differences 1 705 } 706 } 707 } 708 709 if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } { 710 send_log "$file_1 and $file_2 are different lengths\n" 711 verbose "$file_1 and $file_2 are different lengths" 3 712 set differences 1 713 } 714 715 close $file_a 716 close $file_b 717 718 return $differences 719} 720 721proc file_contents { filename } { 722 set file [open $filename r] 723 set contents [read $file] 724 close $file 725 return $contents 726} 727 728proc write_file { filename contents } { 729 set file [open $filename w] 730 puts $file "$contents" 731 close $file 732} 733 734proc verbose_eval { expr { level 1 } } { 735 global verbose 736 if $verbose>$level then { eval verbose "$expr" $level } 737} 738 739# This definition is taken from an unreleased version of DejaGnu. Once 740# that version gets released, and has been out in the world for a few 741# months at least, it may be safe to delete this copy. 742if ![string length [info proc prune_warnings]] { 743 # 744 # prune_warnings -- delete various system verbosities from TEXT. 745 # 746 # An example is: 747 # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9 748 # 749 # Sites with particular verbose os's may wish to override this in site.exp. 750 # 751 proc prune_warnings { text } { 752 # This is from sun4's. Do it for all machines for now. 753 # The "\\1" is to try to preserve a "\n" but only if necessary. 754 regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text 755 756 # It might be tempting to get carried away and delete blank lines, etc. 757 # Just delete *exactly* what we're ask to, and that's it. 758 return $text 759 } 760} 761