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

        $self->load_oraoemu( 'dump/orao-1.2' );
        $self->load_oraoemu( 'dump/SCRINV.BIN', 0x1000 );
        $PC = 0x1000;

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