[perl5.git] / ext / B / t / assembler.t

#!./perl -w

=pod

=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm

=head2 Description

The general idea is to test by assembling a choice set of assembler
instructions, then disassemble them, and check that we've completed the
round trip. Also, error checking of Assembler.pm is tested by feeding
it assorted errors.

Since Assembler.pm likes to assemble a file, we comply by writing a
text file. This file contains three sections:

  testing operand categories
  use each opcode
  erronous assembler instructions

An "operand category" is identified by the suffix of the PUT_/GET_
subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
opcode C<ldsv> has operand category C<svindex>:

   insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];

Because Disassembler.pm also assumes input from a file, we write the
resulting object code to a file. And disassembled output is written to
yet another text file which is then compared to the original input.
(Erronous assembler instructions still generate code, but this is not
written to the object file; therefore disassembly bails out at the first
instruction in error.)

All files are kept in memory by using TIEHASH.


=head2 Caveats

An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
generates invalid object code will not be detected.

Due to the way this test has been set up, failure of a single test
could cause all subsequent tests to fail as well: After an unexpected
assembler error no output is written, and disassembled lines will be
out of sync for all lines thereafter.

Not all possibilities for writing a valid operand value can be tested
because disassembly results in a uniform representation.


=head2 Maintenance

New opcodes are added automatically.

A new operand category will cause this program to die ("no operand list
for XXX"). The cure is to add suitable entries to C<%goodlist> and
C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
happen that the corresponding assembly or disassembly subroutine is
missing.) Note that an empty array as a C<%goodlist> entry means that
opcodes of the operand category do not take an operand (and therefore the
corresponding entry in C<%badlist> should have one). An C<undef> entry
in C<%badlist> means that any value is acceptable (and thus there is no
way to cause an error).

Set C<$dbg> to debug this test.

=cut

package VirtFile;
use strict;

# Note: This is NOT a general purpose package. It implements
# sequential text and binary file i/o in a rather simple form.

sub TIEHANDLE($;$){
    my( $class, $data ) = @_;
    my $obj = { data => defined( $data ) ? $data : '',
                pos => 0 };
    return bless( $obj, $class );
}

sub PRINT($@){
    my( $self ) = shift;
    $self->{data} .= join( '', @_ );
}

sub WRITE($$;$$){
    my( $self, $buf, $len, $offset ) = @_;
    unless( defined( $len ) ){
	$len = length( $buf );
        $offset = 0;
    }
    unless( defined( $offset ) ){
        $offset = 0;
    }
    $self->{data} .= substr( $buf, $offset, $len );
    return $len;
}


sub GETC($){
    my( $self ) = @_;
    return undef() if $self->{pos} >= length( $self->{data} );
    return substr( $self->{data}, $self->{pos}++, 1 );
}

sub READLINE($){
    my( $self ) = @_;
    return undef() if $self->{pos} >= length( $self->{data} );
    my $lfpos = index( $self->{data}, "\n", $self->{pos} );
    if( $lfpos < 0 ){
        $lfpos = length( $self->{data} );
    }
    my $pos = $self->{pos};
    $self->{pos} = $lfpos + 1;
    return substr( $self->{data}, $pos, $self->{pos} - $pos );
}

sub READ($@){
    my $self = shift();
    my $bufref = \$_[0];
    my( undef, $len, $offset ) = @_;
    if( $offset ){
        die( "offset beyond end of buffer\n" )
          if ! defined( $$bufref ) || $offset > length( $$bufref );
    } else {
        $$bufref = '';
        $offset = 0;
    }
    my $remlen = length( $self->{data} ) - $self->{pos};
    $len = $remlen if $remlen < $len;
    return 0 unless $len;
    substr( $$bufref, $offset, $len ) =
      substr( $self->{data}, $self->{pos}, $len );
    $self->{pos} += $len;
    return $len;
}

sub TELL($){
    my $self = shift();
    return $self->{pos};
}

sub CLOSE($){
    my( $self ) = @_;
    $self->{pos} = 0;
}

1;

package main;

use strict;
use Test::More;
use Config qw(%Config);

