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(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

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

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

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

        $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

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