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 Tape);
__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 );

        warn "rendering video memory\n";
        $self->render_vram( @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',
                );

        }
        $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);
        $self->render_vram( @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;
        }

        if ( $addr == 0x87ff ) {
                return $self->read_tape;
        }

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