5 =head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
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
14 Since Assembler.pm likes to assemble a file, we comply by writing a
15 text file. This file contains three sections:
17 testing operand categories
19 erronous assembler instructions
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>:
25 insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
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.)
34 All files are kept in memory by using TIEHASH.
39 An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
40 generates invalid object code will not be detected.
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.
47 Not all possibilities for writing a valid operand value can be tested
48 because disassembly results in a uniform representation.
53 New opcodes are added automatically.
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).
65 Set C<$dbg> to debug this test.
72 # Note: This is NOT a general purpose package. It implements
73 # sequential text and binary file i/o in a rather simple form.
76 my( $class, $data ) = @_;
77 my $obj = { data => defined( $data ) ? $data : '',
79 return bless( $obj, $class );
84 $self->{data} .= join( '', @_ );
88 my( $self, $buf, $len, $offset ) = @_;
89 unless( defined( $len ) ){
90 $len = length( $buf );
93 unless( defined( $offset ) ){
96 $self->{data} .= substr( $buf, $offset, $len );
103 return undef() if $self->{pos} >= length( $self->{data} );
104 return substr( $self->{data}, $self->{pos}++, 1 );
109 return undef() if $self->{pos} >= length( $self->{data} );
110 my $lfpos = index( $self->{data}, "\n", $self->{pos} );
112 $lfpos = length( $self->{data} );
114 my $pos = $self->{pos};
115 $self->{pos} = $lfpos + 1;
116 return substr( $self->{data}, $pos, $self->{pos} - $pos );
122 my( undef, $len, $offset ) = @_;
124 die( "offset beyond end of buffer\n" )
125 if ! defined( $$bufref ) || $offset > length( $$bufref );
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;
155 use Config qw(%Config);
158 if (($Config{'extensions'} !~ /\bB\b/) ){
159 print "1..0 # Skip -- Perl configured without B module\n";
162 if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
163 print "1..0 # Skip -- Perl configured without ByteLoader module\n";
168 use B::Asmdata qw( %insn_data );
169 use B::Assembler qw( &assemble_fh );
170 use B::Disassembler qw( &disassemble_fh &get_header );
172 my( %opsByType, @code2name );
173 my( $lineno, $dbg, $firstbadline, @descr );
174 $dbg = 0; # debug switch
176 # $SIG{__WARN__} handler to catch Assembler error messages
181 print "error: $warnmsg\n" if $dbg;
184 # Callback for writing assembled bytes. This is where we check
185 # that we do get an error.
188 if( ++$lineno >= $firstbadline ){
189 ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
192 my $l = syswrite( OBJ, $_[0] );
196 # Callback for writing a disassembled statement.
199 my $line = join( ' ', @_ );
202 printf "%5d %s\n", $lineno, $line if $dbg;
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.
210 my( $href, $descref, $text ) = @_;
211 for my $odt ( sort( keys( %opsByType ) ) ){
212 my $opcode = $opsByType{$odt}->[0];
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}} ){
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;
226 $descref->[$lineno] = "$text: $code2name[$opcode]";
227 print ASM "$code2name[$opcode]\n";
228 printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
234 # Interesting operand values
237 comment_t => [ '"a comment"' ], # no \n
239 svindex => [ 0x7fffffff, 0 ],
240 opindex => [ 0x7fffffff, 0 ],
241 pvindex => [ 0x7fffffff, 0 ],
242 U32 => [ 0xffffffff, 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 ],
253 strconst => [ '""', '"another string"' ], # no NUL
254 op_tr_array => [ join( ',', 256, 0..255 ) ],
259 # Erronous operand values
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 ],
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
278 op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
284 # Determine all operand types from %Asmdata::insn_data
286 for my $opname ( keys( %insn_data ) ){
287 my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
288 push( @{$opsByType{$getname}}, $opcode );
289 $code2name[$opcode] = $opname;
293 # Write instruction(s) for correct operand values each operand type class
296 tie( *ASM, 'VirtFile' );
297 gen_type( \%goodlist, \@descr, 'round trip' );
299 # Write one instruction for each opcode.
301 for my $opcode ( 0..$#code2name ){
302 next unless defined( $code2name[$opcode] );
303 my $sel = $insn_data{$code2name[$opcode]}->[2];
305 die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
306 if( defined( $goodlist{$sel} ) ){
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;
314 $descr[$lineno] = "round trip: $code2name[$opcode]";
315 print ASM "$code2name[$opcode]\n";
316 printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
321 # Write instruction(s) for incorrect operand values each operand type class
323 $firstbadline = $lineno + 1;
324 gen_type( \%badlist, \@descr, 'asm error' );
326 # invalid opcode is an odd-man-out ;-)
329 $descr[$lineno] = "asm error: Gollum";
330 print ASM "Gollum\n";
331 printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
335 # Now that we have defined all of our tests: plan
337 plan( tests => $lineno );
338 print "firstbadline=$firstbadline\n" if $dbg;
340 # assemble (guard against warnings and death from assembly errors)
342 $SIG{'__WARN__'} = \&catchwarn;
344 $lineno = -1; # account for the assembly header
345 tie( *OBJ, 'VirtFile' );
346 eval { assemble_fh( \*ASM, \&putobj ); };
347 print "eval: $@" if $dbg;
350 $SIG{'__WARN__'} = 'DEFAULT';
354 print "--- disassembling ---\n" if $dbg;
356 tie( *DIS, 'VirtFile' );
357 disassemble_fh( \*OBJ, \&putdis );
361 # get header (for debugging only)
364 my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
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";
374 # check by comparing files line by line
376 print "--- checking ---\n" if $dbg;
378 my( $asmline, $disline );
379 while( defined( $asmline = <ASM> ) ){
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;