viewvc.cgi/VRac/Orao.pm

package Orao;

use warnings;
use strict;

use Carp qw/confess/;
use lib './lib';
#use Time::HiRes qw(time);
use File::Slurp;
use Data::Dump qw/dump/;
use M6502;

use base qw(Class::Accessor M6502 Screen Prefs);
__PACKAGE__->mk_accessors(qw(booted));

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

=head1 SUMMARY

Emulator or Orao 8-bit 6502 machine popular in Croatia

=cut

=head1 FUNCTIONS

=head2 boot

Start emulator, open L<Screen>, load initial ROM images, and render memory

  my $orao = Orao->new({});
  $orao->boot;

=cut

our $orao;

select(STDERR); $| = 1;

sub boot {
        my $self = shift;
        warn "Orao calling upstream init\n";
        $self->SUPER::init(
                read => sub { $self->read( @_ ) },
                write => sub { $self->write( @_ ) },
        );

        warn "Orao $Orao::VERSION emulation starting\n";

        warn "emulating ", $#mem, " bytes of memory\n";

        $self->open_screen;
        $self->load_rom({
                0x1000 => 'dump/SCRINV.BIN',
                # should be 0x6000, but oraoemu has 2 byte prefix
                0x5FFE => 'dump/screen.dmp',
#               0xC000 => 'rom/BAS12.ROM',
#               0xE000 => 'rom/CRT12.ROM',
                0xC000 => 'rom/BAS13.ROM',
                0xE000 => 'rom/CRT13.ROM',
        });

#       $PC = 0xDD11;   # BC
#       $PC = 0xC274;   # MC

        $PC = 0xff89;

        $orao = $self;

#       $self->prompt( 0x1000 );

        my ( $trace, $debug ) = ( $self->trace, $self->debug );
        $self->trace( 0 );
        $self->debug( 0 );

        $self->render( @mem[ 0x6000 .. 0x7fff ] );

        if ( $self->show_mem ) {

                warn "rendering memory map\n";

                $self->render_mem( @mem );

                my @mmap = (
                        0x0000, 0x03FF, 'nulti blok',
                        0x0400, 0x5FFF, 'korisnièki RAM (23K)',
                        0x6000, 0x7FFF, 'video RAM',
                        0x8000, 0x9FFF, 'sistemske lokacije',
                        0xA000, 0xAFFF, 'ekstenzija',
                        0xB000, 0xBFFF, 'DOS',
                        0xC000, 0xDFFF, 'BASIC ROM',
                        0xE000, 0xFFFF, 'sistemski ROM',
                );

        } else {

                warn "rendering video memory\n";
                $self->render( @mem[ 0x6000 .. 0x7fff ] );
        
        }
        $self->sync;
        $self->trace( $trace );
        $self->debug( $debug );

        #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );

        warn "Orao boot finished",
                $self->trace ? ' trace' : '',
                $self->debug ? ' debug' : '',
                "\n";

        M6502::reset();

        $self->booted( 1 );
}

=head2 run

Run interactive emulation loop

  $orao->run;

=cut

sub run {
        my $self = shift;

        $self->boot if ( ! $self->booted );
        $self->loop;
};

=head1 Helper functions

=head2 load_rom

called to init memory and load initial rom images

  $orao->load_rom;

=cut

sub load_rom {
    my ($self, $loaded_files) = @_;

    #my $time_base = time();

        foreach my $addr ( sort keys %$loaded_files ) {
                my $path = $loaded_files->{$addr};
                $self->load_image( $path, $addr );
        }
}

# write chunk directly into memory, updateing vram if needed
sub _write_chunk {
        my $self = shift;
        my ( $addr, $chunk ) = @_;
        $self->write_chunk( $addr, $chunk );
        my $end = $addr + length($chunk);
        my ( $f, $t ) = ( 0x6000, 0x7fff );

        if ( $end < $f || $addr >= $t ) {
                warn "skip vram update\n";
                return;
        };

        $f = $addr if ( $addr > $f );
        $t = $end if ( $end < $t );

        warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
#       foreach my $a ( $f .. $t ) {
#               $self->vram( $a - 0x6000 , $mem[ $a ] );
#       }
        $self->render( @mem[ 0x6000 .. 0x7fff ] );
        $self->render_mem( @mem ) if $self->show_mem;
}

=head2 load_image

Load binary files, ROM images and Orao Emulator files

  $orao->load_image( '/path/to/file', 0x1000 );

