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