[thirdparty/binutils-gdb.git] / binutils / testsuite / lib / binutils-common.exp

# Copyright (C) 1993-2018 Free Software Foundation, Inc.
#
# This file is part of the GNU Binutils.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston,
# MA 02110-1301, USA.

# True if the object format is known to be ELF.
#
proc is_elf_format {} {
    # config.sub for these targets curiously transforms a target doublet
    # ending in -elf to -none.  eg. m68hc12-elf to m68hc12-unknown-none
    # They are always elf.
    if { [istarget m68hc1*-*] || [istarget s12z*-*] || [istarget xgate-*] } {
	return 1;
    }
# vxworks (and windiss) excluded due to number of ELF tests that need
# modifying to pass on those targets.
#	 && ![istarget *-*-vxworks*]
#	 && ![istarget *-*-windiss*]

    if {    ![istarget *-*-chorus*]
	 && ![istarget *-*-cloudabi*]
	 && ![istarget *-*-eabi*]
	 && ![istarget *-*-*elf*]
	 && ![istarget *-*-*freebsd*]
	 && ![istarget *-*-fuchsia*]
	 && ![istarget *-*-gnu*]
	 && ![istarget *-*-irix5*]
	 && ![istarget *-*-irix6*]
	 && ![istarget *-*-kaos*]
	 && ![istarget *-*-*linux*]
	 && ![istarget *-*-lynxos*]
	 && ![istarget *-*-nacl*]
	 && ![istarget *-*-netbsd*]
	 && ![istarget *-*-nto*]
	 && ![istarget *-*-openbsd*]
	 && ![istarget *-*-rtems*]
	 && ![istarget *-*-solaris2*]
	 && ![istarget *-*-sysv4*]
	 && ![istarget *-*-unixware*]
	 && ![istarget *-*-wasm32*]
	 && ![istarget avr-*-*]
	 && ![istarget hppa*64*-*-hpux*]
	 && ![istarget ia64-*-hpux*] } {
	return 0
    }

    if { [istarget *-*-linux*ecoff*]
	 || [istarget *-*-rtemscoff*] } {
	return 0
    }

    if { ![istarget *-*-netbsdelf*]
	 && (   [istarget vax-*-netbsd*]
	     || [istarget ns32k-*-netbsd*]) } {
    	return 0
    }

    if {    [istarget arm-*-openbsd*]
	 || [istarget ns32k-*-openbsd*]
	 || [istarget vax-*-openbsd*] } {
	return 0
    }

    return 1
}

# True if the object format is known to be a.out.
#
proc is_aout_format {} {
    if { [istarget *-*-*aout*]
	 || [istarget *-*-bsd*]
	 || [istarget *-*-msdos*]
	 || [istarget ns32k-*-*]
	 || [istarget pdp11-*-*]
	 || [istarget vax-*-netbsd] } {
	return 1
    }
    return 0
}

# True if the object format is known to be PE COFF.
#
proc is_pecoff_format {} {
    if { ![istarget *-*-mingw*]
	 && ![istarget *-*-cygwin*]
	 && ![istarget *-*-cegcc*]
	 && ![istarget *-*-pe*] } {
	return 0
    }

    return 1
}

# True if the object format is known to be 64-bit ELF.
#
proc is_elf64 { binary_file } {
    global READELF
    global READELFFLAGS

    set tmpfile [file dirname $binary_file]/readelf.out
    set readelf_size ""
    catch "exec $READELF $READELFFLAGS -h $binary_file > $tmpfile" got

    if ![string match "" $got] then {
	return 0
    }

    if { ![regexp "\n\[ \]*Class:\[ \]*ELF(\[0-9\]+)\n" \
	   [file_contents $tmpfile] nil readelf_size] } {
	return 0
    }

    if { $readelf_size == "64" } {
	return 1
    }

    return 0
}

