viewvc.cgi/VRac/Orao.pm

package Orao;

use warnings;
use strict;

use Carp;
use lib './lib';
#use Time::HiRes qw(time);
use File::Slurp;
use Data::Dump qw/dump/;
use M6502;

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

=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

=head2 init

Start emulator

=cut

our $orao;

select(STDERR); $| = 1;

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

        warn "staring Orao $Orao::VERSION emulation\n";

        $self->open_screen;
        $self->load_rom({
                0x1000 => 'dump/SCRINV.BIN',
                0xC000 => 'rom/BAS12.ROM',
                0xE000 => 'rom/CRT12.ROM',
        });

        $PC = 0xDD11;   # BC
#       $PC = 0xC274;   # MC

        $orao = $self;

#       $self->prompt( 0x1000 );

        my $trace = $self->trace;
        $self->trace( 0 );

        if ( $self->show_mem ) {

                warn "rendering memory map\n";

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

                foreach my $i ( 0 .. $#mmap / 3 ) {
                        my $o = $i * 3;
                        my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
                        printf "%04x - %04x - %s\n", $from, $to, $desc;
                        for my $a ( $from .. $to ) {
                                if ( $a >= 0x6000 && $a < 0x8000 ) {
                                        my $b = $self->read( $a );
                                        $self->vram( $a - 0x6000, $b );
                                } else {
                                        $self->read( $a );
                                }
                        }
                }

        } else {

                warn "rendering video memory\n";
                for my $a ( 0x6000 .. 0x7fff ) {
                        $self->vram( $a - 0x6000, $mem[$a] );
                }
        
        }
        $self->sync;
        $self->trace( $trace );

        #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );

        warn "Orao init finished", $self->trace ? ' trace on' : '', "\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 );
        }
}


=head2 load_oraoemu

=cut

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 ] );
        }
}

sub load_oraoemu {
        my $self = shift;
        my ( $path, $addr ) = @_;

        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;
        } 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;
        }
        printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
        return $self->_write_chunk( $addr, $buff );

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

};

=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 {
                                sprintf( "%02x", $_ )
                        } $self->ram( $a, $a+8 )
                )
        );
}

=head2 prompt

  $orao->prompt( $address, $last_command );

=cut

sub prompt {
        my $self = shift;
        $self->app->sync;
        my $a = shift;
        my $last = shift;
        print STDERR $self->hexdump( $a ),
                $last ? "[$last] " : '',
                "> ";
        my $in = <STDIN>;
        chomp($in);
        $in ||= $last;
        $last = $in;
        return split(/\s+/, $in) if $in;
}

=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;
        $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 > 0xafff ) {
                warn sprintf "access to %04x above affff aborting\n", $addr;
                return -1;
        }
        if ( $addr == 0x8800 ) {
                warn sprintf "sound ignored: %x\n", $byte;
        }

        $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 cli

  $orao->cli();

=cut

my $last = 'r 1';

