Acme-6502
view release on metacpan or search on metacpan
inc/MyBuilder.pm view on Meta::CPAN
package MyBuilder;
use base qw( Module::Build );
sub create_build_script {
my ( $self, @args ) = @_;
$self->_auto_mm;
return $self->SUPER::create_build_script( @args );
}
sub _auto_mm {
my $self = shift;
my $mm = $self->meta_merge;
my @meta = qw( homepage bugtracker MailingList repository );
for my $meta ( @meta ) {
next if exists $mm->{resources}{$meta};
my $auto = "_auto_$meta";
next unless $self->can( $auto );
my $av = $self->$auto();
$mm->{resources}{$meta} = $av if defined $av;
}
$self->meta_merge( $mm );
}
sub _auto_repository {
my $self = shift;
if ( -d '.svn' ) {
my $info = `svn info .`;
return $1 if $info =~ /^URL:\s+(.+)$/m;
}
elsif ( -d '.git' ) {
my $info = `git remote -v`;
return unless $info =~ /^origin\s+(.+)$/m;
my $url = $1;
# Special case: patch up github URLs
$url =~ s!^git\@github\.com:!git://github.com/!;
return $url;
}
return;
}
sub _auto_bugtracker {
'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name;
}
sub ACTION_testauthor {
my $self = shift;
$self->test_files( 'xt/author' );
$self->ACTION_test;
}
sub ACTION_critic {
exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t';
}
sub ACTION_tags {
exec(
qw(
ctags -f tags --recurse --totals
--exclude=blib
--exclude=.svn
--exclude='*~'
--languages=Perl
t/ lib/
)
);
}
sub ACTION_tidy {
my $self = shift;
my @extra = qw( Build.PL );
my %found_files = map { %$_ } $self->find_pm_files,
$self->_find_file_by_type( 'pm', 't' ),
$self->_find_file_by_type( 'pm', 'inc' ),
$self->_find_file_by_type( 't', 't' );
my @files = ( keys %found_files,
lib/Acme/6502.pm view on Meta::CPAN
# Opcode to thunk into perlspace
use constant {
ESCAPE_OP => 0x0B,
ESCAPE_SIG => 0xAD
};
BEGIN {
for my $reg ( qw(a x y s p pc) ) {
no strict 'refs';
*{ __PACKAGE__ . "\::get_${reg}" } = sub {
my $self = shift;
return $self->{ reg }->{ $reg };
};
*{ __PACKAGE__ . "\::set_${reg}" } = sub {
my ( $self, $v ) = @_;
$self->{ reg }->{ $reg } = $v;
};
}
}
sub new {
my $class = shift;
my $self = bless { }, $class;
$self->_BUILD( @_ );
return $self;
}
my @OP_CACHE;
sub _BUILD {
my( $self, $args ) = @_;
$args ||= {};
$self->{ mem } = [ ( 0 ) x 65536 ];
$self->{ reg } = {
map { $_ => 0 } qw( a x y s p pc )
};
$self->{ os } = [ ];
$self->{ jumptab } = $args->{ jumptab } || 0xFA00;
lib/Acme/6502.pm view on Meta::CPAN
_inst( _sbc( _absx() ) ), # FD SBC abs, x
_inst( _inc( _absx() ) ), # FE INC abs, x
$bad_inst, # FF BBS7 rel
) if !@OP_CACHE;
$self->{ ops } = [ @OP_CACHE ];
confess "Escape handler opcode not available"
unless $self->{ ops }->[ ESCAPE_OP ] == $bad_inst;
# Patch in the OS escape op handler
$self->{ ops }->[ ESCAPE_OP ] = sub {
my $self = shift;
if ( $self->{ mem }->[ $self->{ reg }->{ pc } ] != ESCAPE_SIG ) {
$bad_inst->( $self );
}
else {
$self->{ reg }->{ pc } += 2;
$self->call_os( $self->{ mem }->[ $self->{ reg }->{ pc } - 1 ] );
}
};
}
sub set_jumptab {
my $self = shift;
$self->{ jumptab } = shift;
}
sub get_state {
my $self = shift;
return @{ $self->{ reg } }{ qw( a x y s p pc ) };
}
sub get_xy {
my $self = shift;
return $self->get_x || ( $self->get_y << 8 );
}
sub set_xy {
my $self = shift;
my $v = shift;
$self->set_x( $v & 0xFF );
$self->set_y( ( $v >> 8 ) & 0xFF );
}
sub read_str {
my $self = shift;
my $addr = shift;
my $str = '';
while ( $self->{ mem }->[ $addr ] != 0x0D ) {
$str .= chr( $self->{ mem }->[ $addr++ ] );
}
return $str;
}
sub read_chunk {
my $self = shift;
my ( $from, $to ) = @_;
return pack( 'C*', @{ $self->{ mem } }[ $from .. $to - 1 ] );
}
sub write_chunk {
my $self = shift;
my ( $addr, $chunk ) = @_;
my $len = length( $chunk );
splice @{ $self->{ mem } }, $addr, $len, unpack( 'C*', $chunk );
}
sub read_8 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ];
}
sub write_8 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val;
}
sub read_16 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ] | ( $self->{ mem }->[ $addr + 1 ] << 8 );
}
sub write_16 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val & 0xFF;
$self->{ mem }->[ $addr + 1 ] = ( $val >> 8 ) & 0xFF;
}
sub read_32 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ]
| ( $self->{ mem }->[ $addr + 1 ] << 8 )
| ( $self->{ mem }->[ $addr + 2 ] << 16 )
| ( $self->{ mem }->[ $addr + 3 ] << 32 );
}
sub write_32 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val & 0xFF;
$self->{ mem }->[ $addr + 1 ] = ( $val >> 8 ) & 0xFF;
$self->{ mem }->[ $addr + 2 ] = ( $val >> 16 ) & 0xFF;
$self->{ mem }->[ $addr + 3 ] = ( $val >> 24 ) & 0xFF;
}
sub poke_code {
my $self = shift;
my $addr = shift;
$self->{ mem }->[ $addr++ ] = $_ for @_;
}
sub load_rom {
my $self = shift;
my ( $f, $a ) = @_;
open my $fh, '<', $f or croak "Can't read $f ($!)\n";
binmode $fh;
my $sz = -s $fh;
sysread $fh, my $buf, $sz or croak "Error reading $f ($!)\n";
close $fh;
$self->write_chunk( $a, $buf );
}
sub call_os {
croak "call_os() not supported";
}
sub run {
my $self = shift;
my $ic = shift;
my $cb = shift;
while ( $ic-- > 0 ) {
my( $a, $x, $y, $s, $p, $pc ) = $self->get_state;
$cb->( $pc, $self->{ mem }->[ $pc ], $a, $x, $y, $s, $p ) if defined $cb;
$self->set_pc( $pc + 1 );
$self->{ ops }->[ $self->{ mem }->[ $pc ] ]->( $self );
}
}
sub make_vector {
my $self = shift;
my ( $call, $vec, $func ) = @_;
$self->{ mem }->[ $call ] = 0x6C; # JMP (indirect)
$self->{ mem }->[ $call + 1 ] = $vec & 0xFF;
$self->{ mem }->[ $call + 2 ] = ( $vec >> 8 ) & 0xFF;
my $jumptab = $self->{ jumptab };
my $addr = $jumptab;
$self->{ mem }->[ $jumptab++ ] = ESCAPE_OP;
$self->{ mem }->[ $jumptab++ ] = ESCAPE_SIG;
$self->{ mem }->[ $jumptab++ ] = $func;
$self->{ mem }->[ $jumptab++ ] = 0x60;
$self->set_jumptab( $jumptab );
$self->{ mem }->[ $vec ] = $addr & 0xFF;
$self->{ mem }->[ $vec + 1 ] = ( $addr >> 8 ) & 0xFF;
}
sub _inst {
my $src = join( "\n", @_ );
# registers
$src =~ s{\$(a|x|y|s|p|pc)\b}{\$self->{reg}->{$1}}g;
# memory and zn access
$src =~ s{\$(mem|zn)\[}{\$self->{$1}->[}g;
my $cr = eval "sub { my \$self=shift; ${src} }";
confess "$@" if $@;
return $cr;
}
sub _bad_inst {
my $self = shift;
my $pc = $self->get_pc;
croak sprintf( "Bad instruction at &%04x (&%02x)\n",
$pc - 1, $self->{ mem }->[ $pc - 1 ] );
}
# Functions that generate code fragments
sub _set_nz {
return
'$p &= ~(N|Z);' . 'if( '
. $_[0]
. ' & 0x80){ $p |= N }'
. 'elsif( '
. $_[0]
. ' == 0 ){ $p |= Z }';
}
sub _push {
my $r = '';
for ( @_ ) {
$r
.= '$mem[STACK + $s] = ('
. $_
. ') & 0xFF; $s = ($s - 1) & 0xFF;' . "\n";
}
return $r;
}
sub _pop {
my $r = '';
for ( @_ ) {
$r .= '$s = ($s + 1) & 0xFF; ' . $_ . ' = $mem[STACK + $s];' . "\n";
}
return $r;
}
sub _pop_p {
return '$s = ($s + 1) & 0xFF; $p = $mem[STACK + $s] | R; $p &= ~B;'
. "\n";
}
# Addressing modes return a list containing setup code, lvalue
sub _zpix {
return (
'my $ea = $mem[$pc++] + $x; '
. '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)' . ";\n",
'$mem[$ea]'
);
}
sub _zpi {
return (
'my $ea = $mem[$pc++]; '
. '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)' . ";\n",
'$mem[$ea]'
);
}
sub _zpiy {
return (
'my $ea = $mem[$pc++]; '
. '$ea = ($mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)) + $y'
. ";\n",
'$mem[$ea]'
);
}
sub _zp {
return ( 'my $ea = $mem[$pc++];' . "\n", '$mem[$ea]' );
}
sub _zpx {
return ( 'my $ea = ($mem[$pc++] + $x) & 0xFF;' . "\n", '$mem[$ea]' );
}
sub _zpy {
return ( 'my $ea = ($mem[$pc++] + $y) & 0xFF;' . "\n", '$mem[$ea]' );
}
sub _abs {
return ( 'my $ea = $mem[$pc] | ($mem[$pc+1] << 8); $pc += 2;' . "\n",
'$mem[$ea]' );
}
sub _absx {
return (
'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $x; $pc += 2;' . "\n",
'$mem[$ea]'
);
}
sub _absy {
return (
'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $y; $pc += 2;' . "\n",
'$mem[$ea]'
);
}
sub _imm {
return ( 'my $v = $mem[$pc++];' . "\n", '$v' );
}
sub _acc {
return ( '', '$a' );
}
sub _rel {
# Doesn't return an lvalue
return ( 'my $t = $mem[$pc++];' . "\n",
'($pc + $t - (($t & 0x80) ? 0x100 : 0))' );
}
sub _status {
my $reg = shift || '$a';
return '$p = ($p & ~(N | Z) | $zn[' . $reg . ']);' . "\n";
}
sub _ora {
return $_[0] . '$a |= ' . $_[1] . ";\n" . _status();
}
sub _and {
return $_[0] . '$a &= ' . $_[1] . ";\n" . _status();
}
sub _eor {
return $_[0] . '$a ^= ' . $_[1] . ";\n" . _status();
}
sub _bit {
return
$_[0]
. '$p = ($p & ~(N|V)) | ('
. $_[1]
. ' & (N|V));' . "\n"
. 'if (($a & '
. $_[1]
. ') == 0) { $p |= Z; } else { $p &= ~Z; }' . "\n";
}
sub _asl {
return
$_[0]
. 'my $w = ('
. $_[1]
. ') << 1; ' . "\n"
. 'if ($w & 0x100) { $p |= C; $w &= ~0x100; } else { $p &= ~C; }'
. "\n"
. _status( '$w' )
. $_[1]
. ' = $w;' . "\n";
}
sub _lsr {
return
$_[0]
. 'my $w = '
. $_[1] . ";\n"
. 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
. '$w >>= 1;' . "\n"
. _status( '$w' )
. $_[1]
. ' = $w;' . "\n";
}
sub _rol {
return
$_[0]
. 'my $w = ('
. $_[1]
. ' << 1) | ($p & C);' . "\n"
. 'if ($w >= 0x100) { $p |= C; $w -= 0x100; } else { $p &= ~C; };'
. "\n"
. _status( '$w' )
. $_[1]
. ' = $w;' . "\n";
}
sub _ror {
return
$_[0]
. 'my $w = '
. $_[1]
. ' | (($p & C) << 8);' . "\n"
. 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
. '$w >>= 1;' . "\n"
. _status( '$w' )
. $_[1]
. ' = $w;' . "\n";
}
sub _sto {
return $_[0] . "$_[1] = $_[2];\n";
}
sub _lod {
return $_[0] . "$_[2] = $_[1];\n" . _status( $_[2] );
}
sub _cmp {
return
$_[0]
. 'my $w = '
. $_[2] . ' - '
. $_[1] . ";\n"
. 'if ($w < 0) { $w += 0x100; $p &= ~C; } else { $p |= C; }' . "\n"
. _status( '$w' );
}
sub _tsb {
return 'croak "TSB not supported\n";' . "\n";
}
sub _trb {
return 'croak "TRB not supported\n";' . "\n";
}
sub _inc {
return
$_[0]
. $_[1] . ' = ('
. $_[1]
. ' + 1) & 0xFF;' . "\n"
. _status( $_[1] );
}
sub _dec {
return
$_[0]
. $_[1] . ' = ('
. $_[1]
. ' + 0xFF) & 0xFF;' . "\n"
. _status( $_[1] );
}
sub _adc {
return
$_[0]
. 'my $w = '
. $_[1] . ";\n"
. 'if ($p & D) {' . "\n"
. 'my $lo = ($a & 0x0F) + ($w & 0x0F) + ($p & C);' . "\n"
. 'if ($lo > 9) { $lo += 6; }' . "\n"
. 'my $hi = ($a >> 4) + ( $w >> 4) + ($lo > 15 ? 1 : 0);' . "\n"
. '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
. '$p = ($p & ~C) | ($hi > 15 ? C : 0);' . "\n"
. '} else {' . "\n"
. 'my $lo = $a + $w + ($p & C);' . "\n"
. '$p &= ~(N | V | Z | C);' . "\n"
. '$p |= (~($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? C : 0);'
. "\n"
. '$a = $lo & 0xFF;' . "\n"
. _status() . '}' . "\n";
}
sub _sbc {
return
$_[0]
. 'my $w = '
. $_[1] . ";\n"
. 'if ($p & D) {' . "\n"
. 'my $lo = ($a & 0x0F) - ($w & 0x0F) - (~$p & C);' . "\n"
. 'if ($lo & 0x10) { $lo -= 6; }' . "\n"
. 'my $hi = ($a >> 4) - ($w >> 4) - (($lo & 0x10) >> 4);' . "\n"
. 'if ($hi & 0x10) { $hi -= 6; }' . "\n"
. '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
. '$p = ($p & ~C) | ($hi > 15 ? 0 : C);' . "\n"
. '} else {' . "\n"
. 'my $lo = $a - $w - (~$p & C);' . "\n"
. '$p &= ~(N | V | Z | C);' . "\n"
. '$p |= (($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? 0 : C);'
. "\n"
. '$a = $lo & 0xFF;' . "\n"
. _status() . '}' . "\n";
}
sub _bra {
return $_[0] . '$pc = ' . $_[1] . ";\n";
}
sub _bfz {
return
$_[0]
. 'if (($p & '
. $_[2]
. ') == 0) { $pc = '
. $_[1] . '; }' . "\n";
}
sub _bfnz {
return
$_[0]
. 'if (($p & '
. $_[2]
. ') != 0) { $pc = '
. $_[1] . '; }' . "\n";
}
sub _jmp_i {
my $a = shift;
return '$pc = $mem[' . $a . '] | ($mem[' . $a . ' + 1] << 8);' . "\n";
}
sub _jmp_i_bug {
my $a = shift;
# this should emulate a page boundary bug:
# JMP 0x80FF fetches from 0x80FF and 0x8000
# instead of 0x80FF and 0x8100
my $b = "($a & 0xFF00) | (($a + 1) & 0xFF)";
return '$pc = $mem[' . $a . '] | ($mem[' . $b . '] << 8);' . "\n";
}
sub _jmp {
return _jmp_i( '$pc' );
}
sub _jmpi {
return 'my $w = $mem[$pc] | ($mem[$pc + 1] << 8); '
. _jmp_i_bug( '$w' );
}
sub _jmpix {
return 'my $w = ($mem[$pc] | ($mem[$pc + 1] << 8)) + $x; '
. _jmp_i( '$w' );
}
sub _rti {
return
_pop( '$p' )
. '$p |= R;'
. 'my ($lo, $hi); '
. _pop( '$lo' )
. _pop( '$hi' )
. '$pc = $lo | ($hi << 8);' . "\n";
}
sub _rts {
return
'my ($lo, $hi); '
. _pop( '$lo' )
. _pop( '$hi' )
. '$pc = ($lo | ($hi << 8)) + 1;' . "\n";
}
1;
__END__
lib/Acme/6502.pm view on Meta::CPAN
Read a carriage return terminated (0x0D) string from the
specified address.
=item C<run( $count [, $callback ] )>
Execute the specified number of instructions and return. Optionally a
callback may be provided in which case it will be called before each
instruction is executed:
my $cb = sub {
my ($pc, $inst, $a, $x, $y, $s, $p) = @_;
# Maybe output trace info
}
$cpu->run(100, $cb);
=item C<write_8( $addr, $value )>
Write the byte at the specified address.
lib/Acme/6502/Tube.pm view on Meta::CPAN
OSFILE => 0xFFDD,
OSASCI => 0xFFE3,
OSNEWL => 0xFFE7,
OSWRCH => 0xFFEE,
OSRDCH => 0xFFE0,
OSWORD => 0xFFF1,
OSBYTE => 0xFFF4,
OSCLI => 0xFFF7
};
sub _BUILD {
my ( $self, $args ) = @_;
$self->SUPER::_BUILD( $args );
$self->{ time_base } = time();
# Inline OSASCI code
$self->poke_code( OSASCI,
0xC9, 0x0D, # CMP #&0D
0xD0, 0x07, # BNE +7
lib/Acme/6502/Tube.pm view on Meta::CPAN
$self->make_vector( 'OSFILE', 0x212, \&_osfile );
$self->make_vector( 'OSARGS', 0x214, \&_osargs );
$self->make_vector( 'OSBGET', 0x216, \&_osbget );
$self->make_vector( 'OSBPUT', 0x218, \&_osbput );
$self->make_vector( 'OSGBPB', 0x21A, \&_osgbpb );
$self->make_vector( 'OSFIND', 0x21C, \&_osfind );
$self->set_jumptab( 0xFA00 );
}
sub _oscli {
my $self = shift;
my $blk = $self->get_xy();
my $cmd = '';
CH: for ( ;; ) {
my $ch = $self->read_8( $blk++ );
last CH if $ch < 0x20;
$cmd .= chr( $ch );
}
$cmd =~ s/^[\s\*]+//g;
if ( lc( $cmd ) eq 'quit' ) {
exit;
}
else {
system( $cmd );
}
}
sub _osbyte {
my $self = shift;
my $a = $self->get_a();
if ( $a == 0x7E ) {
# Ack escape
$self->write_8( 0xFF, 0 );
$self->set_x( 0xFF );
}
elsif ( $a == 0x82 ) {
# Read m/c high order address
$self->set_xy( 0 );
lib/Acme/6502/Tube.pm view on Meta::CPAN
$self->set_xy( HIMEM );
}
elsif ( $a == 0xDA ) {
$self->set_xy( 0x0900 );
}
else {
die sprintf( "OSBYTE %02x not handled\n", $a );
}
}
sub _set_escape {
my $self = shift;
$self->write_8( 0xFF, 0xFF );
}
sub _osword {
my $self = shift;
my $a = $self->get_a();
my $blk = $self->get_xy();
if ( $a == 0x00 ) {
# Command line input
my $buf = $self->read_16( $blk );
my $len = $self->read_8( $blk + 2 );
my $min = $self->read_8( $blk + 3 );
my $max = $self->read_8( $blk + 4 );
lib/Acme/6502/Tube.pm view on Meta::CPAN
elsif ( $a == 0x02 ) {
# Set clock
my $tm = $self->read_32( $blk );
$self->{ time_base } = time() - ( $tm * 100 );
}
else {
die sprintf( "OSWORD %02x not handled\n", $a );
}
}
sub _oswrch {
my $self = shift;
printf( "%c", $self->get_a() );
}
sub _osrdch {
my $self = shift;
Term::ReadKey::ReadMode( 4 );
eval {
my $k = ord( Term::ReadKey::ReadKey( 0 ) );
$k = 0x0D if $k == 0x0A;
$self->set_a( $k );
if ( $k == 27 ) {
$self->set_escape;
$self->set_p( $self->get_p() | $self->C );
}
else {
$self->set_p( $self->get_p() & ~$self->C );
}
};
Term::ReadKey::ReadMode( 0 );
die $@ if $@;
}
sub _osfile {
my $self = shift;
my $a = $self->get_a();
my $blk = $self->get_xy();
my $name = $self->read_str( $self->read_16( $blk ) );
my $load = $self->read_32( $blk + 2 );
my $exec = $self->read_32( $blk + 6 );
my $start = $self->read_32( $blk + 10 );
my $end = $self->read_32( $blk + 14 );
# printf("%-20s %08x %08x %08x %08x\n", $name, $load, $exec, $start, $end);
lib/Acme/6502/Tube.pm view on Meta::CPAN
}
else {
$self->set_a( 0 );
}
}
else {
die sprintf( "OSFILE %02x not handled\n", $a );
}
}
sub _osargs {
die "OSARGS not handled\n";
}
sub _osbget {
die "OSBGET not handled\n";
}
sub _osbput {
die "OSBPUT not handled\n";
}
sub _osgbpb {
die "OSGBPB not handled\n";
}
sub _osfind {
die "OSFIND not handled\n";
}
sub make_vector {
my( $self, $name, $vec, $code ) = @_;
my $addr = $self->$name;
my $vecno = scalar @{ $self->{ os } };
push @{ $self->{ os } }, [ $code, $name ];
$self->SUPER::make_vector( $addr, $vec, $vecno );
}
sub call_os {
my $self = shift;
my $vecno = shift;
eval {
my $call = $self->{ os }->[ $vecno ] || die "Bad OS call $vecno\n";
$call->[ 0 ]->( $self );
};
if ( $@ ) {
my $err = $@;
use warnings;
use Test::More;
use Acme::6502;
use Acme::6502::Tube;
eval { require Test::LeakTrace; };
plan skip_all => "Test::LeakTrace require for this test" if $@;
Test::LeakTrace::no_leaks_ok( sub {
my $cpu = Acme::6502->new;
} );
Test::LeakTrace::no_leaks_ok( sub {
my $cpu = Acme::6502::Tube->new;
} );
done_testing;
t/monkeynes.t view on Meta::CPAN
use strict;
use warnings;
use Test::More 'no_plan';
BEGIN {
use_ok( 'Acme::6502' );
}
my %test_lut = (
m => sub {
return shift->read_8( hex shift );
},
ps => sub {
return shift->get_p;
},
pc => sub {
return shift->get_pc;
},
sp => sub {
return shift->get_s;
},
acc => sub {
return shift->get_a;
},
ix => sub {
return shift->get_x;
},
iy => sub {
return shift->get_y;
},
s => sub {
return $_[0]->get_p & $_[0]->N ? 1 : 0;
},
v => sub {
return $_[0]->get_p & $_[0]->V ? 1 : 0;
},
b => sub {
return $_[0]->get_p & $_[0]->B ? 1 : 0;
},
d => sub {
return $_[0]->get_p & $_[0]->D ? 1 : 0;
},
i => sub {
return $_[0]->get_p & $_[0]->I ? 1 : 0;
},
z => sub {
return $_[0]->get_p & $_[0]->Z ? 1 : 0;
},
c => sub {
return $_[0]->get_p & $_[0]->C ? 1 : 0;
},
);
my %regset_lut = (
ps => sub {
shift->set_p( shift );
},
pc => sub {
shift->set_pc( shift );
},
sp => sub {
shift->set_s( shift );
},
acc => sub {
shift->set_a( shift );
},
ix => sub {
shift->set_x( shift );
},
iy => sub {
shift->set_y( shift );
},
s => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->N );
$_[0]->set_p( $_[0]->get_p | $_[0]->N ) if $_[1];
},
v => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->V );
$_[0]->set_p( $_[0]->get_p | $_[0]->V ) if $_[1];
},
b => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->B );
$_[0]->set_p( $_[0]->get_p | $_[0]->B ) if $_[1];
},
d => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->D );
$_[0]->set_p( $_[0]->get_p | $_[0]->D ) if $_[1];
},
i => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->I );
$_[0]->set_p( $_[0]->get_p | $_[0]->I ) if $_[1];
},
z => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->Z );
$_[0]->set_p( $_[0]->get_p | $_[0]->Z ) if $_[1];
},
c => sub {
$_[0]->set_p( $_[0]->get_p & ~$_[0]->C );
$_[0]->set_p( $_[0]->get_p | $_[0]->C ) if $_[1];
},
);
my $glob = $ENV{TEST_OP} || '*';
my @files = glob( "t/monkeynes/script_${glob}.txt" );
for my $file ( @files ) {
open( my $script, $file ) || die qq(cannot load test script "$file");
_diag( qq(Running script "$file") );
my @lines = <$script>;
chomp( @lines );
run_script( @lines );
close( $script );
}
sub run_script {
my $cpu;
for ( @_ ) {
chomp;
next if m{^\s*$};
next if m{^save};
if ( m{^# (.+)} ) {
_diag( $1 );
}
elsif ( $_ eq 'clear' ) {
next;
t/monkeynes.t view on Meta::CPAN
$cpu->set_pc( $pc );
$cpu->run( 1 );
}
else {
use Data::Dumper;
warn Dumper $_;
}
}
}
sub diag_regs {
my $cpu = shift;
my $reg = uc( defined $_[0] ? $_[0] : '' );
_diag( 'CPU Registers' ) if !$reg;
_diag( sprintf ' PC: $%X', $cpu->get_pc )
if !$reg || $reg eq 'PC';
_diag( sprintf ' SP: $%X', $cpu->get_s ) if !$reg || $reg eq 'SP';
_diag( sprintf ' ACC: $%X', $cpu->get_a )
if !$reg || $reg eq 'ACC';
_diag( sprintf ' IX: $%X', $cpu->get_x ) if !$reg || $reg eq 'IX';
_diag( sprintf ' IY: $%X', $cpu->get_y ) if !$reg || $reg eq 'IY';
# this should be fixed to handle just one flag at a time
_diag( ' Flags S V - B D I Z C' )
if !$reg || $reg =~ m{^(PS|[SVBDIZC])$};
_diag(
sprintf ' PS: %d %d %d %d %d %d %d %d',
split( //, sprintf( '%08b', $cpu->get_p ) )
) if !$reg || $reg =~ m{^(PS|[SVBDIZC])$};
}
sub _diag {
return unless $ENV{DIAG_6502};
diag( @_ );
}
( run in 0.283 second using v1.01-cache-2.11-cpan-4d50c553e7e )