[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'} !~ /\bB\b/) ){
    print "1..0 # Skip -- Perl configured without B module\n";
    exit 0;
  }
  if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
    print "1..0 # Skip -- Perl configured without ByteLoader module\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( ',', 256, 0..255 ) ],
PADOFFSET   => undef,
long        => undef,
	      );

# 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 => undef, # op_pv_tr is no longer exactly 256 shorts
PADOFFSET   => undef,
long	     => undef,
	      );


# 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	157	BEGIN {
46b73616 MHM	158	if (($Config{'extensions'} !~ /\bB\b/) ){
	159	print "1..0 # Skip -- Perl configured without B module\n";
	160	exit 0;
	161	}
ff924b36 CB	162	if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
	163	print "1..0 # Skip -- Perl configured without ByteLoader module\n";
	164	exit 0;
	165	}
	166	}
	167
f4abc3e7 JH	168	use B::Asmdata qw( %insn_data );
	169	use B::Assembler qw( &assemble_fh );
	170	use B::Disassembler qw( &disassemble_fh &get_header );
	171
	172	my( %opsByType, @code2name );
	173	my( $lineno, $dbg, $firstbadline, @descr );
	174	$dbg = 0; # debug switch
	175
	176	# $SIG{__WARN__} handler to catch Assembler error messages
	177	#
	178	my $warnmsg;
	179	sub catchwarn($){
	180	$warnmsg = $_[0];
	181	print "error: $warnmsg\n" if $dbg;
	182	}
	183
	184	# Callback for writing assembled bytes. This is where we check
	185	# that we do get an error.
	186	#
	187	sub putobj($){
	188	if( ++$lineno >= $firstbadline ){
	189	ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
	190	undef( $warnmsg );
	191	} else {
	192	my $l = syswrite( OBJ, $_[0] );
	193	}
	194	}
	195
	196	# Callback for writing a disassembled statement.
	197	#
	198	sub putdis(@){
	199	my $line = join( ' ', @_ );
	200	++$lineno;
	201	print DIS "$line\n";
	202	printf "%5d %s\n", $lineno, $line if $dbg;
	203	}
	204
	205	# Generate assembler instructions from a hash of operand types: each
	206	# existing entry contains a list of good or bad operand values. The
	207	# corresponding opcodes can be found in %opsByType.
	208	#
	209	sub gen_type($$$){
	210	my( $href, $descref, $text ) = @_;
e53790c1	211	for my $odt ( sort( keys( %opsByType ) ) ){
f4abc3e7 JH	212	my $opcode = $opsByType{$odt}->[0];
	213	my $sel = $odt;
	214	$sel =~ s/^GET_//;
	215	die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
	216	if( defined( $href->{$sel} ) ){
	217	if( @{$href->{$sel}} ){
	218	for my $od ( @{$href->{$sel}} ){
	219	++$lineno;
	220	$descref->[$lineno] = "$text: $code2name[$opcode] $od";
	221	print ASM "$code2name[$opcode] $od\n";
	222	printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
	223	}
	224	} else {
	225	++$lineno;
	226	$descref->[$lineno] = "$text: $code2name[$opcode]";
	227	print ASM "$code2name[$opcode]\n";
	228	printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
	229	}
	230	}
	231	}
	232	}
	233
	234	# Interesting operand values
	235	#
	236	my %goodlist = (
	237	comment_t => [ '"a comment"' ], # no \n
	238	none => [],
	239	svindex => [ 0x7fffffff, 0 ],
	240	opindex => [ 0x7fffffff, 0 ],
	241	pvindex => [ 0x7fffffff, 0 ],
	242	U32 => [ 0xffffffff, 0 ],
	243	U8 => [ 0xff, 0 ],
	244	PV => [ '""', '"a string"', ],
	245	I32 => [ -0x80000000, 0x7fffffff ],
	246	IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
	247	IV => $Config{ivsize} == 4 ?
	248	[ -0x80000000, 0x7fffffff ] :
	249	[ '0x000000000', '0x0ffffffff', '0x000000001' ],
	250	NV => [ 1.23456789E3 ],
	251	U16 => [ 0xffff, 0 ],
	252	pvcontents => [],
	253	strconst => [ '""', '"another string"' ], # no NUL
566ece03	254	op_tr_array => [ join( ',', 256, 0..255 ) ],
ca337316	255	PADOFFSET => undef,
53897bd5	256	long => undef,
f4abc3e7 JH	257	);
	258
	259	# Erronous operand values
	260	#
	261	my %badlist = (
	262	comment_t => [ '"multi-line\ncomment"' ], # no \n
	263	none => [ '"spurious arg"' ],
	264	svindex => [ 0xffffffff * 2, -1 ],
	265	opindex => [ 0xffffffff * 2, -2 ],
	266	pvindex => [ 0xffffffff * 2, -3 ],
	267	U32 => [ 0xffffffff * 2, -4 ],
	268	U16 => [ 0x5ffff, -5 ],
	269	U8 => [ 0x6ff, -6 ],
	270	PV => [ 'no quote"' ],
	271	I32 => [ -0x80000001, 0x80000000 ],
	272	IV64 => undef, # PUT_IV64 doesn't check - no integrity there
	273	IV => $Config{ivsize} == 4 ?
	274	[ -0x80000001, 0x80000000 ] : undef,
	275	NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
	276	pvcontents => [ '"spurious arg"' ],
	277	strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
566ece03	278	op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
ca337316	279	PADOFFSET => undef,
53897bd5	280	long => undef,
f4abc3e7 JH	281	);
	282
	283
	284	# Determine all operand types from %Asmdata::insn_data
	285	#
	286	for my $opname ( keys( %insn_data ) ){
	287	my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
	288	push( @{$opsByType{$getname}}, $opcode );
	289	$code2name[$opcode] = $opname;
	290	}
	291
	292
	293	# Write instruction(s) for correct operand values each operand type class
	294	#
	295	$lineno = 0;
	296	tie( *ASM, 'VirtFile' );
	297	gen_type( \%goodlist, \@descr, 'round trip' );
	298
	299	# Write one instruction for each opcode.
	300	#
	301	for my $opcode ( 0..$#code2name ){
	302	next unless defined( $code2name[$opcode] );
	303	my $sel = $insn_data{$code2name[$opcode]}->[2];
	304	$sel =~ s/^GET_//;
	305	die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
	306	if( defined( $goodlist{$sel} ) ){
	307	++$lineno;
	308	if( @{$goodlist{$sel}} ){
	309	my $od = $goodlist{$sel}[0];
	310	$descr[$lineno] = "round trip: $code2name[$opcode] $od";
	311	print ASM "$code2name[$opcode] $od\n";
	312	printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
	313	} else {
	314	$descr[$lineno] = "round trip: $code2name[$opcode]";
	315	print ASM "$code2name[$opcode]\n";
	316	printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
	317	}
	318	}
	319	}
	320
	321	# Write instruction(s) for incorrect operand values each operand type class
	322	#
	323	$firstbadline = $lineno + 1;
	324	gen_type( \%badlist, \@descr, 'asm error' );
	325
	326	# invalid opcode is an odd-man-out ;-)
	327	#
	328	++$lineno;
	329	$descr[$lineno] = "asm error: Gollum";
	330	print ASM "Gollum\n";
	331	printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
	332
	333	close( ASM );
	334
	335	# Now that we have defined all of our tests: plan
	336	#
	337	plan( tests => $lineno );
	338	print "firstbadline=$firstbadline\n" if $dbg;
	339
	340	# assemble (guard against warnings and death from assembly errors)
	341	#
	342	$SIG{'__WARN__'} = \&catchwarn;
	343
	344	$lineno = -1; # account for the assembly header