# True if the object format is known to use RELA relocations.
#
proc is_rela { binary_file } {
    global READELF
    global READELFFLAGS

    set tmpfile [file dirname $binary_file]/readelf.out
    catch "exec $READELF $READELFFLAGS -S $binary_file > $tmpfile" got

    if ![string match "" $got] then {
	return 0
    }

    if { ![regexp "RELA" [file_contents $tmpfile]] } {
	return 0
    }

    return 1
}

# True if the target matches TARGET, specified as a TCL procedure if
# in square brackets or as machine triplet otherwise.
#
proc match_target { target } {
   if [string match {\[*\]} $target] {
	return $target
   } else {
	return [istarget $target]
   }
}

# True if the ELF target supports STB_GNU_UNIQUE with the ELF header's
# OSABI field set to ELFOSABI_GNU.
#
# This generally depends on the target OS only, however there are a
# number of exceptions for bare metal targets as follows.  The MSP430
# and Visium targets set OSABI to ELFOSABI_STANDALONE and cannot
# support STB_GNU_UNIQUE.  Likewise non-EABI ARM targets set OSABI to
# ELFOSABI_ARM, and TI C6X targets to ELFOSABI_C6000_*.  Finally
# rather than `bfd_elf_final_link' AM33/2.0, D30V, DLX, and
# picoJava targets use `_bfd_generic_final_link', which does not
# support STB_GNU_UNIQUE symbol binding causing assertion failures.
#
proc supports_gnu_unique {} {
    if { [istarget *-*-gnu*]
	 || [istarget *-*-linux*]
	 || [istarget *-*-nacl*] } {
	return 1
    }
    if { [istarget "arm*-*-*eabi*"] } {
	return 1
    }
    if { [istarget "wasm32*-*-*"] } {
        return 1
    }
    if { ![istarget "*-*-elf*"] } {
	return 0
    }
    if { [istarget "arm*-*-*"]
	 || [istarget "msp430-*-*"]
	 || [istarget "tic6x-*-*"]
	 || [istarget "visium-*-*"] } {
	return 0
    }
    if { [istarget "am33_2.0-*-*"]
	 || [istarget "d30v-*-*"]
	 || [istarget "dlx-*-*"]
	 || [istarget "pj*-*-*"]
	 || [istarget "xgate-*-*"] } {
	return 0
    }
    return 1
}

# True for targets that do not sort .symtab as per the ELF standard.
# ie. any that have mips_elf32_be_vec, mips_elf32_le_vec,
# mips_elf32_n_be_vec or mips_elf32_n_le_vec as the primary bfd target
# vector in config.bfd.  When syncing with config.bfd, don't forget that
# earlier case-matches trump later ones.
proc is_bad_symtab {} {
    if { ![istarget "mips*-*-*"] } {
	return 0;
    }
    if { [istarget "*-*-chorus*"]
	 || [istarget "*-*-irix5*"]
	 || [istarget "*-*-irix6*"]
	 || [istarget "*-*-none"]
	 || [istarget "*-*-rtems*"]
	 || [istarget "*-*-windiss"] } {
	return 1;
    }
    if { [istarget "*-*-elf*"]
	 && ![istarget "*-sde-*"]
	 && ![istarget "*-mti-*"]
	 && ![istarget "*-img-*"] } {
	return 1;
    }
    if { [istarget "*-*-openbsd*"]
	 && ![istarget "mips64*-*-*"] } {
	return 1;
    }
    return 0;
}

