/[VRac]/Orao.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 52 - (hide annotations)
Tue Jul 31 12:57:35 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 8486 byte(s)
tweaks
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 52 warn "Orao $Orao::VERSION emulation starting\n", dump( $self );
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 49 my ( $trace, $debug ) = ( $self->trace, $self->debug );
66 dpavlin 38 $self->trace( 0 );
67 dpavlin 49 $self->debug( 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 49 $self->debug( $debug );
109 dpavlin 33
110 dpavlin 39 #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
111 dpavlin 34
112 dpavlin 49 warn "Orao init finished",
113     $self->trace ? ' trace' : '',
114     $self->debug ? ' debug' : '',
115     "\n";
116 dpavlin 38
117 dpavlin 30 }
118    
119 dpavlin 29 =head2 load_rom
120    
121     called to init memory and load initial rom images
122    
123     $orao->load_rom;
124    
125     =cut
126    
127     sub load_rom {
128 dpavlin 33 my ($self, $loaded_files) = @_;
129 dpavlin 29
130     #my $time_base = time();
131    
132     foreach my $addr ( sort keys %$loaded_files ) {
133     my $path = $loaded_files->{$addr};
134     $self->load_oraoemu( $path, $addr );
135     }
136     }
137    
138    
139     =head2 load_oraoemu
140    
141     =cut
142    
143 dpavlin 46 sub _write_chunk {
144     my $self = shift;
145     my ( $addr, $chunk ) = @_;
146     $self->write_chunk( $addr, $chunk );
147     my $end = $addr + length($chunk);
148     my ( $f, $t ) = ( 0x6000, 0x7fff );
149    
150     if ( $end < $f || $addr >= $t ) {
151     warn "skip vram update\n";
152     return;
153     };
154    
155     $f = $addr if ( $addr > $f );
156     $t = $end if ( $end < $t );
157    
158     warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
159     foreach my $a ( $f .. $t ) {
160     $self->vram( $a - 0x6000 , $mem[ $a ] );
161     }
162     }
163    
164 dpavlin 29 sub load_oraoemu {
165     my $self = shift;
166     my ( $path, $addr ) = @_;
167    
168 dpavlin 31 my $size = -s $path || confess "no size for $path: $!";
169 dpavlin 29
170     my $buff = read_file( $path );
171    
172     if ( $size == 65538 ) {
173     $addr = 0;
174 dpavlin 33 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
175 dpavlin 46 $self->_write_chunk( $addr, substr($buff,2) );
176 dpavlin 29 return;
177     } elsif ( $size == 32800 ) {
178     $addr = 0;
179 dpavlin 33 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
180 dpavlin 46 $self->_write_chunk( $addr, substr($buff,0x20) );
181 dpavlin 29 return;
182     }
183 dpavlin 33 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
184 dpavlin 46 return $self->_write_chunk( $addr, $buff );
185 dpavlin 29
186     my $chunk;
187    
188     my $pos = 0;
189    
190     while ( my $long = substr($buff,$pos,4) ) {
191     my @b = split(//, $long, 4);
192     $chunk .=
193     ( $b[3] || '' ) .
194     ( $b[2] || '' ) .
195     ( $b[1] || '' ) .
196     ( $b[0] || '' );
197     $pos += 4;
198     }
199    
200 dpavlin 46 $self->_write_chunk( $addr, $chunk );
201 dpavlin 29
202     };
203    
204     =head2 save_dump
205    
206     $orao->save_dump( 'filename', $from, $to );
207    
208     =cut
209    
210     sub save_dump {
211     my $self = shift;
212    
213     my ( $path, $from, $to ) = @_;
214    
215     $from ||= 0;
216     $to ||= 0xffff;
217    
218     open(my $fh, '>', $path) || die "can't open $path: $!";
219     print $fh $self->read_chunk( $from, $to );
220     close($fh);
221    
222     my $size = -s $path;
223 dpavlin 32 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
224 dpavlin 29 }
225    
226     =head2 hexdump
227    
228     $orao->hexdump( $address );
229    
230     =cut
231    
232     sub hexdump {
233     my $self = shift;
234     my $a = shift;
235     return sprintf(" %04x %s\n", $a,
236     join(" ",
237     map {
238     sprintf( "%02x", $_ )
239 dpavlin 47 } @mem[ $a .. $a+8 ]
240 dpavlin 29 )
241     );
242     }
243    
244 dpavlin 32 =head1 Memory management
245 dpavlin 30
246 dpavlin 32 Orao implements all I/O using mmap addresses. This was main reason why
247     L<Acme::6502> was just too slow to handle it.
248    
249     =cut
250    
251     =head2 read
252    
253     Read from memory
254    
255     $byte = read( $address );
256    
257     =cut
258    
259     sub read {
260 dpavlin 33 my $self = shift;
261 dpavlin 32 my ($addr) = @_;
262     my $byte = $mem[$addr];
263 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
264 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
265 dpavlin 32 return $byte;
266     }
267    
268     =head2 write
269    
270     Write into emory
271    
272     write( $address, $byte );
273    
274     =cut
275    
276     sub write {
277 dpavlin 33 my $self = shift;
278 dpavlin 32 my ($addr,$byte) = @_;
279 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
280 dpavlin 32
281     if ( $addr >= 0x6000 && $addr < 0x8000 ) {
282     $self->vram( $addr - 0x6000 , $byte );
283     }
284    
285     if ( $addr == 0x8800 ) {
286     warn sprintf "sound ignored: %x\n", $byte;
287     }
288    
289 dpavlin 52 if ( $addr > 0xafff ) {
290     confess sprintf "write access %04x > afff aborting\n", $self, $addr;
291     }
292    
293 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
294 dpavlin 32
295     $mem[$addr] = $byte;
296 dpavlin 36 return;
297 dpavlin 32 }
298    
299 dpavlin 42 =head1 Command Line
300 dpavlin 32
301 dpavlin 42 Command-line debugging intrerface is implemented for communication with
302     emulated device
303    
304 dpavlin 50 =head2 prompt
305    
306     $orao->prompt( $address, $last_command );
307    
308     =cut
309    
310     my $last = 'r 1';
311    
312     sub prompt {
313     my $self = shift;
314     $self->app->sync;
315     my $a = shift;
316     print STDERR $self->hexdump( $a ),
317     $last ? "[$last] " : '',
318     "> ";
319     my $in = <STDIN>;
320     chomp($in);
321     warn "## prompt got: $in\n" if $self->debug;
322     $in ||= $last;
323     $last = $in;
324     return split(/\s+/, $in) if $in;
325     }
326    
327 dpavlin 42 =head2 cli
328    
329     $orao->cli();
330    
331     =cut
332    
333     sub cli {
334     my $self = shift;
335     my $a = $PC || confess "no pc?";
336 dpavlin 43 while ( my @v = $self->prompt( $a, $last ) ) {
337 dpavlin 42 my $c = shift @v;
338     my $v = shift @v;
339     $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
340     @v = map { hex($_) } @v;
341 dpavlin 49 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
342 dpavlin 42 if ( $c =~ m/^[qx]/i ) {
343     exit;
344     } elsif ( $c eq '?' ) {
345 dpavlin 50 my $t = $self->trace ? 'on' : 'off' ;
346     my $d = $self->debug ? 'on' : 'off' ;
347 dpavlin 42 warn <<__USAGE__;
348 dpavlin 50 Usage:
349    
350 dpavlin 42 x|q\t\texit
351     e 6000 6010\tdump memory, +/- to walk forward/backward
352     m 1000 ff 00\tput ff 00 on 1000
353     j|u 1000\t\tjump (change pc)
354     r 42\t\trun 42 instruction opcodes
355 dpavlin 50 t\t\ttrace [$t]
356     d\t\tdebug [$d]
357    
358 dpavlin 42 __USAGE__
359 dpavlin 50 warn sprintf(" PC: %04x A:%02x P:%02x X:%02x Y:%02x S:%02x\n", $PC, $A, $P, $X, $Y, $S);
360 dpavlin 42 } elsif ( $c =~ m/^e/i ) {
361 dpavlin 49 $a = $v if defined($v);
362 dpavlin 42 my $to = shift @v;
363     $to = $a + 32 if ( ! $to || $to <= $a );
364     my $lines = int( ($to - $a - 8) / 8 );
365     printf "## m %04x %04x lines: %d\n", $a, $to, $lines;
366     while ( $lines ) {
367     print $self->hexdump( $a );
368     $a += 8;
369     $lines--;
370     }
371     $last = '+';
372     } elsif ( $c =~ m/^\+/ ) {
373     $a += 8;
374     } elsif ( $c =~ m/^\-/ ) {
375     $a -= 8;
376     } elsif ( $c =~ m/^m/i ) {
377     $a = $v;
378     $self->poke_code( $a, @v );
379     printf "poke %d bytes at %04x\n", $#v + 1, $a;
380 dpavlin 50 $last = '+';
381 dpavlin 42 } elsif ( $c =~ m/^l/i ) {
382     my $to = shift @v || 0x1000;
383     $a = $to;
384     $self->load_oraoemu( $v, $a );
385 dpavlin 50 $last = '';
386 dpavlin 42 } elsif ( $c =~ m/^s/i ) {
387     $self->save_dump( $v || 'mem.dump', @v );
388 dpavlin 50 $last = '';
389 dpavlin 42 } elsif ( $c =~ m/^r/i ) {
390     $run_for = $v || 1;
391     print "run_for $run_for instructions\n";
392     last;
393     } elsif ( $c =~ m/^(u|j)/ ) {
394     my $to = $v || $a;
395     printf "set pc to %04x\n", $to;
396     $PC = $to; # remember for restart
397     $run_for = 1;
398 dpavlin 50 $last = sprintf('m %04x', $to);
399 dpavlin 42 last;
400     } elsif ( $c =~ m/^t/ ) {
401     $self->trace( not $self->trace );
402     print "trace ", $self->trace ? 'on' : 'off', "\n";
403 dpavlin 49 } elsif ( $c =~ m/^d/ ) {
404     $self->debug( not $self->debug );
405     print "debug ", $self->debug ? 'on' : 'off', "\n";
406 dpavlin 42 } else {
407     warn "# ignore $c\n";
408     last;
409     }
410     }
411    
412    
413     }
414    
415 dpavlin 29 =head1 AUTHOR
416    
417     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
418    
419     =head1 BUGS
420    
421     =head1 ACKNOWLEDGEMENTS
422    
423     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
424     info about this machine (and even hardware implementation from 2007).
425    
426     =head1 COPYRIGHT & LICENSE
427    
428     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
429    
430     This program is free software; you can redistribute it and/or modify it
431     under the same terms as Perl itself.
432    
433     =cut
434    
435     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26