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 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.02

=cut

our $VERSION = '0.02';

=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 init

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

=cut

our $orao;

select(STDERR); $| = 1;

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

        warn "Orao $Orao::VERSION emulation starting\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 init finished",
                $self->trace ? ' trace' : '',
                $self->debug ? ' debug' : '',
                "\n";

}

=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];
        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 ) {
                warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
                return;
        }

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