# Compare two files line-by-line.  FILE_1 is the actual output and FILE_2
# is the expected output.  Ignore blank lines in either file.
#
# FILE_2 is a series of regexps, comments and # directives.  The directives
# are:
#
#    #pass
#        Treat the test as a PASS if everything up till this point has
#        matched.  Ignore any remaining lines in either FILE_1 or FILE_2.
#
#    #failif
#        Reverse the sense of the test: expect differences to exist.
#
#    #...
#    REGEXP
#        Skip all lines in FILE_1 until the first that matches REGEXP.
#
# Other # lines are comments.  Regexp lines starting with the `!' character
# specify inverse matching (use `\!' for literal matching against a leading
# `!').  Skip empty lines in both files.
#
# The first optional argument is a list of regexp substitutions of the form:
#
#    EXP1 SUBSPEC1 EXP2 SUBSPEC2 ...
#
# This tells the function to apply each regexp substitution EXPi->SUBSPECi
# in order to every line of FILE_2.
#
# Return nonzero if differences exist.
proc regexp_diff { file_1 file_2 args } {
    set eof -1
    set end_1 0
    set end_2 0
    set differences 0
    set diff_pass 0
    set fail_if_match 0
    set ref_subst ""
    if { [llength $args] > 0 } {
	set ref_subst [lindex $args 0]
    }
    if { [llength $args] > 1 } {
	perror "Too many arguments to regexp_diff"
	return 1
    }

    if [file exists $file_1] then {
	set file_a [open $file_1 r]
    } else {
	perror "$file_1 doesn't exist"
	return 1
    }

    if [file exists $file_2] then {
	set file_b [open $file_2 r]
    } else {
	perror "$file_2 doesn't exist"
	close $file_a
	return 1
    }

    verbose " Regexp-diff'ing: $file_1 $file_2" 2

    while { 1 } {
	set line_a ""
	set line_b ""
	while { [string length $line_a] == 0 } {
	    # Ignore blank line in FILE_1.
	    if { [gets $file_a line_a] == $eof } {
		set end_1 1
		break
	    }
	}
	while { [string length $line_b] == 0 || [string match "#*" $line_b] } {
	    if { [string match "#pass" $line_b] } {
		set end_2 1
		set diff_pass 1
		break
	    } elseif { [string match "#failif" $line_b] } {
		send_log "fail if no difference\n"
		verbose "fail if no difference" 3
		set fail_if_match 1
	    } elseif { [string match "#..." $line_b] } {
		if { [gets $file_b line_b] == $eof } {
		    set end_2 1
		    set diff_pass 1
		    break
		}
		set negated [expr { [string index $line_b 0] == "!" }]
		set line_bx [string range $line_b $negated end]
		set n [expr { $negated ? "! " : "" }]
		# Substitute on the reference.
		foreach {name value} $ref_subst {
		    regsub -- $name $line_bx $value line_bx
		}
		verbose "looking for $n\"^$line_bx$\"" 3
		while { [expr [regexp "^$line_bx$" "$line_a"] == $negated] } {
		    verbose "skipping    \"$line_a\"" 3
		    if { [gets $file_a line_a] == $eof } {
			set end_1 1
			break
		    }
		}
		break
	    }
	    if { [gets $file_b line_b] == $eof } {
		set end_2 1
		break
	    }
	}

	if { $diff_pass } {
	    break
	} elseif { $end_1 && $end_2 } {
	    break
	} elseif { $end_1 } {
	    send_log "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1\n"
	    verbose "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1" 3
	    set differences 1
	    break
	} elseif { $end_2 } {
	    send_log "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n"
	    verbose "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 3
	    set differences 1
	    break
	} else {
	    set negated [expr { [string index $line_b 0] == "!" }]
	    set line_bx [string range $line_b $negated end]
	    set n [expr { $negated ? "! " : "" }]
	    set s [expr { $negated ? "  " : "" }]
	    # Substitute on the reference.
	    foreach {name value} $ref_subst {
		regsub -- $name $line_bx $value line_bx
	    }
	    verbose "regexp $n\"^$line_bx$\"\nline   \"$line_a\"" 3
	    if { [expr [regexp "^$line_bx$" "$line_a"] == $negated] } {
		send_log "regexp_diff match failure\n"
		send_log "regexp $n\"^$line_bx$\"\nline   $s\"$line_a\"\n"
		verbose "regexp_diff match failure\n" 3
		set differences 1
	    }
	}
    }

    if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } {
	send_log "$file_1 and $file_2 are different lengths\n"
	verbose "$file_1 and $file_2 are different lengths" 3
	set differences 1
    }

    if { $fail_if_match } {
	if { $differences == 0 } {
	    set differences 1
	} else {
	    set differences 0
	}
    }

    close $file_a
    close $file_b

    return $differences
}

