view release on metacpan or  search on metacpan

lib/Acme/6502.pm  view on Meta::CPAN

        _inst( _dec( ( '', '$x' ) ) ),             # CA DEX
        $bad_inst,                                 # CB
        _inst( _cmp( _abs(), '$y' ) ),             # CC CPY abs
        _inst( _cmp( _abs(), '$a' ) ),             # CD CMP abs
        _inst( _dec( _abs() ) ),                   # CE DEC abs
        $bad_inst,                                 # CF BBS4 rel
        _inst( _bfz( _rel(), Z ) ),                # D0 BNE rel
        _inst( _cmp( _zpiy(), '$a' ) ),            # D1 CMP (zp), y
        _inst( _cmp( _zpi(),  '$a' ) ),            # D2 CMP (zp)
        $bad_inst,                                 # D3
        $bad_inst,                                 # D4
        _inst( _cmp( _zpx(), '$a' ) ),             # D5 CMP zp, x
        _inst( _dec( _zpx() ) ),                   # D6 DEC zp, x
        $bad_inst,                                 # D7
        _inst( '$p &= ~D;' ),                      # D8 CLD
        _inst( _cmp( _absy(), '$a' ) ),            # D9 CMP abs, y
        _inst( _push( '$x' ) ),                    # DA PHX
        $bad_inst,                                 # DB
        $bad_inst,                                 # DC
        _inst( _cmp( _absx(), '$a' ) ),            # DD CMP abs, x
        _inst( _dec( _absx() ) ),                  # DE DEC abs, x
        $bad_inst,                                 # DF BBS5 rel
        _inst( _cmp( _imm(), '$x' ) ),             # E0 CPX  #imm
        _inst( _sbc( _zpix(), '$a' ) ),            # E1 SBC (zp, x)
        $bad_inst,                                 # E2
        $bad_inst,                                 # E3
        _inst( _cmp( _zp(), '$x' ) ),              # E4 CPX zp
        _inst( _sbc( _zp() ) ),                    # E5 SBC zp
        _inst( _inc( _zp() ) ),                    # E6 INC zp
        $bad_inst,                                 # E7
        _inst( _inc( ( '', '$x' ) ) ),             # E8 INX
        _inst( _sbc( _imm() ) ),                   # E9 SBC  #imm
        _inst(),                                   # EA NOP
        $bad_inst,                                 # EB
        _inst( _cmp( _abs(), '$x' ) ),             # EC CPX abs
        _inst( _sbc( _abs() ) ),                   # ED SBC abs
        _inst( _inc( _abs() ) ),                   # EE INC abs
        $bad_inst,                                 # EF BBS6 rel
        _inst( _bfnz( _rel(), Z ) ),               # F0 BEQ rel
        _inst( _sbc( _zpiy() ) ),                  # F1 SBC (zp), y
        _inst( _sbc( _zpi() ) ),                   # F2 SBC (zp)
        $bad_inst,                                 # F3
        $bad_inst,                                 # F4
        _inst( _sbc( _zpx() ) ),                   # F5 SBC zp, x
        _inst( _inc( _zpx() ) ),                   # F6 INC zp, x
        $bad_inst,                                 # F7
        _inst( '$p |= D;' ),                       # F8 SED
        _inst( _sbc( _absy() ) ),                  # F9 SBC abs, y
        _inst( _pop( '$x' ), _status( '$x' ) ),    # FA PLX
        $bad_inst,                                 # FB
        $bad_inst,                                 # FC
        _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 );
}