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 run_for));

=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 );

        while ( 1 ) {
                $self->cli;
                M6502::exec($run_for);
        }
};

=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?"; 
        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 = '';
                }
        }

}

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