# prune_warnings_extra -- delete extra warnings from TEXT.
#
# An example is:
# ld: warning: /lib64/ld-linux-x86-64.so.2: unsupported GNU_PROPERTY_TYPE (5) type : 0xc0010001
proc prune_warnings_extra { text } {
    global experimental
    # Warnings are only pruned from non-experimental code (ie code not
    # on a release branch).  For experimental code we want the warnings
    # as they indicate that the sources need to be updated to recognise
    # the new properties.
    if { "$experimental" == "false" } {
	# The "\\1" is to try to preserve a "\n" but only if necessary.
	regsub -all "(^|\n)(\[^\n\]*: warning:\[^\n\]*unsupported GNU_PROPERTY_TYPE\[^\n\]*\n?)+" $text "\\1" text
    }
    return $text
}

# This definition is taken from an unreleased version of DejaGnu.  Once
# that version gets released, and has been out in the world for a few
# months at least, it may be safe to delete this copy.
if ![string length [info proc prune_warnings]] {
    #
    # prune_warnings -- delete various system verbosities from TEXT
    #
    # An example is:
    # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
    #
    # Sites with particular verbose os's may wish to override this in site.exp.
    #
    proc prune_warnings { text } {
	# This is from sun4's.  Do it for all machines for now.
	# The "\\1" is to try to preserve a "\n" but only if necessary.
	regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
	# It might be tempting to get carried away and delete blank lines, etc.
	# Just delete *exactly* what we're ask to, and that's it.
	set text [prune_warnings_extra $text]
	return $text
    }
} elseif { [info procs saved-prune_warnings] == [list] } {
    rename prune_warnings saved-prune_warnings
    proc prune_warnings { text } {
	set text [saved-prune_warnings $text]
	set text [prune_warnings_extra $text]
	return $text
    }
}
Commit	Line	Data
219d1afa	1	# Copyright (C) 1993-2018 Free Software Foundation, Inc.
f3097f33 RS	2	#
	3	# This file is part of the GNU Binutils.
	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 3 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., 51 Franklin Street - Fifth Floor, Boston,
	18	# MA 02110-1301, USA.
	19
	20	# True if the object format is known to be ELF.
	21	#
	22	proc is_elf_format {} {
b3066ae8 AM	23	# config.sub for these targets curiously transforms a target doublet
	24	# ending in -elf to -none. eg. m68hc12-elf to m68hc12-unknown-none
	25	# They are always elf.
7b4ae824	26	if { [istarget m68hc1-] \|\| [istarget s12z-] \|\| [istarget xgate-*] } {
b3066ae8 AM	27	return 1;
b3066ae8 AM	28	}
679ca975 AM	29	# vxworks (and windiss) excluded due to number of ELF tests that need
	30	# modifying to pass on those targets.
	31	# && ![istarget --vxworks*]
	32	# && ![istarget --windiss*]
b3066ae8	33
679ca975 AM	34	if { ![istarget --chorus*]
	35	&& ![istarget --cloudabi*]
	36	&& ![istarget --eabi*]
	37	&& ![istarget --elf]
	38	&& ![istarget --freebsd]
	39	&& ![istarget --fuchsia*]
f3097f33	40	&& ![istarget --gnu*]
f3097f33 RS	41	&& ![istarget --irix5*]
f3097f33 RS	42	&& ![istarget --irix6*]
679ca975 AM	43	&& ![istarget --kaos*]
679ca975 AM	44	&& ![istarget --linux]
c43b2c54	45	&& ![istarget --lynxos*]
4a85cc09	46	&& ![istarget --nacl*]
f3097f33	47	&& ![istarget --netbsd*]
679ca975	48	&& ![istarget --nto*]
f3097f33	49	&& ![istarget --openbsd*]
4a85cc09 SKS	50	&& ![istarget --rtems*]
	51	&& ![istarget --solaris2*]
	52	&& ![istarget --sysv4*]
	53	&& ![istarget --unixware*]
f96bd6c2	54	&& ![istarget --wasm32*]
4a85cc09	55	&& ![istarget avr--]
4a85cc09	56	&& ![istarget hppa64--hpux]
679ca975	57	&& ![istarget ia64--hpux] } {
f3097f33 RS	58	return 0
	59	}
	60
c65c21e1 AM	61	if { [istarget --linuxecoff]
c65c21e1 AM	62	\|\| [istarget --rtemscoff*] } {
f3097f33 RS	63	return 0
	64	}
	65
	66	if { ![istarget --netbsdelf*]
c65c21e1	67	&& ( [istarget vax--netbsd]
f3097f33 RS	68	\|\| [istarget ns32k--netbsd]) } {
	69	return 0
	70	}
	71
4a85cc09	72	if { [istarget arm--openbsd]
f3097f33	73	\|\| [istarget ns32k--openbsd]
f3097f33 RS	74	\|\| [istarget vax--openbsd] } {
	75	return 0
	76	}
	77
	78	return 1
	79	}
	80
	81	# True if the object format is known to be a.out.
	82	#
	83	proc is_aout_format {} {
c65c21e1	84	if { [istarget --aout]
f3097f33 RS	85	\|\| [istarget --bsd*]
f3097f33 RS	86	\|\| [istarget --msdos*]
f3097f33 RS	87	\|\| [istarget ns32k--]
f3097f33 RS	88	\|\| [istarget pdp11--]
f3097f33 RS	89	\|\| [istarget vax-*-netbsd] } {
	90	return 1
	91	}
	92	return 0
	93	}
	94
	95	# True if the object format is known to be PE COFF.
	96	#
	97	proc is_pecoff_format {} {
	98	if { ![istarget --mingw*]
	99	&& ![istarget --cygwin*]
	100	&& ![istarget --cegcc*]
	101	&& ![istarget --pe*] } {
	102	return 0
	103	}
	104
	105	return 1
	106	}
	107
	108	# True if the object format is known to be 64-bit ELF.
	109	#
	110	proc is_elf64 { binary_file } {
	111	global READELF
	112	global READELFFLAGS
	113
506b86a4	114	set tmpfile [file dirname $binary_file]/readelf.out
f3097f33	115	set readelf_size ""
506b86a4	116	catch "exec $READELF $READELFFLAGS -h $binary_file > $tmpfile" got
f3097f33 RS	117
	118	if ![string match "" $got] then {
	119	return 0
	120	}
	121
	122	if { ![regexp "\n\[ \]Class:\[ \]ELF(\[0-9\]+)\n" \
506b86a4	123	[file_contents $tmpfile] nil readelf_size] } {
f3097f33 RS	124	return 0
	125	}
	126
	127	if { $readelf_size == "64" } {
	128	return 1
	129	}
	130
	131	return 0
	132	}
