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->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);
        } 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?"; 
        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;
                } 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			$self->boot if ( ! $self->booted );
144	dpavlin	96	$self->loop;
145	dpavlin	95	};
146
147			=head1 Helper functions
148
149	dpavlin	29	=head2 load_rom
150
151			called to init memory and load initial rom images
152
153			$orao->load_rom;
154
155			=cut
156
157			sub load_rom {
158	dpavlin	33	my ($self, $loaded_files) = @_;
159	dpavlin	29
160			#my $time_base = time();
161
162			foreach my $addr ( sort keys %$loaded_files ) {
163			my $path = $loaded_files->{$addr};
164	dpavlin	94	$self->load_image( $path, $addr );
165	dpavlin	29	}
166			}
167
168	dpavlin	61	# write chunk directly into memory, updateing vram if needed
169	dpavlin	46	sub _write_chunk {
170			my $self = shift;
171			my ( $addr, $chunk ) = @_;
172			$self->write_chunk( $addr, $chunk );
173			my $end = $addr + length($chunk);
174			my ( $f, $t ) = ( 0x6000, 0x7fff );
175
176			if ( $end < $f \|\| $addr >= $t ) {
177			warn "skip vram update\n";
178			return;
179			};
180
181			$f = $addr if ( $addr > $f );
182			$t = $end if ( $end < $t );
183
184			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
185	dpavlin	73	# foreach my $a ( $f .. $t ) {
186			# $self->vram( $a - 0x6000 , $mem[ $a ] );
187			# }
188			$self->render( @mem[ 0x6000 .. 0x7fff ] );
189	dpavlin	77	$self->render_mem( @mem ) if $self->show_mem;
190	dpavlin	46	}
191
192	dpavlin	94	=head2 load_image
193	dpavlin	61
194			Load binary files, ROM images and Orao Emulator files
195
196	dpavlin	94	$orao->load_image( '/path/to/file', 0x1000 );
197	dpavlin	61
198			Returns true on success.
199
200			=cut
201
202	dpavlin	94	sub load_image {
203	dpavlin	29	my $self = shift;
204			my ( $path, $addr ) = @_;
205
206	dpavlin	61	if ( ! -e $path ) {
207			warn "ERROR: file $path doesn't exist\n";
208			return;
209			}
210
211	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
212	dpavlin	29
213			my $buff = read_file( $path );
214
215			if ( $size == 65538 ) {
216			$addr = 0;
217	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
218	dpavlin	46	$self->_write_chunk( $addr, substr($buff,2) );
219	dpavlin	61	return 1;
220	dpavlin	29	} elsif ( $size == 32800 ) {
221			$addr = 0;
222	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
223	dpavlin	46	$self->_write_chunk( $addr, substr($buff,0x20) );
224	dpavlin	61	return 1;
225	dpavlin	29	}
226	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
227	dpavlin	61	$self->_write_chunk( $addr, $buff );
228			return 1;
229	dpavlin	29
230			my $chunk;
231
232			my $pos = 0;
233
234			while ( my $long = substr($buff,$pos,4) ) {
235			my @b = split(//, $long, 4);
236			$chunk .=
237			( $b[3] \|\| '' ) .
238			( $b[2] \|\| '' ) .
239			( $b[1] \|\| '' ) .
240			( $b[0] \|\| '' );
241			$pos += 4;
242			}
243
244	dpavlin	46	$self->_write_chunk( $addr, $chunk );
245	dpavlin	29
246	dpavlin	61	return 1;
247	dpavlin	29	};
248
249			=head2 save_dump
250
251			$orao->save_dump( 'filename', $from, $to );
252
253			=cut
254
255			sub save_dump {
256			my $self = shift;
257
258			my ( $path, $from, $to ) = @_;
259
260			$from \|\|= 0;
261			$to \|\|= 0xffff;
262
263			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
264			print $fh $self->read_chunk( $from, $to );
265			close($fh);
266
267			my $size = -s $path;
268	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
269	dpavlin	29	}
270
271			=head2 hexdump
272
273			$orao->hexdump( $address );
274
275			=cut
276
277			sub hexdump {
278			my $self = shift;
279			my $a = shift;
280			return sprintf(" %04x %s\n", $a,
281			join(" ",
282			map {
283	dpavlin	71	if ( defined($_) ) {
284			sprintf( "%02x", $_ )
285			} else {
286			' '
287			}
288	dpavlin	47	} @mem[ $a .. $a+8 ]
289	dpavlin	29	)
290			);
291			}
292
293	dpavlin	32	=head1 Memory management
294	dpavlin	30
295	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
296			L<Acme::6502> was just too slow to handle it.
297
298			=cut
299
300			=head2 read
301
302			Read from memory
303
304			$byte = read( $address );
305
306			=cut
307
308			sub read {
309	dpavlin	33	my $self = shift;
310	dpavlin	32	my ($addr) = @_;
311			my $byte = $mem[$addr];
312	dpavlin	90	confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
313	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
314	dpavlin	78
315			# keyboard
316
317			if ( first { $addr == $_ } @kbd_ports ) {
318			warn sprintf("keyboard port: %04x\n",$addr);
319			} elsif ( $addr == 0x87fc ) {
320			warn "0x87fc - arrows/back\n";
321			=for pascal
322			if VKey=VK_RIGHT then Result:=16;
323			if VKey=VK_DOWN then Result:=128;
324			if VKey=VK_UP then Result:=192;
325			if VKey=VK_LEFT then Result:=224;
326			if Ord(KeyPressed)=VK_BACK then Result:=224;
327			=cut
328			} elsif ( $addr == 0x87fd ) {
329			warn "0x87fd - enter\n";
330			=for pascal
331			if KeyPressed=Chr(13) then begin
332			Mem[$FC]:=13;
333			Result:=0;
334			end;
335			=cut
336			} elsif ( $addr == 0x87fa ) {
337			warn "0x87fa = F1 - F4\n";
338			=for pascal
339			if VKey=VK_F4 then Result:=16;
340			if VKey=VK_F3 then Result:=128;
341			if VKey=VK_F2 then Result:=192;
342			if VKey=VK_F1 then Result:=224;
343			=cut
344			} elsif ( $addr == 0x87fb ) {
345			warn "0x87fb\n";
346			=for pascal
347			if KeyPressed=Chr(32) then Result:=32;
348			if KeyPressed='"' then Result:=16;
349			if KeyPressed='!' then Result:=16;
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 VKey=191 then Result:=16;
363			=cut
364			}
365
366	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
367	dpavlin	32	return $byte;
368			}
369
370			=head2 write
371
372			Write into emory
373
374			write( $address, $byte );
375
376			=cut
377
378			sub write {
379	dpavlin	33	my $self = shift;
380	dpavlin	32	my ($addr,$byte) = @_;
381	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
382	dpavlin	32
383			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
384			$self->vram( $addr - 0x6000 , $byte );
385			}
386
387			if ( $addr == 0x8800 ) {
388			warn sprintf "sound ignored: %x\n", $byte;
389			}
390
391	dpavlin	52	if ( $addr > 0xafff ) {
392	dpavlin	90	confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
393	dpavlin	52	}
394
395	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
396	dpavlin	32
397			$mem[$addr] = $byte;
398	dpavlin	36	return;
399	dpavlin	32	}
400
401	dpavlin	42	=head1 Command Line
402	dpavlin	32
403	dpavlin	42	Command-line debugging intrerface is implemented for communication with
404			emulated device
405
406	dpavlin	50	=head2 prompt
407
408	dpavlin	61	my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
409	dpavlin	50
410			=cut
411
412			my $last = 'r 1';
413
414			sub prompt {
415			my $self = shift;
416			$self->app->sync;
417			my $a = shift;
418			print STDERR $self->hexdump( $a ),
419			$last ? "[$last] " : '',
420			"> ";
421			my $in = <STDIN>;
422			chomp($in);
423			warn "## prompt got: $in\n" if $self->debug;
424			$in \|\|= $last;
425			$last = $in;
426	dpavlin	61	return ( $in, split(/\s+/, $in) ) if $in;
427	dpavlin	50	}
428
429	dpavlin	42	=head2 cli
430
431			$orao->cli();
432
433			=cut
434
435	dpavlin	68	my $show_R = 0;
436
437	dpavlin	42	sub cli {
438			my $self = shift;
439			my $a = $PC \|\| confess "no pc?";
440	dpavlin	96	my $run_for = 0;
441	dpavlin	68	warn $self->dump_R() if $show_R;
442	dpavlin	61	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
443	dpavlin	42	my $c = shift @v;
444	dpavlin	61	next unless defined($c);
445	dpavlin	42	my $v = shift @v;
446			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
447			@v = map { hex($_) } @v;
448	dpavlin	49	printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
449	dpavlin	42	if ( $c =~ m/^[qx]/i ) {
450			exit;
451			} elsif ( $c eq '?' ) {
452	dpavlin	50	my $t = $self->trace ? 'on' : 'off' ;
453			my $d = $self->debug ? 'on' : 'off' ;
454	dpavlin	42	warn <<__USAGE__;
455	dpavlin	50	Usage:
456
457	dpavlin	42	x\|q\t\texit
458			e 6000 6010\tdump memory, +/- to walk forward/backward
459			m 1000 ff 00\tput ff 00 on 1000
460			j\|u 1000\t\tjump (change pc)
461			r 42\t\trun 42 instruction opcodes
462	dpavlin	50	t\t\ttrace [$t]
463			d\t\tdebug [$d]
464
465	dpavlin	42	__USAGE__
466	dpavlin	68	warn $self->dump_R;
467	dpavlin	42	} elsif ( $c =~ m/^e/i ) {
468	dpavlin	49	$a = $v if defined($v);
469	dpavlin	42	my $to = shift @v;
470			$to = $a + 32 if ( ! $to \|\| $to <= $a );
471	dpavlin	71	$to = 0xffff if ( $to > 0xffff );
472	dpavlin	59	my $lines = int( ($to - $a + 8) / 8 );
473			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
474			while ( --$lines ) {
475	dpavlin	42	print $self->hexdump( $a );
476			$a += 8;
477			}
478			$last = '+';
479	dpavlin	68	$show_R = 0;
480	dpavlin	42	} elsif ( $c =~ m/^\+/ ) {
481			$a += 8;
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/^m/i ) {
487	dpavlin	70	$a = $v if defined($v);
488	dpavlin	42	$self->poke_code( $a, @v );
489			printf "poke %d bytes at %04x\n", $#v + 1, $a;
490	dpavlin	50	$last = '+';
491	dpavlin	68	$show_R = 0;
492	dpavlin	42	} elsif ( $c =~ m/^l/i ) {
493			my $to = shift @v \|\| 0x1000;
494			$a = $to;
495	dpavlin	94	$self->load_image( $v, $a );
496	dpavlin	50	$last = '';
497	dpavlin	42	} elsif ( $c =~ m/^s/i ) {
498			$self->save_dump( $v \|\| 'mem.dump', @v );
499	dpavlin	50	$last = '';
500	dpavlin	42	} elsif ( $c =~ m/^r/i ) {
501			$run_for = $v \|\| 1;
502			print "run_for $run_for instructions\n";
503	dpavlin	68	$show_R = 1;
504	dpavlin	42	last;
505			} elsif ( $c =~ m/^(u\|j)/ ) {
506			my $to = $v \|\| $a;
507			printf "set pc to %04x\n", $to;
508			$PC = $to; # remember for restart
509			$run_for = 1;
510	dpavlin	62	$last = "r $run_for";
511	dpavlin	68	$show_R = 1;
512	dpavlin	42	last;
513			} elsif ( $c =~ m/^t/ ) {
514			$self->trace( not $self->trace );
515			print "trace ", $self->trace ? 'on' : 'off', "\n";
516	dpavlin	64	$last = '';
517	dpavlin	49	} elsif ( $c =~ m/^d/ ) {
518			$self->debug( not $self->debug );
519			print "debug ", $self->debug ? 'on' : 'off', "\n";
520	dpavlin	64	$last = '';
521	dpavlin	42	} else {
522	dpavlin	61	warn "# ignored $line\n" if ($line);
523			$last = '';
524	dpavlin	42	}
525			}
526
527	dpavlin	96	return $run_for;
528	dpavlin	42	}
529
530	dpavlin	29	=head1 AUTHOR
531
532			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
533
534			=head1 BUGS
535
536			=head1 ACKNOWLEDGEMENTS
537
538			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
539			info about this machine (and even hardware implementation from 2007).
540
541			=head1 COPYRIGHT & LICENSE
542
543			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
544
545			This program is free software; you can redistribute it and/or modify it
546			under the same terms as Perl itself.
547
548			=cut
549
550			1; # End of Orao