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

  ViewVC Help
Powered by ViewVC 1.1.26