eb22018c	133
506b86a4 AM	134	# True if the object format is known to use RELA relocations.
	135	#
	136	proc is_rela { binary_file } {
	137	global READELF
	138	global READELFFLAGS
	139
	140	set tmpfile [file dirname $binary_file]/readelf.out
	141	catch "exec $READELF $READELFFLAGS -S $binary_file > $tmpfile" got
	142
	143	if ![string match "" $got] then {
	144	return 0
	145	}
	146
	147	if { ![regexp "RELA" [file_contents $tmpfile]] } {
	148	return 0
	149	}
	150
	151	return 1
	152	}
	153
6d9dabbb MR	154	# True if the target matches TARGET, specified as a TCL procedure if
	155	# in square brackets or as machine triplet otherwise.
	156	#
	157	proc match_target { target } {
	158	if [string match {\[*\]} $target] {
	159	return $target
	160	} else {
	161	return [istarget $target]
	162	}
	163	}
	164
a43942db MR	165	# True if the ELF target supports STB_GNU_UNIQUE with the ELF header's
	166	# OSABI field set to ELFOSABI_GNU.
	167	#
	168	# This generally depends on the target OS only, however there are a
	169	# number of exceptions for bare metal targets as follows. The MSP430
	170	# and Visium targets set OSABI to ELFOSABI_STANDALONE and cannot
	171	# support STB_GNU_UNIQUE. Likewise non-EABI ARM targets set OSABI to
	172	# ELFOSABI_ARM, and TI C6X targets to ELFOSABI_C6000_*. Finally