Returns true on success.

=cut

sub load_image {
        my $self = shift;
        my ( $path, $addr ) = @_;

        if ( ! -e $path ) {
                warn "ERROR: file $path doesn't exist\n";
                return;
        }

        my $size = -s $path || confess "no size for $path: $!";

        my $buff = read_file( $path );

        if ( $size == 65538 ) {
                $addr = 0;
                warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
                $self->_write_chunk( $addr, substr($buff,2) );
                return 1;
        } elsif ( $size == 32800 ) {
                $addr = 0;
                warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
                $self->_write_chunk( $addr, substr($buff,0x20) );
                return 1;
        }
        printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
        $self->_write_chunk( $addr, $buff );
        return 1;

        my $chunk;

        my $pos = 0;

        while ( my $long = substr($buff,$pos,4) ) {
                my @b = split(//, $long, 4);
                $chunk .=
                        ( $b[3] || '' ) .
                        ( $b[2] || '' ) .
                        ( $b[1] || '' ) .
                        ( $b[0] || '' );
                $pos += 4;
        }

        $self->_write_chunk( $addr, $chunk );

        return 1;
};

=head2 save_dump

  $orao->save_dump( 'filename', $from, $to );

=cut

sub save_dump {
        my $self = shift;

        my ( $path, $from, $to ) = @_;

        $from ||= 0;
        $to ||= 0xffff;

        open(my $fh, '>', $path) || die "can't open $path: $!";
        print $fh $self->read_chunk( $from, $to );
        close($fh);

        my $size = -s $path;
        warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
}

=head2 hexdump

  $orao->hexdump( $address );

=cut

sub hexdump {
        my $self = shift;
        my $a = shift;
        return sprintf(" %04x %s\n", $a,
                join(" ",
                        map {
                                if ( defined($_) ) {
                                        sprintf( "%02x", $_ )
                                } else {
                                        '  '
                                }
                        } @mem[ $a .. $a+8 ]
                )
        );
}

=head1 Memory management

Orao implements all I/O using mmap addresses. This was main reason why
L<Acme::6502> was just too slow to handle it.

=cut

=head2 read

Read from memory

  $byte = read( $address );

=cut

my $keyboard_none = 255;

my $keyboard = {
        0x87FC => {
                'right'         => 16,
                'down'          => 128,
                'up'            => 192,
                'left'          => 224,
                'backspace' => 224,
        },
        0x87FD => sub {
                my ( $self, $key ) = @_;
                if ( $key eq 'return' ) {
                        M6502::_write( 0xfc, 13 );
                        warn "return\n";
                        return 0;
                } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
                        warn "ctrl\n";
                        return 16;
                }
                return $keyboard_none;
        },
        0x87FA => {
                'f4' => 16,
                'f3' => 128,
                'f2' => 192,
                'f1' => 224,
        },
        0x87FB => sub {
                my ( $self, $key ) = @_;
                if ( $key eq 'space' ) {
                        return 32;
                } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
                        warn "shift\n";
                        return 16;
                }
                return $keyboard_none;
        },
        0x87F6 => {
                '6' => 16,
                't' => 128,
                'y' => 192,     # hr: z
                'r' => 224,
        },
        0x87F7 => {
                '5' => 32,
                '4' => 16,
        },
        0x87EE => {
                '7' => 16,
                'u' => 128,
                'i' => 192,
                'o' => 224,
        },
        0x87EF => {
                '8' => 32,
                '9' => 16,
        },
        0x87DE => {
                '1' => 16,
                'w' => 128,
                'q' => 192,
                'e' => 224,
        },
        0x87DF => {
                '2' => 32,
                '3' => 16,
        },
        0x87BE => {
                'm' => 16,
                'k' => 128,
                'j' => 192,
                'l' => 224,
        },
        0x87BF => {
                ',' => 32,      # <
                '.' => 16,      # >
        },
        0x877E => {
                'z' => 16,      # hr:y
                's' => 128,
                'a' => 192,
                'd' => 224,
        },
        0x877F => {
                'x' => 32,
                'c' => 16,
        },
        0x86FE => {
                'n' => 16,
                'g' => 128,
                'h' => 192,
                'f' => 224,
        },
        0x86FF => {
                'b' => 32,
                'v' => 16,
        },
        0x85FE => {
                '<' => 16,              # :
                '\\' => 128,    # ¾
                '\'' => 192,    # æ
                ';' => 224,             # è
        },
        0x85FF => {
                '/' => 32,
                'f11' => 16,    # ^
        },
        0x83FE => {
                'f12' => 16,    # ;
                '[' => 128,             # ¹
                ']' => 192,             # ð
                'p' => 224,
        },
        0x83FF => {
                '-' => 32,
                '0' => 16,
        },
};

