VRac/M6502/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 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;

our $PC = 0x1000;

sub init {
        my $self = shift;
        warn "call 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',
        });

        $orao = $self;

#       $self->prompt( 0x1000 );

        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 ) {
#                       $orao->read( $a );
#               }
#               $self->sync;
        }

}

=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) );
                $self->poke_code( $addr, map { ord($_) } split(//,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

my @mem = (0xff) x 0x100000; # 64Mb

=head2 read

Read from memory

  $byte = read( $address );

=cut

sub read {
        my $self = shift;
        my ($addr) = @_;
        my $byte = $mem[$addr];
        warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;
        $self->mmap_pixel( $addr, 0, $byte, 0 );
        return $byte;
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
        my $self = shift;
        warn "# Orao::write(",dump(@_),")\n" if $self->debug;
        my ($addr,$byte) = @_;

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


=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	29
12	dpavlin	30	use base qw(Class::Accessor M6502 Screen);
13	dpavlin	29	__PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));
14
15			=head1 NAME
16
17			Orao - Orao emulator
18
19			=head1 VERSION
20
21			Version 0.02
22
23			=cut
24
25			our $VERSION = '0.02';
26
27			=head1 SUMMARY
28
29			Emulator or Orao 8-bit 6502 machine popular in Croatia
30
31			=cut
32
33	dpavlin	30	=head2 init
34
35			Start emulator
36
37			=cut
38
39	dpavlin	32	our $orao;
40
41	dpavlin	33	our $PC = 0x1000;
42
43	dpavlin	30	sub init {
44			my $self = shift;
45			warn "call upstream init\n";
46	dpavlin	33	$self->SUPER::init( $self, @_ );
47	dpavlin	30
48	dpavlin	31	warn "staring Orao $Orao::VERSION emulation\n";
49	dpavlin	30
50			$self->open_screen;
51	dpavlin	33	$self->load_rom({
52			0x1000 => 'dump/SCRINV.BIN',
53			0xC000 => 'rom/BAS12.ROM',
54			0xE000 => 'rom/CRT12.ROM',
55			});
56	dpavlin	32
57			$orao = $self;
58
59	dpavlin	33	# $self->prompt( 0x1000 );
60
61			warn "rendering memory map\n";
62
63			my @mmap = (
64			0x0000, 0x03FF, 'nulti blok',
65			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
66			0x6000, 0x7FFF, 'video RAM',
67			0x8000, 0x9FFF, 'sistemske lokacije',
68			0xA000, 0xAFFF, 'ekstenzija',
69			0xB000, 0xBFFF, 'DOS',
70			0xC000, 0xDFFF, 'BASIC ROM',
71			0xE000, 0xFFFF, 'sistemski ROM',
72			);
73
74			foreach my $i ( 0 .. $#mmap / 3 ) {
75			my $o = $i * 3;
76			my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
77			printf "%04x - %04x - %s\n", $from, $to, $desc;
78			# for my $a ( $from .. $to ) {
79			# $orao->read( $a );
80			# }
81			# $self->sync;
82			}
83
84	dpavlin	30	}
85
86	dpavlin	29	=head2 load_rom
87
88			called to init memory and load initial rom images
89
90			$orao->load_rom;
91
92			=cut
93
94			sub load_rom {
95	dpavlin	33	my ($self, $loaded_files) = @_;
96	dpavlin	29
97			#my $time_base = time();
98
99			foreach my $addr ( sort keys %$loaded_files ) {
100			my $path = $loaded_files->{$addr};
101			$self->load_oraoemu( $path, $addr );
102			}
103			}
104
105
106			=head2 load_oraoemu
107
108			=cut
109
110			sub load_oraoemu {
111			my $self = shift;
112			my ( $path, $addr ) = @_;
113
114	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
115	dpavlin	29
116			my $buff = read_file( $path );
117
118			if ( $size == 65538 ) {
119			$addr = 0;
120	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
121	dpavlin	29	$self->write_chunk( $addr, substr($buff,2) );
122			return;
123			} elsif ( $size == 32800 ) {
124			$addr = 0;
125	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
126	dpavlin	29	#$self->write_chunk( $addr, substr($buff,0x20) );
127			$self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );
128			return;
129			}
130	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
131	dpavlin	29	return $self->write_chunk( $addr, $buff );
132
133			my $chunk;
134
135			my $pos = 0;
136
137			while ( my $long = substr($buff,$pos,4) ) {
138			my @b = split(//, $long, 4);
139			$chunk .=
140			( $b[3] \|\| '' ) .
141			( $b[2] \|\| '' ) .
142			( $b[1] \|\| '' ) .
143			( $b[0] \|\| '' );
144			$pos += 4;
145			}
146
147			$self->write_chunk( $addr, $chunk );
148
149			};
150
151			=head2 save_dump
152
153			$orao->save_dump( 'filename', $from, $to );
154
155			=cut
156
157			sub save_dump {
158			my $self = shift;
159
160			my ( $path, $from, $to ) = @_;
161
162			$from \|\|= 0;
163			$to \|\|= 0xffff;
164
165			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
166			print $fh $self->read_chunk( $from, $to );
167			close($fh);
168
169			my $size = -s $path;
170	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
171	dpavlin	29	}
172
173			=head2 hexdump
174
175			$orao->hexdump( $address );
176
177			=cut
178
179			sub hexdump {
180			my $self = shift;
181			my $a = shift;
182			return sprintf(" %04x %s\n", $a,
183			join(" ",
184			map {
185			sprintf( "%02x", $_ )
186			} $self->ram( $a, $a+8 )
187			)
188			);
189			}
190
191			=head2 prompt
192
193			$orao->prompt( $address, $last_command );
194
195			=cut
196
197			sub prompt {
198			my $self = shift;
199			my $a = shift;
200			my $last = shift;
201	dpavlin	32	print STDERR $self->hexdump( $a ),
202	dpavlin	29	$last ? "[$last] " : '',
203			"> ";
204			my $in = <STDIN>;
205			chomp($in);
206			$in \|\|= $last;
207			$last = $in;
208			return split(/\s+/, $in) if $in;
209			}
210
211	dpavlin	32	=head1 Memory management
212	dpavlin	30
213	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
214			L<Acme::6502> was just too slow to handle it.
215
216			=cut
217
218			my @mem = (0xff) x 0x100000; # 64Mb
219
220			=head2 read
221
222			Read from memory
223
224			$byte = read( $address );
225
226			=cut
227
228			sub read {
229	dpavlin	33	my $self = shift;
230	dpavlin	32	my ($addr) = @_;
231			my $byte = $mem[$addr];
232			warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;
233	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
234	dpavlin	32	return $byte;
235			}
236
237			=head2 write
238
239			Write into emory
240
241			write( $address, $byte );
242
243			=cut
244
245			sub write {
246	dpavlin	33	my $self = shift;
247	dpavlin	32	warn "# Orao::write(",dump(@_),")\n" if $self->debug;
248			my ($addr,$byte) = @_;
249
250			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
251			$self->vram( $addr - 0x6000 , $byte );
252			}
253
254			if ( $addr > 0xafff ) {
255			warn sprintf "access to %04x above affff aborting\n", $addr;
256			return -1;
257			}
258			if ( $addr == 0x8800 ) {
259			warn sprintf "sound ignored: %x\n", $byte;
260			}
261
262	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
263	dpavlin	32
264			$mem[$addr] = $byte;
265			}
266
267
268	dpavlin	29	=head1 AUTHOR
269
270			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
271
272			=head1 BUGS
273
274			=head1 ACKNOWLEDGEMENTS
275
276			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
277			info about this machine (and even hardware implementation from 2007).
278
279			=head1 COPYRIGHT & LICENSE
280
281			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
282
283			This program is free software; you can redistribute it and/or modify it
284			under the same terms as Perl itself.
285
286			=cut
287
288			1; # End of Orao