a8eb42a8	173	# rather than `bfd_elf_final_link' AM33/2.0, D30V, DLX, and
a43942db MR	174	# picoJava targets use `_bfd_generic_final_link', which does not
	175	# support STB_GNU_UNIQUE symbol binding causing assertion failures.
	176	#
	177	proc supports_gnu_unique {} {
	178	if { [istarget --gnu*]
	179	\|\| [istarget --linux*]
	180	\|\| [istarget --nacl*] } {
	181	return 1
	182	}
	183	if { [istarget "arm--eabi"] } {
	184	return 1
	185	}
f96bd6c2 PC	186	if { [istarget "wasm32--*"] } {
	187	return 1
	188	}
a43942db MR	189	if { ![istarget "--elf*"] } {
	190	return 0
	191	}
	192	if { [istarget "arm--*"]
	193	\|\| [istarget "msp430--"]
	194	\|\| [istarget "tic6x--"]
	195	\|\| [istarget "visium--"] } {
	196	return 0
	197	}
	198	if { [istarget "am33_2.0--"]
	199	\|\| [istarget "d30v--"]
	200	\|\| [istarget "dlx--"]
be570f06 AM	201	\|\| [istarget "pj--*"]
be570f06 AM	202	\|\| [istarget "xgate--"] } {
a43942db MR	203	return 0
	204	}
	205	return 1
	206	}
	207
9cc0123f AM	208	# True for targets that do not sort .symtab as per the ELF standard.
	209	# ie. any that have mips_elf32_be_vec, mips_elf32_le_vec,
	210	# mips_elf32_n_be_vec or mips_elf32_n_le_vec as the primary bfd target
	211	# vector in config.bfd. When syncing with config.bfd, don't forget that
	212	# earlier case-matches trump later ones.
	213	proc is_bad_symtab {} {
	214	if { ![istarget "mips--*"] } {
	215	return 0;
	216	}
	217	if { [istarget "--chorus*"]
	218	\|\| [istarget "--irix5*"]
	219	\|\| [istarget "--irix6*"]
	220	\|\| [istarget "--none"]
	221	\|\| [istarget "--rtems*"]
	222	\|\| [istarget "--windiss"] } {
	223	return 1;
	224	}
	225	if { [istarget "--elf*"]
	226	&& ![istarget "-sde-"]
	227	&& ![istarget "-mti-"]
	228	&& ![istarget "-img-"] } {
	229	return 1;
	230	}
	231	if { [istarget "--openbsd*"]
	232	&& ![istarget "mips64--*"] } {
	233	return 1;
	234	}
	235	return 0;
	236	}
	237
eb22018c RS	238	# Compare two files line-by-line. FILE_1 is the actual output and FILE_2
	239	# is the expected output. Ignore blank lines in either file.
	240	#
	241	# FILE_2 is a series of regexps, comments and # directives. The directives
	242	# are:
	243	#
	244	# #pass
	245	# Treat the test as a PASS if everything up till this point has
	246	# matched. Ignore any remaining lines in either FILE_1 or FILE_2.
	247	#
	248	# #failif
	249	# Reverse the sense of the test: expect differences to exist.
	250	#
	251	# #...
	252	# REGEXP
	253	# Skip all lines in FILE_1 until the first that matches REGEXP.
	254	#