BEGIN {
  if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
    print "1..0 # Skip -- Perl configured without ByteLoader module\n";
    exit 0;
  }
  print "1..0\n"; exit 0;
}

use B::Asmdata      qw( %insn_data );
use B::Assembler    qw( &assemble_fh );
use B::Disassembler qw( &disassemble_fh &get_header );

my( %opsByType, @code2name );
my( $lineno, $dbg, $firstbadline, @descr );
$dbg = 0; # debug switch

# $SIG{__WARN__} handler to catch Assembler error messages
#
my $warnmsg;
sub catchwarn($){
    $warnmsg = $_[0];
    print "error: $warnmsg\n" if $dbg;
}

# Callback for writing assembled bytes. This is where we check
# that we do get an error.
#
sub putobj($){
    if( ++$lineno >= $firstbadline ){
        ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
        undef( $warnmsg );
    } else {
        my $l = syswrite( OBJ, $_[0] );
    }
}

# Callback for writing a disassembled statement.
#
sub putdis(@){
    my $line = join( ' ', @_ );
    ++$lineno;
    print DIS "$line\n";
    printf "%5d %s\n", $lineno, $line if $dbg;
}

# Generate assembler instructions from a hash of operand types: each
# existing entry contains a list of good or bad operand values. The
# corresponding opcodes can be found in %opsByType.
#
sub gen_type($$$){
    my( $href, $descref, $text ) = @_;
    for my $odt ( sort( keys( %opsByType ) ) ){
        my $opcode = $opsByType{$odt}->[0];
	my $sel = $odt;
	$sel =~ s/^GET_//;
	die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
        if( defined( $href->{$sel} ) ){
            if( @{$href->{$sel}} ){
		for my $od ( @{$href->{$sel}} ){
		    ++$lineno;
                    $descref->[$lineno] = "$text: $code2name[$opcode] $od";
		    print ASM "$code2name[$opcode] $od\n";
		    printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
		}
	    } else {
		++$lineno;
                $descref->[$lineno] = "$text: $code2name[$opcode]";
		print ASM "$code2name[$opcode]\n";
		printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
	    }
	}
    }
}

# Interesting operand values
#
my %goodlist = (
comment_t   => [ '"a comment"' ],  # no \n
none        => [],
svindex     => [ 0x7fffffff, 0 ],
opindex     => [ 0x7fffffff, 0 ],
pvindex     => [ 0x7fffffff, 0 ],
U32         => [ 0xffffffff, 0 ],
U8          => [ 0xff, 0 ],
PV          => [ '""', '"a string"', ],
I32         => [ -0x80000000, 0x7fffffff ],
IV64        => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats  0x%09x
IV          => $Config{ivsize} == 4 ?
               [ -0x80000000, 0x7fffffff ] :
               [ '0x000000000', '0x0ffffffff', '0x000000001' ],
NV          => [ 1.23456789E3 ],
U16         => [ 0xffff, 0 ],
pvcontents  => [],
strconst    => [ '""', '"another string"' ], # no NUL
op_tr_array => [ join( ',', 0..255 ) ],
	      );

# Erronous operand values
#
my %badlist = (
comment_t   => [ '"multi-line\ncomment"' ],  # no \n
none        => [ '"spurious arg"'  ],
svindex     => [ 0xffffffff * 2, -1 ],
opindex     => [ 0xffffffff * 2, -2 ],
pvindex     => [ 0xffffffff * 2, -3 ],
U32         => [ 0xffffffff * 2, -4 ],
U16         => [ 0x5ffff, -5 ],
U8          => [ 0x6ff, -6 ],
PV          => [ 'no quote"' ],
I32         => [ -0x80000001, 0x80000000 ],
IV64        => undef, # PUT_IV64 doesn't check - no integrity there
IV          => $Config{ivsize} == 4 ?
               [ -0x80000001, 0x80000000 ] : undef,
NV          => undef, # PUT_NV accepts anything - it shouldn't, real-ly
pvcontents  => [ '"spurious arg"' ],
strconst    => [  'no quote"',  '"with NUL '."\0".' char"' ], # no NUL
op_tr_array => [ join( ',', 1..42 ) ],
	      );


