/[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

Diff of /Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

M6502/Orao.pm revision 33 by dpavlin, Mon Jul 30 21:00:36 2007 UTC Orao.pm revision 209 by dpavlin, Mon Apr 14 19:55:29 2008 UTC
# Line 3  package Orao; Line 3  package Orao;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use Carp;  use Carp qw/confess/;
 use lib './lib';  
 #use Time::HiRes qw(time);  
7  use File::Slurp;  use File::Slurp;
8  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
9    use M6502 '0.0.3';
10    use Screen;
11    
12  use base qw(Class::Accessor M6502 Screen);  use base qw(Class::Accessor VRac M6502 Screen Prefs Tape Session);
13  __PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));  #__PACKAGE__->mk_accessors(qw());
14    
15  =head1 NAME  =head1 NAME
16    
# Line 18  Orao - Orao emulator Line 18  Orao - Orao emulator
18    
19  =head1 VERSION  =head1 VERSION
20    
21  Version 0.02  Version 0.06
22    
23  =cut  =cut
24    
25  our $VERSION = '0.02';  our $VERSION = '0.06';
26    
27  =head1 SUMMARY  =head1 SUMMARY
28    
29  Emulator or Orao 8-bit 6502 machine popular in Croatia  Emulator for Orao 8-bit 6502 machine popular in Croatia (especially schools)
30    
31  =cut  =cut
32    
33  =head2 init  =head1 FUNCTIONS
34    
35  Start emulator  =head2 run
36    
37  =cut  Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
38    
39  our $orao;  =cut
40    
41  our $PC = 0x1000;  our $emu;
42    
43  sub init {  sub run {
44          my $self = shift;          my $self = shift;
         warn "call upstream init\n";  
         $self->SUPER::init( $self, @_ );  
45    
46          warn "staring Orao $Orao::VERSION emulation\n";          M6502::reset();
47            $self->_init_callbacks;
48    
49            warn "Orao calling upstream init\n";
50            $self->SUPER::init(
51                    read => sub { $self->read( @_ ) },
52                    write => sub { $self->write( @_ ) },
53            );
54    
55            warn "Orao $Orao::VERSION emulation starting\n";
56    
57            warn "emulating ", $#mem, " bytes of memory\n";
58    
59    #       $self->scale( 2 );
60            $self->show_mem( 1 );
61            $self->load_session( 'sess/current' );
62    
63          $self->open_screen;          $self->open_screen;
64          $self->load_rom({          $self->load_rom({
65                  0x1000 => 'dump/SCRINV.BIN',  #               0x1000 => 'dump/SCRINV.BIN',
66                  0xC000 => 'rom/BAS12.ROM',                  # should be 0x6000, but oraoemu has 2 byte prefix
67                  0xE000 => 'rom/CRT12.ROM',  #               0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
68    #               0xC000 => 'rom/Orao/BAS12.ROM',
69    #               0xE000 => 'rom/Orao/CRT12.ROM',
70                    0xC000 => 'rom/Orao/BAS13.ROM',
71                    0xE000 => 'rom/Orao/CRT13.ROM',
72          });          });
73    
74          $orao = $self;  #       $PC = 0xDD11;   # BC
75    #       $PC = 0xC274;   # MC
76    
77  #       $self->prompt( 0x1000 );          $PC = 0xff89;
78    
79          warn "rendering memory map\n";          $emu = $self;
80    
81          my @mmap = (  #       $self->prompt( 0x1000 );
82                  0x0000, 0x03FF, 'nulti blok',  
83                  0x0400, 0x5FFF, 'korisnički RAM (23K)',          my ( $trace, $debug ) = ( $self->trace, $self->debug );
84                  0x6000, 0x7FFF, 'video RAM',          $self->trace( 0 );
85                  0x8000, 0x9FFF, 'sistemske lokacije',          $self->debug( 0 );
86                  0xA000, 0xAFFF, 'ekstenzija',  
87                  0xB000, 0xBFFF, 'DOS',          warn "rendering memory\n";
88                  0xC000, 0xDFFF, 'BASIC ROM',          $self->render_mem( M6502::mem_peek_region(0x0000,0xffff) );
89                  0xE000, 0xFFFF, 'sistemski ROM',  
90          );          if ( $self->show_mem ) {
91    
92                    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                    print "Orao memory map:";
104    
105                    while ( @mmap ) {
106                            my ( $from, $to, $desc ) = splice(@mmap, 0, 3);
107                            printf("%04x-%04x %s\n", $from, $to, $desc);
108                    }
109    
         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;  
110          }          }
111    
112  }          $self->trace( $trace );
113            $self->debug( $debug );
114    
115            warn "Orao boot finished",
116                    $self->trace ? ' trace' : '',
117                    $self->debug ? ' debug' : '',
118                    "\n";
119    
120    #       $self->load_tape( 'tapes/Orao/bdash.tap' );
121    #       $self->load_tape( 'tapes/Orao/crtanje.tap' );
122            $self->load_tape( 'tapes/Orao/jjack.tap' );
123    
124            $self->render_vram;
125    
126            $self->loop( sub {
127                    my $run_for = shift;
128                    warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
129                    M6502::exec( $run_for );
130                    $self->render_vram;
131            });
132    };
133    
 =head2 load_rom  