738f4d98 MR	255	# Other # lines are comments. Regexp lines starting with the `!' character
	256	# specify inverse matching (use `\!' for literal matching against a leading
	257	# `!'). Skip empty lines in both files.
eb22018c RS	258	#
	259	# The first optional argument is a list of regexp substitutions of the form:
	260	#
	261	# EXP1 SUBSPEC1 EXP2 SUBSPEC2 ...
	262	#
	263	# This tells the function to apply each regexp substitution EXPi->SUBSPECi
	264	# in order to every line of FILE_2.
	265	#
	266	# Return nonzero if differences exist.
	267	proc regexp_diff { file_1 file_2 args } {
	268	set eof -1
	269	set end_1 0
	270	set end_2 0
	271	set differences 0
	272	set diff_pass 0
	273	set fail_if_match 0
	274	set ref_subst ""
	275	if { [llength $args] > 0 } {
	276	set ref_subst [lindex $args 0]
	277	}
	278	if { [llength $args] > 1 } {
	279	perror "Too many arguments to regexp_diff"
	280	return 1
	281	}
	282
	283	if [file exists $file_1] then {
	284	set file_a [open $file_1 r]
	285	} else {
	286	perror "$file_1 doesn't exist"
	287	return 1
	288	}
	289
	290	if [file exists $file_2] then {
	291	set file_b [open $file_2 r]
	292	} else {
	293	perror "$file_2 doesn't exist"
	294	close $file_a
	295	return 1
	296	}
	297
	298	verbose " Regexp-diff'ing: $file_1 $file_2" 2
	299
	300	while { 1 } {
	301	set line_a ""
	302	set line_b ""
	303	while { [string length $line_a] == 0 } {
	304	# Ignore blank line in FILE_1.
	305	if { [gets $file_a line_a] == $eof } {
	306	set end_1 1
	307	break
	308	}
	309	}
	310	while { [string length $line_b] == 0 \|\| [string match "#*" $line_b] } {
	311	if { [string match "#pass" $line_b] } {
	312	set end_2 1
	313	set diff_pass 1
	314	break
	315	} elseif { [string match "#failif" $line_b] } {
	316	send_log "fail if no difference\n"
	317	verbose "fail if no difference" 3
	318	set fail_if_match 1
	319	} elseif { [string match "#..." $line_b] } {
	320	if { [gets $file_b line_b] == $eof } {
	321	set end_2 1
322	set diff_pass 1
323	break
324	}
47a50e5b	325	set negated [expr { [string index $line_b 0] == "!" }]
738f4d98 MR	326	set line_bx [string range $line_b $negated end]
738f4d98 MR	327	set n [expr { $negated ? "! " : "" }]
eb22018c RS	328	# Substitute on the reference.
eb22018c RS	329	foreach {name value} $ref_subst {
738f4d98	330	regsub -- $name $line_bx $value line_bx
eb22018c	331	}
738f4d98 MR	332	verbose "looking for $n\"^$line_bx$\"" 3
738f4d98 MR	333	while { [expr [regexp "^$line_bx$" "$line_a"] == $negated] } {
eb22018c RS	334	verbose "skipping \"$line_a\"" 3
	335	if { [gets $file_a line_a] == $eof } {
	336	set end_1 1
	337	break
	338	}
	339	}
	340	break
	341	}
	342	if { [gets $file_b line_b] == $eof } {
	343	set end_2 1
	344	break
	345	}
	346	}
	347
	348	if { $diff_pass } {
	349	break
	350	} elseif { $end_1 && $end_2 } {
	351	break
	352	} elseif { $end_1 } {
	353	send_log "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1\n"
	354	verbose "extra regexps in $file_2 starting with \"^$line_b$\"\nEOF from $file_1" 3
	355	set differences 1
	356	break
	357	} elseif { $end_2 } {
	358	send_log "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n"
	359	verbose "extra lines in $file_1 starting with \"^$line_a$\"\nEOF from $file_2\n" 3
	360	set differences 1
	361	break
	362	} else {
47a50e5b	363	set negated [expr { [string index $line_b 0] == "!" }]
738f4d98 MR	364	set line_bx [string range $line_b $negated end]
	365	set n [expr { $negated ? "! " : "" }]
	366	set s [expr { $negated ? " " : "" }]
eb22018c RS	367	# Substitute on the reference.
eb22018c RS	368	foreach {name value} $ref_subst {
738f4d98	369	regsub -- $name $line_bx $value line_bx
eb22018c	370	}
738f4d98 MR	371	verbose "regexp $n\"^$line_bx$\"\nline \"$line_a\"" 3
738f4d98 MR	372	if { [expr [regexp "^$line_bx$" "$line_a"] == $negated] } {
eb22018c	373	send_log "regexp_diff match failure\n"
738f4d98	374	send_log "regexp $n\"^$line_bx$\"\nline $s\"$line_a\"\n"
eb22018c RS	375	verbose "regexp_diff match failure\n" 3
	376	set differences 1
	377	}
	378	}
	379	}
	380
	381	if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } {
	382	send_log "$file_1 and $file_2 are different lengths\n"
	383	verbose "$file_1 and $file_2 are different lengths" 3
	384	set differences 1
	385	}
	386
	387	if { $fail_if_match } {
	388	if { $differences == 0 } {
	389	set differences 1
	390	} else {
	391	set differences 0
	392	}
	393	}
	394
	395	close $file_a
	396	close $file_b
	397
	398	return $differences
	399	}