# Determine all operand types from %Asmdata::insn_data
#
for my $opname ( keys( %insn_data ) ){
    my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
    push( @{$opsByType{$getname}}, $opcode );
    $code2name[$opcode] = $opname;
}


# Write instruction(s) for correct operand values each operand type class
#
$lineno = 0;
tie( *ASM, 'VirtFile' );
gen_type( \%goodlist, \@descr, 'round trip' );

# Write one instruction for each opcode.
#
for my $opcode ( 0..$#code2name ){
    next unless defined( $code2name[$opcode] );
    my $sel = $insn_data{$code2name[$opcode]}->[2];
    $sel =~ s/^GET_//;
    die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
    if( defined( $goodlist{$sel} ) ){
        ++$lineno;
        if( @{$goodlist{$sel}} ){
            my $od = $goodlist{$sel}[0];
            $descr[$lineno] = "round trip: $code2name[$opcode] $od";
            print ASM "$code2name[$opcode] $od\n";
            printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
        } else {
            $descr[$lineno] = "round trip: $code2name[$opcode]";
            print ASM "$code2name[$opcode]\n";
            printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
	}
    }
} 

# Write instruction(s) for incorrect operand values each operand type class
#
$firstbadline = $lineno + 1;
gen_type( \%badlist, \@descr, 'asm error' );

# invalid opcode is an odd-man-out ;-)
#
++$lineno;
$descr[$lineno] = "asm error: Gollum";
print ASM "Gollum\n";
printf "%5d %s\n", $lineno, 'Gollum' if $dbg;

close( ASM );

# Now that we have defined all of our tests: plan
#
plan( tests => $lineno );
print "firstbadline=$firstbadline\n" if $dbg;

# assemble (guard against warnings and death from assembly errors)
#
$SIG{'__WARN__'} = \&catchwarn;

$lineno = -1; # account for the assembly header
tie( *OBJ, 'VirtFile' );
eval { assemble_fh( \*ASM, \&putobj ); };
print "eval: $@" if $dbg;
close( ASM );
close( OBJ );
$SIG{'__WARN__'} = 'DEFAULT';

# disassemble
#
print "--- disassembling ---\n" if $dbg;
$lineno = 0;
tie( *DIS, 'VirtFile' );
disassemble_fh( \*OBJ, \&putdis );
close( OBJ );
close( DIS );

# get header (for debugging only)
#
if( $dbg ){
    my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
        get_header();
    printf "Magic:        0x%08x\n", $magic;
    print  "Architecture: $archname\n";
    print  "Byteloader V: $blversion\n";
    print  "ivsize:       $ivsize\n";
    print  "ptrsize:      $ptrsize\n";
    print  "Byteorder:    $byteorder\n";
}

# check by comparing files line by line
#
print "--- checking ---\n" if $dbg;
$lineno = 0;
my( $asmline, $disline );
while( defined( $asmline = <ASM> ) ){
    $disline = <DIS>;
    ++$lineno;
    last if $lineno eq $firstbadline; # bail out where errors begin
    ok( $asmline eq $disline, $descr[$lineno] );
    printf "%5d %s\n", $lineno, $asmline if $dbg;
}
close( ASM );
close( DIS );