sub cli {
        my $self = shift;
        my $a = $PC || confess "no pc?"; 
        while ( my @v = $self->prompt( $a, $last ) ) {
                my $c = shift @v;
                my $v = shift @v;
                $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
                printf "## [%s] %s\n", ($v || 'undef'), join(",",@v) if $self->debug;
                @v = map { hex($_) } @v;
                if ( $c =~ m/^[qx]/i ) {
                        exit;
                } elsif ( $c eq '?' ) {
                        warn <<__USAGE__;
uage:
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
__USAGE__
                } elsif ( $c =~ m/^e/i ) {
                        $a ||= $v;
                        my $to = shift @v;
                        $to = $a + 32 if ( ! $to || $to <= $a );
                        my $lines = int( ($to - $a - 8) / 8 );
                        printf "## m %04x %04x lines: %d\n", $a, $to, $lines;
                        while ( $lines ) {
                                print $self->hexdump( $a );
                                $a += 8;
                                $lines--;
                        }
                        $last = '+';
                } elsif ( $c =~ m/^\+/ ) {
                        $a += 8;
                } elsif ( $c =~ m/^\-/ ) {
                        $a -= 8;
                } elsif ( $c =~ m/^m/i ) {
                        $a = $v;
                        $self->poke_code( $a, @v );
                        printf "poke %d bytes at %04x\n", $#v + 1, $a;
                } elsif ( $c =~ m/^l/i ) {
                        my $to = shift @v || 0x1000;
                        $a = $to;
                        $self->load_oraoemu( $v, $a );
                } elsif ( $c =~ m/^s/i ) {
                        $self->save_dump( $v || 'mem.dump', @v );
                } elsif ( $c =~ m/^r/i ) {
                        $run_for = $v || 1;
                        print "run_for $run_for instructions\n";
                        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;
                } elsif ( $c =~ m/^t/ ) {
                        $self->trace( not $self->trace );
                        print "trace ", $self->trace ? 'on' : 'off', "\n";
                } else {
                        warn "# ignore $c\n";
                        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			use Carp;
7			use lib './lib';
8			#use Time::HiRes qw(time);
9			use File::Slurp;
10	dpavlin	32	use Data::Dump qw/dump/;
11	dpavlin	34	use M6502;
12	dpavlin	29
13	dpavlin	30	use base qw(Class::Accessor M6502 Screen);
14	dpavlin	29	__PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));
15
16			=head1 NAME
17
18			Orao - Orao emulator
19
20			=head1 VERSION
21
22			Version 0.02
23
24			=cut
25
26			our $VERSION = '0.02';
27
28			=head1 SUMMARY
29
30			Emulator or Orao 8-bit 6502 machine popular in Croatia
31
32			=cut
33
34	dpavlin	30	=head2 init
35
36			Start emulator
37
38			=cut
39
40	dpavlin	32	our $orao;
41
42	dpavlin	42	select(STDERR); $\| = 1;
43
44	dpavlin	30	sub init {
45			my $self = shift;
46	dpavlin	34	warn "Orao calling upstream init\n";
47	dpavlin	33	$self->SUPER::init( $self, @_ );
48	dpavlin	30
49	dpavlin	31	warn "staring Orao $Orao::VERSION emulation\n";
50	dpavlin	30
51			$self->open_screen;
52	dpavlin	33	$self->load_rom({
53			0x1000 => 'dump/SCRINV.BIN',
54			0xC000 => 'rom/BAS12.ROM',
55			0xE000 => 'rom/CRT12.ROM',
56			});
57	dpavlin	32
58	dpavlin	46	$PC = 0xDD11; # BC
59			# $PC = 0xC274; # MC
60	dpavlin	35
61	dpavlin	32	$orao = $self;
62
63	dpavlin	33	# $self->prompt( 0x1000 );
64
65	dpavlin	38	my $trace = $self->trace;
66			$self->trace( 0 );
67	dpavlin	33
68	dpavlin	38	if ( $self->show_mem ) {
69	dpavlin	33
70	dpavlin	38	warn "rendering memory map\n";
71
72			my @mmap = (
73			0x0000, 0x03FF, 'nulti blok',
74			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
75			0x6000, 0x7FFF, 'video RAM',
76			0x8000, 0x9FFF, 'sistemske lokacije',
77			0xA000, 0xAFFF, 'ekstenzija',
78			0xB000, 0xBFFF, 'DOS',
79			0xC000, 0xDFFF, 'BASIC ROM',
80			0xE000, 0xFFFF, 'sistemski ROM',
81			);
82
83			foreach my $i ( 0 .. $#mmap / 3 ) {
84			my $o = $i * 3;
85			my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
86			printf "%04x - %04x - %s\n", $from, $to, $desc;
87			for my $a ( $from .. $to ) {
88			if ( $a >= 0x6000 && $a < 0x8000 ) {
89			my $b = $self->read( $a );
90			$self->vram( $a - 0x6000, $b );
91			} else {
92			$self->read( $a );
93			}
94	dpavlin	36	}
95	dpavlin	34	}
96	dpavlin	38
97			} else {
98
99			warn "rendering video memory\n";
100			for my $a ( 0x6000 .. 0x7fff ) {
101			$self->vram( $a - 0x6000, $mem[$a] );
102			}
103
104	dpavlin	33	}
105	dpavlin	38	$self->sync;
106			$self->trace( $trace );
107	dpavlin	33
108	dpavlin	39	#( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
109	dpavlin	34
110	dpavlin	38	warn "Orao init finished", $self->trace ? ' trace on' : '', "\n";
111
112	dpavlin	30	}
113
114	dpavlin	29	=head2 load_rom
115
116			called to init memory and load initial rom images
117
118			$orao->load_rom;
119
120			=cut
121
122			sub load_rom {
123	dpavlin	33	my ($self, $loaded_files) = @_;
124	dpavlin	29
125			#my $time_base = time();
126
127			foreach my $addr ( sort keys %$loaded_files ) {
128			my $path = $loaded_files->{$addr};
129			$self->load_oraoemu( $path, $addr );
130			}
131			}
132
133
134			=head2 load_oraoemu
135
136			=cut
137
138	dpavlin	46	sub _write_chunk {
139			my $self = shift;
140			my ( $addr, $chunk ) = @_;
141			$self->write_chunk( $addr, $chunk );
142			my $end = $addr + length($chunk);
143			my ( $f, $t ) = ( 0x6000, 0x7fff );
144
145			if ( $end < $f \|\| $addr >= $t ) {
146			warn "skip vram update\n";
147			return;
148			};
149
150			$f = $addr if ( $addr > $f );
151			$t = $end if ( $end < $t );
152
153			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
154			foreach my $a ( $f .. $t ) {
155			$self->vram( $a - 0x6000 , $mem[ $a ] );
156			}
157			}
158
159	dpavlin	29	sub load_oraoemu {
160			my $self = shift;
161			my ( $path, $addr ) = @_;
162
163	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
164	dpavlin	29
165			my $buff = read_file( $path );
166
167			if ( $size == 65538 ) {
168			$addr = 0;
169	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
170	dpavlin	46	$self->_write_chunk( $addr, substr($buff,2) );
171	dpavlin	29	return;
172			} elsif ( $size == 32800 ) {
173			$addr = 0;
174	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
175	dpavlin	46	$self->_write_chunk( $addr, substr($buff,0x20) );
176	dpavlin	29	return;
177			}
178	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
179	dpavlin	46	return $self->_write_chunk( $addr, $buff );
180	dpavlin	29
181			my $chunk;
182
183			my $pos = 0;
184
185			while ( my $long = substr($buff,$pos,4) ) {
186			my @b = split(//, $long, 4);
187			$chunk .=
188			( $b[3] \|\| '' ) .
189			( $b[2] \|\| '' ) .
190			( $b[1] \|\| '' ) .
191			( $b[0] \|\| '' );
192			$pos += 4;
193			}
194
195	dpavlin	46	$self->_write_chunk( $addr, $chunk );
196	dpavlin	29
197			};
198
199			=head2 save_dump
200
201			$orao->save_dump( 'filename', $from, $to );
202
203			=cut
204
205			sub save_dump {
206			my $self = shift;
207
208			my ( $path, $from, $to ) = @_;
209
210			$from \|\|= 0;
211			$to \|\|= 0xffff;
212
213			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
214			print $fh $self->read_chunk( $from, $to );
215			close($fh);
216
217			my $size = -s $path;
218	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
219	dpavlin	29	}
220
221			=head2 hexdump
222
223			$orao->hexdump( $address );
224
225			=cut
226
227			sub hexdump {
228			my $self = shift;
229			my $a = shift;
230			return sprintf(" %04x %s\n", $a,
231			join(" ",
232			map {
233			sprintf( "%02x", $_ )
234			} $self->ram( $a, $a+8 )
235			)
236			);
237			}
238
239			=head2 prompt
240
241			$orao->prompt( $address, $last_command );
242
243			=cut
244
245			sub prompt {
246			my $self = shift;
247	dpavlin	43	$self->app->sync;
248	dpavlin	29	my $a = shift;
249			my $last = shift;
250	dpavlin	32	print STDERR $self->hexdump( $a ),
251	dpavlin	29	$last ? "[$last] " : '',
252			"> ";
253			my $in = <STDIN>;
254			chomp($in);
255			$in \|\|= $last;
256			$last = $in;
257			return split(/\s+/, $in) if $in;
258			}
259
260	dpavlin	32	=head1 Memory management
261	dpavlin	30
262	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
263			L<Acme::6502> was just too slow to handle it.
264
265			=cut
266
267			=head2 read
268
269			Read from memory
270
271			$byte = read( $address );
272
273			=cut
274
275			sub read {
276	dpavlin	33	my $self = shift;
277	dpavlin	32	my ($addr) = @_;
278			my $byte = $mem[$addr];
279	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
280	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
281	dpavlin	32	return $byte;
282			}
283
284			=head2 write
285
286			Write into emory
287
288			write( $address, $byte );
289
290			=cut
291
292			sub write {
293	dpavlin	33	my $self = shift;
294	dpavlin	32	my ($addr,$byte) = @_;
295	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
296	dpavlin	32
297			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
298			$self->vram( $addr - 0x6000 , $byte );
299			}
300
301			if ( $addr > 0xafff ) {
302			warn sprintf "access to %04x above affff aborting\n", $addr;
303			return -1;
304			}
305			if ( $addr == 0x8800 ) {
306			warn sprintf "sound ignored: %x\n", $byte;
307			}
308
309	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
310	dpavlin	32
311			$mem[$addr] = $byte;
312	dpavlin	36	return;
313	dpavlin	32	}
314
315	dpavlin	42	=head1 Command Line
316	dpavlin	32
317	dpavlin	42	Command-line debugging intrerface is implemented for communication with
318			emulated device
319
320			=head2 cli
321
322			$orao->cli();
323
324			=cut
325
326			my $last = 'r 1';
327
328			sub cli {
329			my $self = shift;
330			my $a = $PC \|\| confess "no pc?";
331	dpavlin	43	while ( my @v = $self->prompt( $a, $last ) ) {
332	dpavlin	42	my $c = shift @v;
333			my $v = shift @v;
334			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
335			printf "## [%s] %s\n", ($v \|\| 'undef'), join(",",@v) if $self->debug;
336			@v = map { hex($_) } @v;
337			if ( $c =~ m/^[qx]/i ) {
338			exit;
339			} elsif ( $c eq '?' ) {
340			warn <<__USAGE__;
341			uage:
342			x\|q\t\texit
343			e 6000 6010\tdump memory, +/- to walk forward/backward
344			m 1000 ff 00\tput ff 00 on 1000
345			j\|u 1000\t\tjump (change pc)
346			r 42\t\trun 42 instruction opcodes
347			__USAGE__
348			} elsif ( $c =~ m/^e/i ) {
349			$a \|\|= $v;
350			my $to = shift @v;
351			$to = $a + 32 if ( ! $to \|\| $to <= $a );
352			my $lines = int( ($to - $a - 8) / 8 );
353			printf "## m %04x %04x lines: %d\n", $a, $to, $lines;
354			while ( $lines ) {
355			print $self->hexdump( $a );
356			$a += 8;
357			$lines--;
358			}
359			$last = '+';
360			} elsif ( $c =~ m/^\+/ ) {
361			$a += 8;
362			} elsif ( $c =~ m/^\-/ ) {
363			$a -= 8;
364			} elsif ( $c =~ m/^m/i ) {
365			$a = $v;
366			$self->poke_code( $a, @v );
367			printf "poke %d bytes at %04x\n", $#v + 1, $a;
368			} elsif ( $c =~ m/^l/i ) {
369			my $to = shift @v \|\| 0x1000;
370			$a = $to;
371			$self->load_oraoemu( $v, $a );
372			} elsif ( $c =~ m/^s/i ) {
373			$self->save_dump( $v \|\| 'mem.dump', @v );
374			} elsif ( $c =~ m/^r/i ) {
375			$run_for = $v \|\| 1;
376			print "run_for $run_for instructions\n";
377			last;
378			} elsif ( $c =~ m/^(u\|j)/ ) {
379			my $to = $v \|\| $a;
380			printf "set pc to %04x\n", $to;
381			$PC = $to; # remember for restart
382			$run_for = 1;
383			last;
384			} elsif ( $c =~ m/^t/ ) {
385			$self->trace( not $self->trace );
386			print "trace ", $self->trace ? 'on' : 'off', "\n";
387			} else {
388			warn "# ignore $c\n";
389			last;
390			}
391			}
392
393
394			}
395
396	dpavlin	29	=head1 AUTHOR
397
398			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
399
400			=head1 BUGS
401
402			=head1 ACKNOWLEDGEMENTS
403
404			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
405			info about this machine (and even hardware implementation from 2007).
406
407			=head1 COPYRIGHT & LICENSE
408
409			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
410
411			This program is free software; you can redistribute it and/or modify it
412			under the same terms as Perl itself.
413
414			=cut
415
416			1; # End of Orao