7dd36a6f L	400
	401	# prune_warnings_extra -- delete extra warnings from TEXT.
	402	#
	403	# An example is:
	404	# ld: warning: /lib64/ld-linux-x86-64.so.2: unsupported GNU_PROPERTY_TYPE (5) type : 0xc0010001
	405	proc prune_warnings_extra { text } {
	406	global experimental
	407	# Warnings are only pruned from non-experimental code (ie code not
	408	# on a release branch). For experimental code we want the warnings
	409	# as they indicate that the sources need to be updated to recognise
	410	# the new properties.
	411	if { "$experimental" == "false" } {
	412	# The "\\1" is to try to preserve a "\n" but only if necessary.
	413	regsub -all "(^\|\n)(\[^\n\]: warning:\[^\n\]unsupported GNU_PROPERTY_TYPE\[^\n\]*\n?)+" $text "\\1" text
	414	}
	415	return $text
	416	}
	417
	418	# This definition is taken from an unreleased version of DejaGnu. Once
	419	# that version gets released, and has been out in the world for a few
	420	# months at least, it may be safe to delete this copy.
	421	if ![string length [info proc prune_warnings]] {
	422	#
	423	# prune_warnings -- delete various system verbosities from TEXT
	424	#
	425	# An example is:
	426	# ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
	427	#
	428	# Sites with particular verbose os's may wish to override this in site.exp.
	429	#
	430	proc prune_warnings { text } {
	431	# This is from sun4's. Do it for all machines for now.
	432	# The "\\1" is to try to preserve a "\n" but only if necessary.
	433	regsub -all "(^\|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
	434	# It might be tempting to get carried away and delete blank lines, etc.
	435	# Just delete exactly what we're ask to, and that's it.
	436	set text [prune_warnings_extra $text]
	437	return $text
	438	}
	439	} elseif { [info procs saved-prune_warnings] == [list] } {
	440	rename prune_warnings saved-prune_warnings
	441	proc prune_warnings { text } {
	442	set text [saved-prune_warnings $text]
	443	set text [prune_warnings_extra $text]
	444	return $text
	445	}
	446	}