__END__
Commit	Line	Data
f4abc3e7 JH	1	#!./perl -w
	2
	3	=pod
	4
	5	=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
	6
	7	=head2 Description
	8
	9	The general idea is to test by assembling a choice set of assembler
	10	instructions, then disassemble them, and check that we've completed the
	11	round trip. Also, error checking of Assembler.pm is tested by feeding
	12	it assorted errors.
	13
	14	Since Assembler.pm likes to assemble a file, we comply by writing a
	15	text file. This file contains three sections:
	16
	17	testing operand categories
	18	use each opcode
	19	erronous assembler instructions
	20
	21	An "operand category" is identified by the suffix of the PUT_/GET_
	22	subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
	23	opcode C<ldsv> has operand category C<svindex>:
	24
	25	insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
	26
	27	Because Disassembler.pm also assumes input from a file, we write the
	28	resulting object code to a file. And disassembled output is written to
	29	yet another text file which is then compared to the original input.
	30	(Erronous assembler instructions still generate code, but this is not
	31	written to the object file; therefore disassembly bails out at the first
	32	instruction in error.)
	33
	34	All files are kept in memory by using TIEHASH.
	35
	36
	37	=head2 Caveats
	38
	39	An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
	40	generates invalid object code will not be detected.
	41
	42	Due to the way this test has been set up, failure of a single test
	43	could cause all subsequent tests to fail as well: After an unexpected
	44	assembler error no output is written, and disassembled lines will be
	45	out of sync for all lines thereafter.
	46
	47	Not all possibilities for writing a valid operand value can be tested
	48	because disassembly results in a uniform representation.
	49
	50
	51	=head2 Maintenance
	52
	53	New opcodes are added automatically.
	54
	55	A new operand category will cause this program to die ("no operand list
	56	for XXX"). The cure is to add suitable entries to C<%goodlist> and
	57	C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
	58	happen that the corresponding assembly or disassembly subroutine is
	59	missing.) Note that an empty array as a C<%goodlist> entry means that
	60	opcodes of the operand category do not take an operand (and therefore the
	61	corresponding entry in C<%badlist> should have one). An C<undef> entry
	62	in C<%badlist> means that any value is acceptable (and thus there is no
	63	way to cause an error).
	64
65	Set C<$dbg> to debug this test.
66
67	=cut
68
69	package VirtFile;
70	use strict;
71
72	# Note: This is NOT a general purpose package. It implements
73	# sequential text and binary file i/o in a rather simple form.
74
75	sub TIEHANDLE($;$){
76	my( $class, $data ) = @_;
77	my $obj = { data => defined( $data ) ? $data : '',
78	pos => 0 };
79	return bless( $obj, $class );
80	}
81
82	sub PRINT($@){
83	my( $self ) = shift;
84	$self->{data} .= join( '', @_ );
85	}
86
87	sub WRITE($$;$$){
88	my( $self, $buf, $len, $offset ) = @_;
89	unless( defined( $len ) ){
90	$len = length( $buf );
91	$offset = 0;
92	}
93	unless( defined( $offset ) ){
94	$offset = 0;
95	}
96	$self->{data} .= substr( $buf, $offset, $len );
97	return $len;
98	}
99
100
101	sub GETC($){
102	my( $self ) = @_;
103	return undef() if $self->{pos} >= length( $self->{data} );
104	return substr( $self->{data}, $self->{pos}++, 1 );
105	}
106
107	sub READLINE($){
108	my( $self ) = @_;
109	return undef() if $self->{pos} >= length( $self->{data} );
110	my $lfpos = index( $self->{data}, "\n", $self->{pos} );
111	if( $lfpos < 0 ){
112	$lfpos = length( $self->{data} );
113	}
114	my $pos = $self->{pos};
115	$self->{pos} = $lfpos + 1;
116	return substr( $self->{data}, $pos, $self->{pos} - $pos );
117	}
118
119	sub READ($@){
120	my $self = shift();
121	my $bufref = \$_[0];
122	my( undef, $len, $offset ) = @_;
123	if( $offset ){
124	die( "offset beyond end of buffer\n" )
125	if ! defined( $$bufref ) \|\| $offset > length( $$bufref );
126	} else {
127	$$bufref = '';
128	$offset = 0;
129	}
130	my $remlen = length( $self->{data} ) - $self->{pos};
131	$len = $remlen if $remlen < $len;
132	return 0 unless $len;
133	substr( $$bufref, $offset, $len ) =
134	substr( $self->{data}, $self->{pos}, $len );
135	$self->{pos} += $len;
136	return $len;
137	}
138
139	sub TELL($){
140	my $self = shift();
141	return $self->{pos};
142	}
143
144	sub CLOSE($){
145	my( $self ) = @_;
146	$self->{pos} = 0;
147	}
148
149	1;
150
151	package main;
152
153	use strict;
154	use Test::More;
155	use Config qw(%Config);
156
ff924b36 CB	157	BEGIN {
	158	if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
	159	print "1..0 # Skip -- Perl configured without ByteLoader module\n";
	160	exit 0;
	161	}
