VRac/M6502/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 List::Util qw/first/;
use M6502;

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

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SUMMARY

Emulator or Orao 8-bit 6502 machine popular in Croatia

=cut

my @kbd_ports = (
    0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
    0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
    0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
    0x83FE,0x83FF,
);

=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',
        });

#       $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();

}

=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_oraoemu( $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_oraoemu

Load binary files, ROM images and Orao Emulator files

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

Returns true on success.

=cut

sub load_oraoemu {
        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

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 ( first { $addr == $_ } @kbd_ports ) {
                warn sprintf("keyboard port: %04x\n",$addr);
        } elsif ( $addr == 0x87fc ) {
                warn "0x87fc - arrows/back\n";
=for pascal
                if VKey=VK_RIGHT then Result:=16;
                if VKey=VK_DOWN then Result:=128;
                if VKey=VK_UP then Result:=192;
                if VKey=VK_LEFT then Result:=224;
                if Ord(KeyPressed)=VK_BACK then Result:=224;
=cut
        } elsif ( $addr == 0x87fd ) {
                warn "0x87fd - enter\n";
=for pascal
    if KeyPressed=Chr(13) then begin
      Mem[$FC]:=13;
      Result:=0;
    end;
=cut
        } elsif ( $addr == 0x87fa ) {
                warn "0x87fa = F1 - F4\n";
=for pascal
    if VKey=VK_F4 then Result:=16;
    if VKey=VK_F3 then Result:=128;
    if VKey=VK_F2 then Result:=192;
    if VKey=VK_F1 then Result:=224;
=cut
        } elsif ( $addr == 0x87fb ) {
                warn "0x87fb\n";
=for pascal
    if KeyPressed=Chr(32) then Result:=32;
    if KeyPressed='"' then Result:=16;
    if KeyPressed='!' then Result:=16;
    if KeyPressed='$' then Result:=16;
    if KeyPressed='%' then Result:=16;
    if KeyPressed='&' then Result:=16;
    if KeyPressed='(' then Result:=16;
    if KeyPressed=')' then Result:=16;
    if KeyPressed='=' then Result:=16;
    if KeyPressed='#' then Result:=16;
    if KeyPressed='+' then Result:=16;
    if KeyPressed='*' then Result:=16;
    if KeyPressed='?' then Result:=16;
    if KeyPressed='<' then Result:=16;
    if KeyPressed='>' then Result:=16;
    if VKey=191 then Result:=16;
=cut
        }

        $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 STDERR $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?"; 
        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;
                } 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_oraoemu( $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 = '';
                }
        }

}

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