sub read {
        my $self = shift;
        my ($addr) = @_;
        my $byte = $mem[$addr];
        confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
        warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;

        # keyboard

        if ( defined( $keyboard->{$addr} ) ) {
                warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
                my $key = $self->key_pressed;
                if ( defined($key) ) {
                        my $ret = $keyboard_none;
                        my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
                        if ( ref($r) eq 'CODE' ) {
                                $ret = $r->($self, $key);
                        } elsif ( defined($r->{$key}) ) {
                                $ret = $r->{$key};
                                if ( ref($ret) eq 'CODE' ) {
                                        $ret = $ret->($self);
                                }
                        } else {
                                warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
                        }
                        warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
                        return $ret;
                }
                return $keyboard_none;
        }

        $self->mmap_pixel( $addr, 0, $byte, 0 );
        return $byte;
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
        my $self = shift;
        my ($addr,$byte) = @_;
        warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;

        if ( $addr >= 0x6000 && $addr < 0x8000 ) {
#               $self->vram( $addr - 0x6000 , $byte );
        }

        if ( $addr == 0x8800 ) {
                warn sprintf "sound ignored: %x\n", $byte;
        }

        if ( $addr > 0xafff ) {
                confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
        }

        $self->mmap_pixel( $addr, $byte, 0, 0 );

        $mem[$addr] = $byte;
        return;
}

=head1 Command Line

Command-line debugging intrerface is implemented for communication with
emulated device

=head2 prompt

  my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );

=cut

my $last = 'r 1';

sub prompt {
        my $self = shift;
        $self->app->sync;
        my $a = shift;
        print $self->hexdump( $a ),
                $last ? "[$last] " : '',
                "> ";
        my $in = <STDIN>;
        chomp($in);
        warn "## prompt got: $in\n" if $self->debug;
        $in ||= $last;
        $last = $in;
        return ( $in, split(/\s+/, $in) ) if $in;
}

=head2 cli

  $orao->cli();

=cut

my $show_R = 0;

sub cli {
        my $self = shift;
        my $a = $PC || confess "no pc?"; 
        my $run_for = 0;
        warn $self->dump_R() if $show_R;
        while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
                my $c = shift @v;
                next unless defined($c);
                my $v = shift @v;
                $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
                @v = map { hex($_) } @v;
                printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
                if ( $c =~ m/^[qx]/i ) {
                        exit;
                } elsif ( $c eq '?' ) {
                        my $t = $self->trace ? 'on' : 'off' ;
                        my $d = $self->debug ? 'on' : 'off' ;
                        warn <<__USAGE__;
Usage:

x|q\t\texit
e 6000 6010\tdump memory, +/- to walk forward/backward
m 1000 ff 00\tput ff 00 on 1000
j|u 1000\t\tjump (change pc)
r 42\t\trun 42 instruction opcodes
t\t\ttrace [$t]
d\t\tdebug [$d]

__USAGE__
                        warn $self->dump_R;
                        $last = '';
                } elsif ( $c =~ m/^e/i ) {
                        $a = $v if defined($v);
                        my $to = shift @v;
                        $to = $a + 32 if ( ! $to || $to <= $a );
                        $to = 0xffff if ( $to > 0xffff );
                        my $lines = int( ($to - $a + 8) / 8 );
                        printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
                        while ( --$lines ) {
                                print $self->hexdump( $a );
                                $a += 8;
                        }
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^\+/ ) {
                        $a += 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^\-/ ) {
                        $a -= 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^m/i ) {
                        $a = $v if defined($v);
                        $self->poke_code( $a, @v );
                        printf "poke %d bytes at %04x\n", $#v + 1, $a;
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^l/i ) {
                        my $to = shift @v || 0x1000;
                        $a = $to;
                        $self->load_image( $v, $a );
                        $last = '';
                } elsif ( $c =~ m/^s/i ) {
                        $self->save_dump( $v || 'mem.dump', @v );
                        $last = '';
                } elsif ( $c =~ m/^r/i ) {
                        $run_for = $v || 1;
                        print "run_for $run_for instructions\n";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^(u|j)/ ) {
                        my $to = $v || $a;
                        printf "set pc to %04x\n", $to;
                        $PC = $to;      # remember for restart
                        $run_for = 1;
                        $last = "r $run_for";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^t/ ) {
                        $self->trace( not $self->trace );
                        print "trace ", $self->trace ? 'on' : 'off', "\n";
                        $last = '';
                } elsif ( $c =~ m/^d/ ) {
                        $self->debug( not $self->debug );
                        print "debug ", $self->debug ? 'on' : 'off', "\n";
                        $last = '';
                } else {
                        warn "# ignored $line\n" if ($line);
                        $last = '';
                }
        }

        return $run_for;
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 BUGS