134    
135  called to init memory and load initial rom images  =head1 Helper functions
136    
137    $orao->load_rom;  =head2 write_chunk
138    
139    Write chunk directly into memory, updateing vram if needed
140    
141      $emu->write_chunk( 0x1000, $chunk_data );
142    
143  =cut  =cut
144    
145  sub load_rom {  sub write_chunk {
146      my ($self, $loaded_files) = @_;          my $self = shift;
147            my ( $addr, $chunk ) = @_;
148            $self->SUPER::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      #my $time_base = time();          $f = $addr if ( $addr > $f );
158            $t = $end if ( $end < $t );
159    
160          foreach my $addr ( sort keys %$loaded_files ) {          warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
161                  my $path = $loaded_files->{$addr};          $self->render_vram;
162                  $self->load_oraoemu( $path, $addr );          $self->render_mem( @mem );
         }  
163  }  }
164    
165    =head2 load_image
166    
167  =head2 load_oraoemu  Load binary files, ROM images and Orao Emulator files
168    
169      $emu->load_image( '/path/to/file', 0x1000 );
170    
171    Returns true on success.
172    
173  =cut  =cut
174    
175  sub load_oraoemu {  sub load_image {
176          my $self = shift;          my $self = shift;
177          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
178    
179            if ( ! -e $path ) {
180                    warn "ERROR: file $path doesn't exist\n";
181                    return;
182            }
183    
184          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
185    
186          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 119  sub load_oraoemu { Line 189  sub load_oraoemu {
189                  $addr = 0;                  $addr = 0;
190                  warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;                  warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
191                  $self->write_chunk( $addr, substr($buff,2) );                  $self->write_chunk( $addr, substr($buff,2) );
192                  return;                  return 1;
193          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
194                  $addr = 0;                  $addr = 0;
195                  warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;                  warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
196                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->write_chunk( $addr, substr($buff,0x20) );
197                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
198          }          }
199    
200          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
201          return $self->write_chunk( $addr, $buff );          $self->write_chunk( $addr, $buff );
202            return 1;
203    };
204    
         my $chunk;  
205    
206          my $pos = 0;  =head1 Memory management
207    
208          while ( my $long = substr($buff,$pos,4) ) {  Orao implements all I/O using mmap addresses. This was main reason why
209                  my @b = split(//, $long, 4);  L<Acme::6502> was just too slow to handle it.
                 $chunk .=  
                         ( $b[3] || '' ) .  
                         ( $b[2] || '' ) .  
                         ( $b[1] || '' ) .  
                         ( $b[0] || '' );  
                 $pos += 4;  
         }  
210    
211          $self->write_chunk( $addr, $chunk );  =cut
212    
213  };  =head2 read
214    
215  =head2 save_dump  Read from memory
216    
217    $orao->save_dump( 'filename', $from, $to );    $byte = read( $address );
218    
219  =cut  =cut
220    
221  sub save_dump {  my $keyboard_none = 255;
222    
223    my $keyboard = {
224            0x87FC => {
225                    'right'         => 16,
226                    'down'          => 128,
227                    'up'            => 192,
228                    'left'          => 224,
229                    'backspace' => 224,
230            },
231            0x87FD => sub {
232                    my $self = shift;
233                    if ( $self->key_active('return') ) {
234    #                       M6502::_write( 0xfc, 13 );
235                            warn "return\n";
236                            return 0;
237                    } elsif ( $self->key_active('left ctrl','right ctrl') ) {
238                            warn "ctrl\n";
239                            return 16;
240                    }
241                    return $keyboard_none;
242            },
243            0x87FA => {
244                    'f4' => 16,
245                    'f3' => 128,
246                    'f2' => 192,
247                    'f1' => 224,
248            },
249            0x87FB => sub {
250                    my $self = shift;
251                    if ( $self->key_active('space') ) {
252                            warn "space\n";
253                            return 32;
254                    } elsif ( $self->key_active('left shift','right shift') ) {
255                            warn "shift\n";
256                            return 16;
257    #               } elsif ( $self->tape ) {
258    #                       warn "has tape!";
259    #                       return 0;
260                    }
261                    return $keyboard_none;
262            },
263            0x87F6 => {
264                    '6' => 16,
265                    't' => 128,
266                    'y' => 192,     # hr: z
267                    'r' => 224,
268            },
269            0x87F7 => {
270                    '5' => 32,
271                    '4' => 16,
272            },
273            0x87EE => {
274                    '7' => 16,
275                    'u' => 128,
276                    'i' => 192,
277                    'o' => 224,
278            },
279            0x87EF => {
280                    '8' => 32,
281                    '9' => 16,
282            },
283            0x87DE => {
284                    '1' => 16,
285                    'w' => 128,
286                    'q' => 192,
287                    'e' => 224,
288            },
289            0x87DF => {
290                    '2' => 32,
291                    '3' => 16,
292            },
293            0x87BE => {
294                    'm' => 16,
295                    'k' => 128,
296                    'j' => 192,
297                    'l' => 224,
298            },
299            0x87BF => {
300                    ',' => 32,      # <
301                    '.' => 16,      # >
302            },
303            0x877E => {
304                    'z' => 16,      # hr:y
305                    's' => 128,
306                    'a' => 192,
307                    'd' => 224,
308            },
309            0x877F => {
310                    'x' => 32,
311                    'c' => 16,
312            },
313            0x86FE => {
314                    'n' => 16,
315                    'g' => 128,
316                    'h' => 192,
317                    'f' => 224,
318            },
319            0x86FF => {
320                    'b' => 32,
321                    'v' => 16,
322            },
323            0x85FE => {
324                    '<' => 16,              # :
325                    '\\' => 128,    # ¾
326                    '\'' => 192,    # ę
327                    ';' => 224,             # č
328            },
329            0x85FF => {
330                    '/' => 32,
331                    'f11' => 16,    # ^
332            },
333            0x83FE => {
334                    'f12' => 16,    # ;
335                    '[' => 128,             # ¹
336                    ']' => 192,             # š
337                    'p' => 224,
338            },
339            0x83FF => {
340                    '-' => 32,
341                    '0' => 16,
342            },
343    };
344    
345    sub read {
346          my $self = shift;          my $self = shift;
347            my ($addr) = @_;
348            die "address over 64k: $addr" if ( $addr > 0xffff );
349            my $byte = $mem[$addr];
350            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
351            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
352    
353          my ( $path, $from, $to ) = @_;          # keyboard
354    
355          $from ||= 0;          if ( defined( $keyboard->{$addr} ) ) {
356          $to ||= 0xffff;                  warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
357            
358                    my $ret = $keyboard_none;
359                    my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
360                    if ( ref($r) eq 'CODE' ) {
361                            $ret = $r->($self);
362                    } else {
363                            foreach my $k ( keys %$r ) {
364                                    my $return = 0;
365                                    if ( $self->key_active($k) ) {
366                                            warn "key '$k' is active\n";
367                                            $return ||= $r->{$k};
368                                    }
369                                    $ret = $return if $return;
370                            }
371                    }
372                    warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
373                    return $ret;
374            }
375    
376          open(my $fh, '>', $path) || die "can't open $path: $!";          if ( $addr == 0x87ff ) {
377          print $fh $self->read_chunk( $from, $to );                  return $self->read_tape;
378          close($fh);          }
379    
380          my $size = -s $path;          $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
381          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;          return $byte;
382  }  }
383    
384  =head2 hexdump  =head2 write
385    
386    Write into emory
387    
388    $orao->hexdump( $address );    write( $address, $byte );
389    
390  =cut  =cut
391    
392  sub hexdump {  sub write {
393          my $self = shift;          my $self = shift;
394          my $a = shift;          my ($addr,$byte) = @_;
395          return sprintf(" %04x %s\n", $a,          warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
                 join(" ",  
                         map {  
                                 sprintf( "%02x", $_ )  
                         } $self->ram( $a, $a+8 )  
                 )  
         );  
 }  
396    
397  =head2 prompt          if ( $addr == 0x8800 ) {
398                    $self->write_tape( $byte );
399                    warn sprintf "sound ignored: %x\n", $byte;
400            }
401    
402    $orao->prompt( $address, $last_command );          if ( $addr > 0xafff ) {
403                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
404            }
405    
406  =cut          $self->render_vram if ( $addr >= 0x6000 && $addr <= 0x7fff );
407    
408  sub prompt {          $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
409          my $self = shift;  #       $mem[$addr] = $byte;
410          my $a = shift;          return;
         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;  
411  }  }
412    
413  =head1 Memory management  =head1 Architecture specific
414    
415  Orao implements all I/O using mmap addresses. This was main reason why  =head2 render_vram
416  L<Acme::6502> was just too slow to handle it.  
417    Render one frame of video ram
418    
419      $self->render_vram;
420    
421  =cut  =cut
422    
423  my @mem = (0xff) x 0x100000; # 64Mb  sub render_vram {
424            my $self = shift;
425    
426  =head2 read  #       my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
427    #       my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
428            my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
429    
430            my $vram = SDL::Surface->new(
431                    -width => 256,
432                    -height => 256,
433                    -depth => 1,    # 1 bit per pixel
434                    -pitch => 32,   # bytes per line
435                    -from => $pixels,
436            );
437            $vram->set_colors( 0, $black, $white );
438    
439  Read from memory          $self->render_frame( $vram );
440    }
441    
442    $byte = read( $address );  =head2 cpu_PC
443    
444    Helper metod to set or get PC for current architecture
445    
446  =cut  =cut
447    
448  sub read {  sub cpu_PC {
449          my $self = shift;          my ( $self, $addr ) = @_;
450          my ($addr) = @_;          if ( defined($addr) ) {
451          my $byte = $mem[$addr];                  $PC = $addr;
452          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;                  warn sprintf("running from PC %04x\n", $PC);
453          $self->mmap_pixel( $addr, 0, $byte, 0 );          };
454          return $byte;          return $PC;
455  }  }
456    
 =head2 write  