dc9e9a31	162	print "1..0\n"; exit 0;
ff924b36 CB	163	}
ff924b36 CB	164
f4abc3e7 JH	165	use B::Asmdata qw( %insn_data );
	166	use B::Assembler qw( &assemble_fh );
	167	use B::Disassembler qw( &disassemble_fh &get_header );
	168
	169	my( %opsByType, @code2name );
	170	my( $lineno, $dbg, $firstbadline, @descr );
	171	$dbg = 0; # debug switch
	172
	173	# $SIG{__WARN__} handler to catch Assembler error messages
	174	#
	175	my $warnmsg;
	176	sub catchwarn($){
	177	$warnmsg = $_[0];
	178	print "error: $warnmsg\n" if $dbg;
	179	}
	180
	181	# Callback for writing assembled bytes. This is where we check
	182	# that we do get an error.
	183	#
	184	sub putobj($){
	185	if( ++$lineno >= $firstbadline ){
	186	ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
	187	undef( $warnmsg );
	188	} else {
	189	my $l = syswrite( OBJ, $_[0] );
	190	}
	191	}
	192
	193	# Callback for writing a disassembled statement.
	194	#
	195	sub putdis(@){
	196	my $line = join( ' ', @_ );
	197	++$lineno;
	198	print DIS "$line\n";
	199	printf "%5d %s\n", $lineno, $line if $dbg;
	200	}
	201
	202	# Generate assembler instructions from a hash of operand types: each
	203	# existing entry contains a list of good or bad operand values. The
	204	# corresponding opcodes can be found in %opsByType.
	205	#
	206	sub gen_type($$$){
	207	my( $href, $descref, $text ) = @_;
e53790c1	208	for my $odt ( sort( keys( %opsByType ) ) ){
f4abc3e7 JH	209	my $opcode = $opsByType{$odt}->[0];
	210	my $sel = $odt;
	211	$sel =~ s/^GET_//;
	212	die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
	213	if( defined( $href->{$sel} ) ){
	214	if( @{$href->{$sel}} ){
	215	for my $od ( @{$href->{$sel}} ){
	216	++$lineno;
	217	$descref->[$lineno] = "$text: $code2name[$opcode] $od";
	218	print ASM "$code2name[$opcode] $od\n";
	219	printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
	220	}
	221	} else {
	222	++$lineno;
	223	$descref->[$lineno] = "$text: $code2name[$opcode]";
	224	print ASM "$code2name[$opcode]\n";
	225	printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
	226	}
	227	}
	228	}
	229	}
	230
	231	# Interesting operand values
	232	#
	233	my %goodlist = (
	234	comment_t => [ '"a comment"' ], # no \n
	235	none => [],
	236	svindex => [ 0x7fffffff, 0 ],
	237	opindex => [ 0x7fffffff, 0 ],
	238	pvindex => [ 0x7fffffff, 0 ],
	239	U32 => [ 0xffffffff, 0 ],
	240	U8 => [ 0xff, 0 ],
	241	PV => [ '""', '"a string"', ],
	242	I32 => [ -0x80000000, 0x7fffffff ],
	243	IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
	244	IV => $Config{ivsize} == 4 ?
	245	[ -0x80000000, 0x7fffffff ] :
	246	[ '0x000000000', '0x0ffffffff', '0x000000001' ],
	247	NV => [ 1.23456789E3 ],
	248	U16 => [ 0xffff, 0 ],
	249	pvcontents => [],
	250	strconst => [ '""', '"another string"' ], # no NUL
	251	op_tr_array => [ join( ',', 0..255 ) ],
	252	);
	253
	254	# Erronous operand values
	255	#
	256	my %badlist = (
	257	comment_t => [ '"multi-line\ncomment"' ], # no \n
	258	none => [ '"spurious arg"' ],
	259	svindex => [ 0xffffffff * 2, -1 ],
	260	opindex => [ 0xffffffff * 2, -2 ],
	261	pvindex => [ 0xffffffff * 2, -3 ],
	262	U32 => [ 0xffffffff * 2, -4 ],
	263	U16 => [ 0x5ffff, -5 ],
	264	U8 => [ 0x6ff, -6 ],
	265	PV => [ 'no quote"' ],
	266	I32 => [ -0x80000001, 0x80000000 ],
	267	IV64 => undef, # PUT_IV64 doesn't check - no integrity there
	268	IV => $Config{ivsize} == 4 ?
	269	[ -0x80000001, 0x80000000 ] : undef,
	270	NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
	271	pvcontents => [ '"spurious arg"' ],
	272	strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
273	op_tr_array => [ join( ',', 1..42 ) ],
274	);
275
276
277	# Determine all operand types from %Asmdata::insn_data
278	#
279	for my $opname ( keys( %insn_data ) ){
280	my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
281	push( @{$opsByType{$getname}}, $opcode );
282	$code2name[$opcode] = $opname;
283	}
284
285
286	# Write instruction(s) for correct operand values each operand type class
287	#
288	$lineno = 0;
289	tie( *ASM, 'VirtFile' );
290	gen_type( \%goodlist, \@descr, 'round trip' );
291
292	# Write one instruction for each opcode.
293	#
294	for my $opcode ( 0..$#code2name ){
295	next unless defined( $code2name[$opcode] );
296	my $sel = $insn_data{$code2name[$opcode]}->[2];
297	$sel =~ s/^GET_//;
298	die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
299	if( defined( $goodlist{$sel} ) ){
300	++$lineno;
301	if( @{$goodlist{$sel}} ){
302	my $od = $goodlist{$sel}[0];
303	$descr[$lineno] = "round trip: $code2name[$opcode] $od";
304	print ASM "$code2name[$opcode] $od\n";
305	printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
306	} else {
307	$descr[$lineno] = "round trip: $code2name[$opcode]";
308	print ASM "$code2name[$opcode]\n";
309	printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
310	}
311	}
312	}
313
314	# Write instruction(s) for incorrect operand values each operand type class
315	#
316	$firstbadline = $lineno + 1;
317	gen_type( \%badlist, \@descr, 'asm error' );
318
319	# invalid opcode is an odd-man-out ;-)
320	#
321	++$lineno;
322	$descr[$lineno] = "asm error: Gollum";
323	print ASM "Gollum\n";
324	printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
325
326	close( ASM );
327
328	# Now that we have defined all of our tests: plan
329	#
330	plan( tests => $lineno );
331	print "firstbadline=$firstbadline\n" if $dbg;
332
333	# assemble (guard against warnings and death from assembly errors)
334	#
335	$SIG{'__WARN__'} = \&catchwarn;
336
337	$lineno = -1; # account for the assembly header
338	tie( *OBJ, 'VirtFile' );
339	eval { assemble_fh( \*ASM, \&putobj ); };
340	print "eval: $@" if $dbg;
341	close( ASM );
342	close( OBJ );
343	$SIG{'__WARN__'} = 'DEFAULT';
344
345	# disassemble
346	#
347	print "--- disassembling ---\n" if $dbg;
348	$lineno = 0;
349	tie( *DIS, 'VirtFile' );
350	disassemble_fh( \*OBJ, \&putdis );
351	close( OBJ );
352	close( DIS );
353
354	# get header (for debugging only)
355	#
356	if( $dbg ){
357	my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
358	get_header();
359	printf "Magic: 0x%08x\n", $magic;
360	print "Architecture: $archname\n";
361	print "Byteloader V: $blversion\n";
362	print "ivsize: $ivsize\n";
363	print "ptrsize: $ptrsize\n";
364	print "Byteorder: $byteorder\n";
365	}
366
367	# check by comparing files line by line
368	#
369	print "--- checking ---\n" if $dbg;
370	$lineno = 0;
371	my( $asmline, $disline );
372	while( defined( $asmline = <ASM> ) ){
373	$disline = <DIS>;
374	++$lineno;
375	last if $lineno eq $firstbadline; # bail out where errors begin
376	ok( $asmline eq $disline, $descr[$lineno] );
377	printf "%5d %s\n", $lineno, $asmline if $dbg;
378	}
379	close( ASM );
380	close( DIS );
381
382	__END__