view release on metacpan or  search on metacpan

t/monkeynes.t  view on Meta::CPAN

  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;
    }
    elsif ( $_ eq 'power on' ) {
      $cpu = Acme::6502->new();
      $cpu->set_s( 255 );
      $cpu->set_p( $cpu->get_p | $cpu->R );
      isa_ok( $cpu, 'Acme::6502' );
    }
    elsif ( $_ eq 'memclear' ) {
      $cpu->poke_code( 0, ( 0 ) x 65536 );
      _diag( 'Mem cleared' );
    }
    elsif ( $_ eq 'step' ) {
      _diag( 'Running next instruction...' );
      $cpu->run( 1 );
    }
    elsif ( m{^regset (.+) (.+)} ) {
      $regset_lut{ lc $1 }->( $cpu, hex $2 );
      _diag( "$1 set to $2" );
    }
    elsif ( m{^regs(?: (.+))?} ) {
      diag_regs( $cpu, $1 );
    }
    elsif ( m{^memset (.+) (.+)} ) {
      $cpu->write_8( hex $1, hex $2 );
      is( $cpu->read_8( hex $1 ), hex $2, "Mem[$1] set to $2" );
    }
    elsif ( m{^test (.+) (.+) (.+)} ) {
      my ( $op, @args ) = split( /:/, $1 );
      my $cmp = $2;
      $cmp = '==' if $cmp eq '=';
      cmp_ok( $test_lut{ lc $op }->( $cpu, @args ),
        $cmp, hex $3, "$1 $2 $3" );
    }
    elsif ( m{^op (.+)} ) {
      my ( $op, $args_hex ) = split( ' ', $1 );
      _diag( "OP: $1" );
      $args_hex = '' unless defined $args_hex;
      my @args = ( $args_hex =~ m{(..)}g );
      my $pc = hex( 8000 );
      $cpu->poke_code(
        $pc,
        map { hex( $_ || 0 ) } $op,
        @args[ 0 .. 1 ]
      );
      $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( @_ );
}