345	tie( *OBJ, 'VirtFile' );
346	eval { assemble_fh( \*ASM, \&putobj ); };
347	print "eval: $@" if $dbg;
348	close( ASM );
349	close( OBJ );
350	$SIG{'__WARN__'} = 'DEFAULT';
351
352	# disassemble
353	#
354	print "--- disassembling ---\n" if $dbg;
355	$lineno = 0;
356	tie( *DIS, 'VirtFile' );
357	disassemble_fh( \*OBJ, \&putdis );
358	close( OBJ );
359	close( DIS );
360
361	# get header (for debugging only)
362	#
363	if( $dbg ){
364	my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
365	get_header();
366	printf "Magic: 0x%08x\n", $magic;
367	print "Architecture: $archname\n";
368	print "Byteloader V: $blversion\n";
369	print "ivsize: $ivsize\n";
370	print "ptrsize: $ptrsize\n";
371	print "Byteorder: $byteorder\n";
372	}
373
374	# check by comparing files line by line
375	#
376	print "--- checking ---\n" if $dbg;
377	$lineno = 0;
378	my( $asmline, $disline );
379	while( defined( $asmline = <ASM> ) ){
380	$disline = <DIS>;
381	++$lineno;
382	last if $lineno eq $firstbadline; # bail out where errors begin
383	ok( $asmline eq $disline, $descr[$lineno] );
384	printf "%5d %s\n", $lineno, $asmline if $dbg;
385	}
386	close( ASM );
387	close( DIS );
388
389	__END__