=head1 ACKNOWLEDGEMENTS

See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
info about this machine (and even hardware implementation from 2007).

=head1 COPYRIGHT & LICENSE

Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Orao
1	dpavlin	29	package Orao;
2
3			use warnings;
4			use strict;
5
6	dpavlin	56	use Carp qw/confess/;
7	dpavlin	29	use lib './lib';
8			#use Time::HiRes qw(time);
9			use File::Slurp;
10	dpavlin	32	use Data::Dump qw/dump/;
11	dpavlin	34	use M6502;
12	dpavlin	29
13	dpavlin	56	use base qw(Class::Accessor M6502 Screen Prefs);
14	dpavlin	96	__PACKAGE__->mk_accessors(qw(booted));
15	dpavlin	29
16			=head1 NAME
17
18			Orao - Orao emulator
19
20			=head1 VERSION
21
22	dpavlin	95	Version 0.04
23	dpavlin	29
24			=cut
25
26	dpavlin	95	our $VERSION = '0.04';
27	dpavlin	29
28			=head1 SUMMARY
29
30			Emulator or Orao 8-bit 6502 machine popular in Croatia
31
32			=cut
33
34	dpavlin	95	=head1 FUNCTIONS
35
36	dpavlin	82	=head2 boot
37	dpavlin	30
38	dpavlin	56	Start emulator, open L<Screen>, load initial ROM images, and render memory
39	dpavlin	30
40	dpavlin	82	my $orao = Orao->new({});
41			$orao->boot;
42
43	dpavlin	30	=cut
44
45	dpavlin	32	our $orao;
46
47	dpavlin	42	select(STDERR); $\| = 1;
48
49	dpavlin	82	sub boot {
50	dpavlin	30	my $self = shift;
51	dpavlin	34	warn "Orao calling upstream init\n";
52	dpavlin	90	$self->SUPER::init(
53			read => sub { $self->read( @_ ) },
54			write => sub { $self->write( @_ ) },
55			);
56	dpavlin	30
57	dpavlin	56	warn "Orao $Orao::VERSION emulation starting\n";
58	dpavlin	30
59	dpavlin	90	warn "emulating ", $#mem, " bytes of memory\n";
60
61	dpavlin	30	$self->open_screen;
62	dpavlin	33	$self->load_rom({
63			0x1000 => 'dump/SCRINV.BIN',
64	dpavlin	76	# should be 0x6000, but oraoemu has 2 byte prefix
65			0x5FFE => 'dump/screen.dmp',
66	dpavlin	106	# 0xC000 => 'rom/BAS12.ROM',
67			# 0xE000 => 'rom/CRT12.ROM',
68			0xC000 => 'rom/BAS13.ROM',
69			0xE000 => 'rom/CRT13.ROM',
70	dpavlin	33	});
71	dpavlin	32
72	dpavlin	73	# $PC = 0xDD11; # BC
73	dpavlin	46	# $PC = 0xC274; # MC
74	dpavlin	35
75	dpavlin	78	$PC = 0xff89;
76
77	dpavlin	32	$orao = $self;
78
79	dpavlin	33	# $self->prompt( 0x1000 );
80
81	dpavlin	49	my ( $trace, $debug ) = ( $self->trace, $self->debug );
82	dpavlin	38	$self->trace( 0 );
83	dpavlin	49	$self->debug( 0 );
84	dpavlin	33
85	dpavlin	73	$self->render( @mem[ 0x6000 .. 0x7fff ] );
86
87	dpavlin	38	if ( $self->show_mem ) {
88	dpavlin	33
89	dpavlin	38	warn "rendering memory map\n";
90
91	dpavlin	76	$self->render_mem( @mem );
92
93	dpavlin	38	my @mmap = (
94			0x0000, 0x03FF, 'nulti blok',
95			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
96			0x6000, 0x7FFF, 'video RAM',
97			0x8000, 0x9FFF, 'sistemske lokacije',
98			0xA000, 0xAFFF, 'ekstenzija',
99			0xB000, 0xBFFF, 'DOS',
100			0xC000, 0xDFFF, 'BASIC ROM',
101			0xE000, 0xFFFF, 'sistemski ROM',
102			);
103
104			} else {
105
106			warn "rendering video memory\n";
107	dpavlin	73	$self->render( @mem[ 0x6000 .. 0x7fff ] );
108	dpavlin	38
109	dpavlin	33	}
110	dpavlin	38	$self->sync;
111			$self->trace( $trace );
112	dpavlin	49	$self->debug( $debug );
113	dpavlin	33
114	dpavlin	39	#( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
115	dpavlin	34
116	dpavlin	82	warn "Orao boot finished",
117	dpavlin	49	$self->trace ? ' trace' : '',
118			$self->debug ? ' debug' : '',
119			"\n";
120	dpavlin	38
121	dpavlin	82	M6502::reset();
122
123	dpavlin	95	$self->booted( 1 );
124	dpavlin	30	}
125
126	dpavlin	95	=head2 run
127
128			Run interactive emulation loop
129
130			$orao->run;
131
132			=cut
133
134			sub run {
135			my $self = shift;
136
137			$self->boot if ( ! $self->booted );
138	dpavlin	96	$self->loop;
139	dpavlin	95	};
140
141			=head1 Helper functions
142
143	dpavlin	29	=head2 load_rom
144
145			called to init memory and load initial rom images
146
147			$orao->load_rom;
148
149			=cut
150
151			sub load_rom {
152	dpavlin	33	my ($self, $loaded_files) = @_;
153	dpavlin	29
154			#my $time_base = time();
155
156			foreach my $addr ( sort keys %$loaded_files ) {
157			my $path = $loaded_files->{$addr};
158	dpavlin	94	$self->load_image( $path, $addr );
159	dpavlin	29	}
160			}
161
162	dpavlin	61	# write chunk directly into memory, updateing vram if needed
163	dpavlin	46	sub _write_chunk {
164			my $self = shift;
165			my ( $addr, $chunk ) = @_;
166			$self->write_chunk( $addr, $chunk );
167			my $end = $addr + length($chunk);
168			my ( $f, $t ) = ( 0x6000, 0x7fff );
169
170			if ( $end < $f \|\| $addr >= $t ) {
171			warn "skip vram update\n";
172			return;
173			};
174
175			$f = $addr if ( $addr > $f );
176			$t = $end if ( $end < $t );
177
178			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
179	dpavlin	73	# foreach my $a ( $f .. $t ) {
180			# $self->vram( $a - 0x6000 , $mem[ $a ] );
181			# }
182			$self->render( @mem[ 0x6000 .. 0x7fff ] );
183	dpavlin	77	$self->render_mem( @mem ) if $self->show_mem;
184	dpavlin	46	}
185
186	dpavlin	94	=head2 load_image
187	dpavlin	61
188			Load binary files, ROM images and Orao Emulator files
189
190	dpavlin	94	$orao->load_image( '/path/to/file', 0x1000 );
191	dpavlin	61
192			Returns true on success.
193
194			=cut
195
196	dpavlin	94	sub load_image {
197	dpavlin	29	my $self = shift;
198			my ( $path, $addr ) = @_;
199
200	dpavlin	61	if ( ! -e $path ) {
201			warn "ERROR: file $path doesn't exist\n";
202			return;
203			}
204
205	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
206	dpavlin	29
207			my $buff = read_file( $path );
208
209			if ( $size == 65538 ) {
210			$addr = 0;
211	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
212	dpavlin	46	$self->_write_chunk( $addr, substr($buff,2) );
213	dpavlin	61	return 1;
214	dpavlin	29	} elsif ( $size == 32800 ) {
215			$addr = 0;
216	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
217	dpavlin	46	$self->_write_chunk( $addr, substr($buff,0x20) );
218	dpavlin	61	return 1;
219	dpavlin	29	}
220	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
221	dpavlin	61	$self->_write_chunk( $addr, $buff );
222			return 1;
223	dpavlin	29
224			my $chunk;
225
226			my $pos = 0;
227
228			while ( my $long = substr($buff,$pos,4) ) {
229			my @b = split(//, $long, 4);
230			$chunk .=
231			( $b[3] \|\| '' ) .
232			( $b[2] \|\| '' ) .
233			( $b[1] \|\| '' ) .
234			( $b[0] \|\| '' );
235			$pos += 4;
236			}
237
238	dpavlin	46	$self->_write_chunk( $addr, $chunk );
239	dpavlin	29
240	dpavlin	61	return 1;
241	dpavlin	29	};
242
243			=head2 save_dump
244
245			$orao->save_dump( 'filename', $from, $to );
246
247			=cut
248
249			sub save_dump {
250			my $self = shift;
251
252			my ( $path, $from, $to ) = @_;
253
254			$from \|\|= 0;
255			$to \|\|= 0xffff;
256
257			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
258			print $fh $self->read_chunk( $from, $to );
259			close($fh);
260
261			my $size = -s $path;
262	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
263	dpavlin	29	}
264
265			=head2 hexdump
266
267			$orao->hexdump( $address );
268
269			=cut
270
271			sub hexdump {
272			my $self = shift;
273			my $a = shift;
274			return sprintf(" %04x %s\n", $a,
275			join(" ",
276			map {
277	dpavlin	71	if ( defined($_) ) {
278			sprintf( "%02x", $_ )
279			} else {
280			' '
281			}
282	dpavlin	47	} @mem[ $a .. $a+8 ]
283	dpavlin	29	)
284			);
285			}
286
287	dpavlin	32	=head1 Memory management
288	dpavlin	30
289	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
290			L<Acme::6502> was just too slow to handle it.
291
292			=cut
293
294			=head2 read
295
296			Read from memory
297
298			$byte = read( $address );
299
300			=cut
301
302	dpavlin	105	my $keyboard_none = 255;
303
304	dpavlin	98	my $keyboard = {
305			0x87FC => {
306			'right' => 16,
307			'down' => 128,
308			'up' => 192,
309			'left' => 224,
310			'backspace' => 224,
311			},
312	dpavlin	103	0x87FD => sub {
313			my ( $self, $key ) = @_;
314			if ( $key eq 'return' ) {
315	dpavlin	101	M6502::_write( 0xfc, 13 );
316	dpavlin	105	warn "return\n";
317	dpavlin	98	return 0;
318	dpavlin	105	} elsif ( $key =~ m/ ctrl/ \|\| $self->key_down( 'left ctrl' ) \|\| $self->key_down( 'right ctrl' ) ) {
319			warn "ctrl\n";
320	dpavlin	103	return 16;
321			}
322	dpavlin	105	return $keyboard_none;
323	dpavlin	98	},
324			0x87FA => {
325			'f4' => 16,
326			'f3' => 128,
327			'f2' => 192,
328			'f1' => 224,
329			},
330	dpavlin	103	0x87FB => sub {
331			my ( $self, $key ) = @_;
332			if ( $key eq 'space' ) {
333			return 32;
334			} elsif ( $self->key_down( 'left shift' ) \|\| $self->key_down( 'right shift' ) ) {
335	dpavlin	105	warn "shift\n";
336	dpavlin	103	return 16;
337			}
338	dpavlin	105	return $keyboard_none;
339	dpavlin	98	},
340			0x87F6 => {
341			'6' => 16,
342			't' => 128,
343	dpavlin	105	'y' => 192, # hr: z
344	dpavlin	98	'r' => 224,
345			},
346			0x87F7 => {
347			'5' => 32,
348			'4' => 16,
349			},
350			0x87EE => {
351			'7' => 16,
352			'u' => 128,
353			'i' => 192,
354			'o' => 224,
355			},
356			0x87EF => {
357			'8' => 32,
358			'9' => 16,
359			},
360			0x87DE => {
361			'1' => 16,
362			'w' => 128,
363			'q' => 192,
364			'e' => 224,
365			},
366			0x87DF => {
367			'2' => 32,
368			'3' => 16,
369			},
370			0x87BE => {
371			'm' => 16,
372			'k' => 128,
373			'j' => 192,
374			'l' => 224,
375			},
376			0x87BF => {
377	dpavlin	105	',' => 32, # <
378			'.' => 16, # >
379	dpavlin	98	},
380			0x877E => {
381	dpavlin	105	'z' => 16, # hr:y
382	dpavlin	98	's' => 128,
383			'a' => 192,
384			'd' => 224,
385			},
386			0x877F => {
387			'x' => 32,
388			'c' => 16,
389			},
390			0x86FE => {
391			'n' => 16,
392			'g' => 128,
393			'h' => 192,
394			'f' => 224,
395			},
396			0x86FF => {
397			'b' => 32,
398	dpavlin	102	'v' => 16,
399	dpavlin	98	},
400			0x85FE => {
401	dpavlin	105	'<' => 16, # :
402			'\\' => 128, # ¾
403			'\'' => 192, # æ
404			';' => 224, # è
405	dpavlin	98	},
406			0x85FF => {
407			'/' => 32,
408	dpavlin	105	'f11' => 16, # ^
409	dpavlin	98	},
410			0x83FE => {
411	dpavlin	105	'f12' => 16, # ;
412			'[' => 128, # ¹
413			']' => 192, # ð
414	dpavlin	98	'p' => 224,
415			},
416			0x83FF => {
417			'-' => 32,
418			'0' => 16,
419			},
420			};
421
422	dpavlin	32	sub read {
423	dpavlin	33	my $self = shift;
424	dpavlin	32	my ($addr) = @_;
425			my $byte = $mem[$addr];
426	dpavlin	90	confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
427	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
428	dpavlin	78
429			# keyboard
430
431	dpavlin	105	if ( defined( $keyboard->{$addr} ) ) {
432	dpavlin	97	warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
433	dpavlin	99	my $key = $self->key_pressed;
434			if ( defined($key) ) {
435	dpavlin	103	my $ret = $keyboard_none;
436	dpavlin	98	my $r = $keyboard->{$addr} \|\| confess "no definition for keyboard port found";
437	dpavlin	103	if ( ref($r) eq 'CODE' ) {
438			$ret = $r->($self, $key);
439	dpavlin	105	} elsif ( defined($r->{$key}) ) {
440			$ret = $r->{$key};
441	dpavlin	98	if ( ref($ret) eq 'CODE' ) {
442	dpavlin	103	$ret = $ret->($self);
443	dpavlin	98	}
444			} else {
445	dpavlin	99	warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
446	dpavlin	98	}
447	dpavlin	105	warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
448			return $ret;
449	dpavlin	98	}
450	dpavlin	101	return $keyboard_none;
451	dpavlin	78	}
452
453	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
454	dpavlin	32	return $byte;
455			}
456
457			=head2 write
458
459			Write into emory
460
461			write( $address, $byte );
462
463			=cut
464
465			sub write {
466	dpavlin	33	my $self = shift;
467	dpavlin	32	my ($addr,$byte) = @_;
468	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
469	dpavlin	32
470			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
471	dpavlin	106	# $self->vram( $addr - 0x6000 , $byte );
472	dpavlin	32	}
473
474			if ( $addr == 0x8800 ) {
475			warn sprintf "sound ignored: %x\n", $byte;
476			}
477
478	dpavlin	52	if ( $addr > 0xafff ) {
479	dpavlin	90	confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
480	dpavlin	52	}
481
482	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
483	dpavlin	32
484			$mem[$addr] = $byte;
485	dpavlin	36	return;
486	dpavlin	32	}
487
488	dpavlin	42	=head1 Command Line
489	dpavlin	32
490	dpavlin	42	Command-line debugging intrerface is implemented for communication with
491			emulated device
492
493	dpavlin	50	=head2 prompt
494
495	dpavlin	61	my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
496	dpavlin	50
497			=cut
498
499			my $last = 'r 1';
500
501			sub prompt {
502			my $self = shift;
503			$self->app->sync;
504			my $a = shift;
505	dpavlin	97	print $self->hexdump( $a ),
506	dpavlin	50	$last ? "[$last] " : '',
507			"> ";
508			my $in = <STDIN>;
509			chomp($in);
510			warn "## prompt got: $in\n" if $self->debug;
511			$in \|\|= $last;
512			$last = $in;
513	dpavlin	61	return ( $in, split(/\s+/, $in) ) if $in;
514	dpavlin	50	}
515
516	dpavlin	42	=head2 cli
517
518			$orao->cli();
519
520			=cut
521
522	dpavlin	68	my $show_R = 0;
523
524	dpavlin	42	sub cli {
525			my $self = shift;
526			my $a = $PC \|\| confess "no pc?";
527	dpavlin	96	my $run_for = 0;
528	dpavlin	68	warn $self->dump_R() if $show_R;
529	dpavlin	61	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
530	dpavlin	42	my $c = shift @v;
531	dpavlin	61	next unless defined($c);
532	dpavlin	42	my $v = shift @v;
533			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
534			@v = map { hex($_) } @v;
535	dpavlin	49	printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
536	dpavlin	42	if ( $c =~ m/^[qx]/i ) {
537			exit;
538			} elsif ( $c eq '?' ) {
539	dpavlin	50	my $t = $self->trace ? 'on' : 'off' ;
540			my $d = $self->debug ? 'on' : 'off' ;
541	dpavlin	42	warn <<__USAGE__;
542	dpavlin	50	Usage:
543
544	dpavlin	42	x\|q\t\texit
545			e 6000 6010\tdump memory, +/- to walk forward/backward
546			m 1000 ff 00\tput ff 00 on 1000
547			j\|u 1000\t\tjump (change pc)
548			r 42\t\trun 42 instruction opcodes
549	dpavlin	50	t\t\ttrace [$t]
550			d\t\tdebug [$d]
551
552	dpavlin	42	__USAGE__
553	dpavlin	68	warn $self->dump_R;
554	dpavlin	97	$last = '';
555	dpavlin	42	} elsif ( $c =~ m/^e/i ) {
556	dpavlin	49	$a = $v if defined($v);
557	dpavlin	42	my $to = shift @v;
558			$to = $a + 32 if ( ! $to \|\| $to <= $a );
559	dpavlin	71	$to = 0xffff if ( $to > 0xffff );
560	dpavlin	59	my $lines = int( ($to - $a + 8) / 8 );
561			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
562			while ( --$lines ) {
563	dpavlin	42	print $self->hexdump( $a );
564			$a += 8;
565			}
566			$last = '+';
567	dpavlin	68	$show_R = 0;
568	dpavlin	42	} elsif ( $c =~ m/^\+/ ) {
569			$a += 8;
570	dpavlin	68	$show_R = 0;
571	dpavlin	42	} elsif ( $c =~ m/^\-/ ) {
572			$a -= 8;
573	dpavlin	68	$show_R = 0;
574	dpavlin	42	} elsif ( $c =~ m/^m/i ) {
575	dpavlin	70	$a = $v if defined($v);
576	dpavlin	42	$self->poke_code( $a, @v );
577			printf "poke %d bytes at %04x\n", $#v + 1, $a;
578	dpavlin	50	$last = '+';
579	dpavlin	68	$show_R = 0;
580	dpavlin	42	} elsif ( $c =~ m/^l/i ) {
581			my $to = shift @v \|\| 0x1000;
582			$a = $to;
583	dpavlin	94	$self->load_image( $v, $a );
584	dpavlin	50	$last = '';
585	dpavlin	42	} elsif ( $c =~ m/^s/i ) {
586			$self->save_dump( $v \|\| 'mem.dump', @v );
587	dpavlin	50	$last = '';
588	dpavlin	42	} elsif ( $c =~ m/^r/i ) {
589			$run_for = $v \|\| 1;
590			print "run_for $run_for instructions\n";
591	dpavlin	68	$show_R = 1;
592	dpavlin	42	last;
593			} elsif ( $c =~ m/^(u\|j)/ ) {
594			my $to = $v \|\| $a;
595			printf "set pc to %04x\n", $to;
596			$PC = $to; # remember for restart
597			$run_for = 1;
598	dpavlin	62	$last = "r $run_for";
599	dpavlin	68	$show_R = 1;
600	dpavlin	42	last;
601			} elsif ( $c =~ m/^t/ ) {
602			$self->trace( not $self->trace );
603			print "trace ", $self->trace ? 'on' : 'off', "\n";
604	dpavlin	64	$last = '';
605	dpavlin	49	} elsif ( $c =~ m/^d/ ) {
606			$self->debug( not $self->debug );
607			print "debug ", $self->debug ? 'on' : 'off', "\n";
608	dpavlin	64	$last = '';
609	dpavlin	42	} else {
610	dpavlin	61	warn "# ignored $line\n" if ($line);
611			$last = '';
612	dpavlin	42	}
613			}
614
615	dpavlin	96	return $run_for;
616	dpavlin	42	}
617
618	dpavlin	29	=head1 AUTHOR
619
620			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
621
622			=head1 BUGS
623
624			=head1 ACKNOWLEDGEMENTS
625
626			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
627			info about this machine (and even hardware implementation from 2007).
628
629			=head1 COPYRIGHT & LICENSE
630
631			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
632
633			This program is free software; you can redistribute it and/or modify it
634			under the same terms as Perl itself.
635
636			=cut
637
638			1; # End of Orao