1N/Atext file. This file contains three sections: 1N/A testing operand categories 1N/A erronous assembler instructions 1N/AAn "operand category" is identified by the suffix of the PUT_/GET_ 1N/Asubroutines as shown in the C<%Asmdata::insn_data> initialization, e.g. 1N/Aopcode C<ldsv> has operand category C<svindex>: 1N/A insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; 1N/Aresulting object code to a file. And disassembled output is written to 1N/Ayet another text file which is then compared to the original input. 1N/A(Erronous assembler instructions still generate code, but this is not 1N/Awritten to the object file; therefore disassembly bails out at the first 1N/Ainstruction in error.) 1N/AAll files are kept in memory by using TIEHASH. 1N/Agenerates invalid object code will not be detected. 1N/ADue to the way this test has been set up, failure of a single test 1N/Acould cause all subsequent tests to fail as well: After an unexpected 1N/Aassembler error no output is written, and disassembled lines will be 1N/Aout of sync for all lines thereafter. 1N/ANot all possibilities for writing a valid operand value can be tested 1N/Abecause disassembly results in a uniform representation. 1N/ANew opcodes are added automatically. 1N/AA new operand category will cause this program to die ("no operand list 1N/Afor XXX"). The cure is to add suitable entries to C<%goodlist> and 1N/AC<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also 1N/Ahappen that the corresponding assembly or disassembly subroutine is 1N/Amissing.) Note that an empty array as a C<%goodlist> entry means that 1N/Aopcodes of the operand category do not take an operand (and therefore the 1N/Acorresponding entry in C<%badlist> should have one). An C<undef> entry 1N/Ain C<%badlist> means that any value is acceptable (and thus there is no 1N/Away to cause an error). 1N/ASet C<$dbg> to debug this test. 1N/A# Note: This is NOT a general purpose package. It implements 1N/A# sequential text and binary file i/o in a rather simple form. 1N/A my( $class, $data ) = @_; 1N/A my $obj = { data => defined( $data ) ? $data : '', 1N/A return bless( $obj, $class ); 1N/A my( $self ) = shift; 1N/A $self->{data} .= join( '', @_ ); 1N/A my( $self, $buf, $len, $offset ) = @_; 1N/A unless( defined( $len ) ){ 1N/A $len = length( $buf ); 1N/A unless( defined( $offset ) ){ 1N/A $self->{data} .= substr( $buf, $offset, $len ); 1N/A return undef() if $self->{pos} >= length( $self->{data} ); 1N/A return substr( $self->{data}, $self->{pos}++, 1 ); 1N/A return undef() if $self->{pos} >= length( $self->{data} ); 1N/A my $lfpos = index( $self->{data}, "\n", $self->{pos} ); 1N/A $lfpos = length( $self->{data} ); 1N/A my $pos = $self->{pos}; 1N/A $self->{pos} = $lfpos + 1; 1N/A return substr( $self->{data}, $pos, $self->{pos} - $pos ); 1N/A my $bufref = \$_[0]; 1N/A my( undef, $len, $offset ) = @_; 1N/A die( "offset beyond end of buffer\n" ) 1N/A if ! defined( $$bufref ) || $offset > length( $$bufref ); 1N/A my $remlen = length( $self->{data} ) - $self->{pos}; 1N/A $len = $remlen if $remlen < $len; 1N/A return 0 unless $len; 1N/A substr( $$bufref, $offset, $len ) = 1N/A substr( $self->{data}, $self->{pos}, $len ); 1N/A $self->{pos} += $len; 1N/A return $self->{pos}; 1N/Ause Config qw(%Config); 1N/A print "1..0 # Skip -- Perl configured without ByteLoader module\n"; 1N/Ause B::Asmdata qw( %insn_data ); 1N/Ause B::Assembler qw( &assemble_fh ); 1N/Ause B::Disassembler qw( &disassemble_fh &get_header ); 1N/Amy( %opsByType, @code2name ); 1N/Amy( $lineno, $dbg, $firstbadline, @descr ); 1N/A$dbg = 0; # debug switch 1N/A# $SIG{__WARN__} handler to catch Assembler error messages 1N/A print "error: $warnmsg\n" if $dbg; 1N/A# Callback for writing assembled bytes. This is where we check 1N/A# that we do get an error. 1N/A if( ++$lineno >= $firstbadline ){ 1N/A ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] ); 1N/A my $l = syswrite( OBJ, $_[0] ); 1N/A# Callback for writing a disassembled statement. 1N/A my $line = join( ' ', @_ ); 1N/A print DIS "$line\n"; 1N/A printf "%5d %s\n", $lineno, $line if $dbg; 1N/A# Generate assembler instructions from a hash of operand types: each 1N/A# existing entry contains a list of good or bad operand values. The 1N/A# corresponding opcodes can be found in %opsByType. 1N/A my( $href, $descref, $text ) = @_; 1N/A for my $odt ( sort( keys( %opsByType ) ) ){ 1N/A my $opcode = $opsByType{$odt}->[0]; 1N/A die( "no operand list for $sel\n" ) unless exists( $href->{$sel} ); 1N/A if( defined( $href->{$sel} ) ){ 1N/A if( @{$href->{$sel}} ){ 1N/A for my $od ( @{$href->{$sel}} ){ 1N/A $descref->[$lineno] = "$text: $code2name[$opcode] $od"; 1N/A print ASM "$code2name[$opcode] $od\n"; 1N/A printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg; 1N/A $descref->[$lineno] = "$text: $code2name[$opcode]"; 1N/A print ASM "$code2name[$opcode]\n"; 1N/A printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg; 1N/A# Interesting operand values 1N/Acomment_t => [ '"a comment"' ], # no \n 1N/Asvindex => [ 0x7fffffff, 0 ], 1N/Aopindex => [ 0x7fffffff, 0 ], 1N/Apvindex => [ 0x7fffffff, 0 ], 1N/AU32 => [ 0xffffffff, 0 ], 1N/APV => [ '""', '"a string"', ], 1N/AI32 => [ -0x80000000, 0x7fffffff ], 1N/AIV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x 1N/AIV => $Config{ivsize} == 4 ? 1N/A [ -0x80000000, 0x7fffffff ] : 1N/A [ '0x000000000', '0x0ffffffff', '0x000000001' ], 1N/ANV => [ 1.23456789E3 ], 1N/AU16 => [ 0xffff, 0 ], 1N/Astrconst => [ '""', '"another string"' ], # no NUL 1N/Aop_tr_array => [ join( ',
', 256, 0..255 ) ], 1N/A# Erronous operand values 1N/Acomment_t => [ '"multi-line\ncomment"' ], # no \n 1N/Anone => [ '"spurious arg"' ], 1N/Asvindex => [ 0xffffffff * 2, -1 ], 1N/Aopindex => [ 0xffffffff * 2, -2 ], 1N/Apvindex => [ 0xffffffff * 2, -3 ], 1N/AU32 => [ 0xffffffff * 2, -4 ], 1N/AU16 => [ 0x5ffff, -5 ], 1N/AI32 => [ -0x80000001, 0x80000000 ], 1N/AIV64 => undef, # PUT_IV64 doesn't check - no integrity there 1N/A [ -0x80000001, 0x80000000 ] : undef, 1N/ANV => undef, # PUT_NV accepts anything - it shouldn't, real-ly 1N/Astrconst => [ 'no quote"', '"with NUL '."\
0".' char"' ], # no NUL 1N/Aop_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts 1N/A# Determine all operand types from %Asmdata::insn_data 1N/Afor my $opname ( keys( %insn_data ) ){ 1N/A my ( $opcode, $put, $getname ) = @{$insn_data{$opname}}; 1N/A push( @{$opsByType{$getname}}, $opcode ); 1N/A $code2name[$opcode] = $opname; 1N/A# Write instruction(s) for correct operand values each operand type class 1N/A# Write one instruction for each opcode. 1N/Afor my $opcode ( 0..$#code2name ){ 1N/A next unless defined( $code2name[$opcode] ); 1N/A my $sel = $insn_data{$code2name[$opcode]}->[2]; 1N/A die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} ); 1N/A if( defined( $goodlist{$sel} ) ){ 1N/A if( @{$goodlist{$sel}} ){ 1N/A my $od = $goodlist{$sel}[0]; 1N/A $descr[$lineno] = "round trip: $code2name[$opcode] $od"; 1N/A print ASM "$code2name[$opcode] $od\n"; 1N/A printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg; 1N/A $descr[$lineno] = "round trip: $code2name[$opcode]"; 1N/A print ASM "$code2name[$opcode]\n"; 1N/A printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg; 1N/A# Write instruction(s) for incorrect operand values each operand type class 1N/A$firstbadline = $lineno + 1; 1N/A# invalid opcode is an odd-man-out ;-) 1N/A$descr[$lineno] = "asm error: Gollum"; 1N/Aprint ASM "Gollum\n"; 1N/A# Now that we have defined all of our tests: plan 1N/Aplan( tests => $lineno ); 1N/Aprint "firstbadline=$firstbadline\n" if $dbg; 1N/A# assemble (guard against warnings and death from assembly errors) 1N/A$lineno = -1; # account for the assembly header 1N/Aeval { assemble_fh( \*ASM, \&putobj ); }; 1N/Aprint "eval: $@" if $dbg; 1N/Aprint "--- disassembling ---\n" if $dbg; 1N/Adisassemble_fh( \*OBJ, \&putdis ); 1N/A# get header (for debugging only) 1N/A my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) = 1N/A printf "Magic: 0x%08x\n", $magic; 1N/A print "Architecture: $archname\n"; 1N/A print "Byteloader V: $blversion\n"; 1N/A print "ivsize: $ivsize\n"; 1N/A print "ptrsize: $ptrsize\n"; 1N/A print "Byteorder: $byteorder\n"; 1N/A# check by comparing files line by line 1N/Aprint "--- checking ---\n" if $dbg; 1N/Amy( $asmline, $disline ); 1N/Awhile( defined( $asmline = <ASM> ) ){ 1N/A last if $lineno eq $firstbadline; # bail out where errors begin 1N/A ok( $asmline eq $disline, $descr[$lineno] ); 1N/A printf "%5d %s\n", $lineno, $asmline if $dbg;