457    
458  Write into emory  =head2 _init_callbacks
459    
460    write( $address, $byte );  Mark memory areas for which we want to get callbacks to perl
461    
462  =cut  =cut
463    
464  sub write {  sub _init_callbacks {
465          my $self = shift;          my $self = shift;
466          warn "# Orao::write(",dump(@_),")\n" if $self->debug;          warn "set calbacks to perl for memory areas...\n";
         my ($addr,$byte) = @_;  
467    
468          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          # don't call for anything
469                  $self->vram( $addr - 0x6000 , $byte );          M6502::set_all_callbacks( 0x00 );
         }  
470    
471          if ( $addr > 0xafff ) {          # video ram
472                  warn sprintf "access to %04x above affff aborting\n", $addr;  #       M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
473                  return -1;          # keyboard
474            M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
475            # tape
476            M6502::set_read_callback( 0x87ff );
477            M6502::set_write_callback( 0x8800 );
478    
479            my $map = '';
480            foreach ( 0 .. 0xffff ) {
481                    my $cb = M6502::get_callback( $_ );
482                    $map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
483          }          }
484          if ( $addr == 0x8800 ) {          warn "callback map:\n$map\n";
                 warn sprintf "sound ignored: %x\n", $byte;  
         }  
   
         $self->mmap_pixel( $addr, $byte, 0, 0 );  
   
         $mem[$addr] = $byte;  
485  }  }
486    
487    =head1 SEE ALSO
488    
489    L<VRac>, L<M6502>, L<Screen>, L<Tape>
490    
491  =head1 AUTHOR  =head1 AUTHOR
492    
493  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
494    
 =head1 BUGS  
   
495  =head1 ACKNOWLEDGEMENTS  =head1 ACKNOWLEDGEMENTS
496    
497  See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all  See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
Legend:
Removed from v.33  
changed lines
  Added in v.209
  ViewVC Help
Powered by ViewVC 1.1.26