/[VRac]/M6502/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 /M6502/Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26