/[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 165 by dpavlin, Mon Aug 6 07:04:40 2007 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;
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";          warn "Orao calling upstream init\n";
47            $self->SUPER::init(
48                    read => sub { $self->read( @_ ) },
49                    write => sub { $self->write( @_ ) },
50            );
51    
52            warn "Orao $Orao::VERSION emulation starting\n";
53    
54            warn "emulating ", $#mem, " bytes of memory\n";
55    
56    #       $self->scale( 2 );
57    #       $self->show_mem( 1 );
58            $self->load_session( 'session.pl' );
59    
60          $self->open_screen;          $self->open_screen;
61          $self->load_rom({          $self->load_rom({
62                  0x1000 => 'dump/SCRINV.BIN',  #               0x1000 => 'dump/SCRINV.BIN',
63                  0xC000 => 'rom/BAS12.ROM',                  # should be 0x6000, but oraoemu has 2 byte prefix
64                  0xE000 => 'rom/CRT12.ROM',  #               0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
65    #               0xC000 => 'rom/Orao/BAS12.ROM',
66    #               0xE000 => 'rom/Orao/CRT12.ROM',
67                    0xC000 => 'rom/Orao/BAS13.ROM',
68                    0xE000 => 'rom/Orao/CRT13.ROM',
69          });          });
70    
71          $orao = $self;  #       $PC = 0xDD11;   # BC
72    #       $PC = 0xC274;   # MC
73    
74  #       $self->prompt( 0x1000 );          $PC = 0xff89;
75    
76          warn "rendering memory map\n";          $emu = $self;
77    
78          my @mmap = (  #       $self->prompt( 0x1000 );
79                  0x0000, 0x03FF, 'nulti blok',  
80                  0x0400, 0x5FFF, 'korisnički RAM (23K)',          my ( $trace, $debug ) = ( $self->trace, $self->debug );
81                  0x6000, 0x7FFF, 'video RAM',          $self->trace( 0 );
82                  0x8000, 0x9FFF, 'sistemske lokacije',          $self->debug( 0 );
83                  0xA000, 0xAFFF, 'ekstenzija',  
84                  0xB000, 0xBFFF, 'DOS',          warn "rendering memory\n";
85                  0xC000, 0xDFFF, 'BASIC ROM',          $self->render_mem( @mem );
86                  0xE000, 0xFFFF, 'sistemski ROM',  
87          );          if ( $self->show_mem ) {
88    
89                    my @mmap = (
90                            0x0000, 0x03FF, 'nulti blok',
91                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
92                            0x6000, 0x7FFF, 'video RAM',
93                            0x8000, 0x9FFF, 'sistemske lokacije',
94                            0xA000, 0xAFFF, 'ekstenzija',
95                            0xB000, 0xBFFF, 'DOS',
96                            0xC000, 0xDFFF, 'BASIC ROM',
97                            0xE000, 0xFFFF, 'sistemski ROM',
98                    );
99    
100                    print "Orao memory map:";
101    
102                    while ( @mmap ) {
103                            my ( $from, $to, $desc ) = splice(@mmap, 0, 3);
104                            printf("%04x-%04x %s\n", $from, $to, $desc);
105                    }
106    
         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;  
107          }          }
108    
109  }          $self->trace( $trace );
110            $self->debug( $debug );
111    
112            warn "Orao boot finished",
113                    $self->trace ? ' trace' : '',
114                    $self->debug ? ' debug' : '',
115                    "\n";
116    
117            M6502::reset();
118    
119    #       $self->load_tape( '../oraoigre/bdash.tap' );
120    
121            $self->loop( sub {
122                    my $run_for = shift;
123                    warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
124                    M6502::exec( $run_for );
125                    $self->render_vram;
126            });
127    };
128    
129    
130  =head2 load_rom  =head1 Helper functions
131    
132  called to init memory and load initial rom images  =head2 write_chunk
133    
134    $orao->load_rom;  Write chunk directly into memory, updateing vram if needed
135    
136      $emu->write_chunk( 0x1000, $chunk_data );
137    
138  =cut  =cut
139    
140  sub load_rom {  sub write_chunk {
141      my ($self, $loaded_files) = @_;          my $self = shift;
142            my ( $addr, $chunk ) = @_;
143            $self->SUPER::write_chunk( $addr, $chunk );
144            my $end = $addr + length($chunk);
145            my ( $f, $t ) = ( 0x6000, 0x7fff );
146    
147            if ( $end < $f || $addr >= $t ) {
148                    warn "skip vram update\n";
149                    return;
150            };
151    
152      #my $time_base = time();          $f = $addr if ( $addr > $f );
153            $t = $end if ( $end < $t );
154    
155          foreach my $addr ( sort keys %$loaded_files ) {          warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
156                  my $path = $loaded_files->{$addr};          $self->render_vram;
157                  $self->load_oraoemu( $path, $addr );          $self->render_mem( @mem );
         }  
158  }  }
159    
160    =head2 load_image
161    
162    Load binary files, ROM images and Orao Emulator files
163    
164  =head2 load_oraoemu    $emu->load_image( '/path/to/file', 0x1000 );
165    
166    Returns true on success.
167    
168  =cut  =cut
169    
170  sub load_oraoemu {  sub load_image {
171          my $self = shift;          my $self = shift;
172          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
173    
174            if ( ! -e $path ) {
175                    warn "ERROR: file $path doesn't exist\n";
176                    return;
177            }
178    
179          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
180    
181          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 119  sub load_oraoemu { Line 184  sub load_oraoemu {
184                  $addr = 0;                  $addr = 0;
185                  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;
186                  $self->write_chunk( $addr, substr($buff,2) );                  $self->write_chunk( $addr, substr($buff,2) );
187                  return;                  return 1;
188          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
189                  $addr = 0;                  $addr = 0;
190                  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;
191                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->write_chunk( $addr, substr($buff,0x20) );
192                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
         }  
         printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;  
         return $self->write_chunk( $addr, $buff );  
   
         my $chunk;  
   
         my $pos = 0;  
   
         while ( my $long = substr($buff,$pos,4) ) {  
                 my @b = split(//, $long, 4);  
                 $chunk .=  
                         ( $b[3] || '' ) .  
                         ( $b[2] || '' ) .  
                         ( $b[1] || '' ) .  
                         ( $b[0] || '' );  
                 $pos += 4;  
193          }          }
194    
195          $self->write_chunk( $addr, $chunk );          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
196            $self->write_chunk( $addr, $buff );
197            return 1;
198  };  };
199    
 =head2 save_dump  
   
   $orao->save_dump( 'filename', $from, $to );  
   
 =cut  
   
 sub save_dump {  
         my $self = shift;  
   
         my ( $path, $from, $to ) = @_;  
   
         $from ||= 0;  
         $to ||= 0xffff;  
   
         open(my $fh, '>', $path) || die "can't open $path: $!";  
         print $fh $self->read_chunk( $from, $to );  
         close($fh);  
   
         my $size = -s $path;  
         warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;  
 }  
   
 =head2 hexdump  
   
   $orao->hexdump( $address );  
   
 =cut  
   
 sub hexdump {  
         my $self = shift;  
         my $a = shift;  
         return sprintf(" %04x %s\n", $a,  
                 join(" ",  
                         map {  
                                 sprintf( "%02x", $_ )  
                         } $self->ram( $a, $a+8 )  
                 )  
         );  
 }  
   
 =head2 prompt  
   
   $orao->prompt( $address, $last_command );  
   
 =cut  
   
 sub prompt {  
         my $self = shift;  
         my $a = shift;  
         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;  
 }  
200    
201  =head1 Memory management  =head1 Memory management
202    
# Line 215  L<Acme::6502> was just too slow to handl Line 205  L<Acme::6502> was just too slow to handl
205    
206  =cut  =cut
207    
 my @mem = (0xff) x 0x100000; # 64Mb  
   
208  =head2 read  =head2 read
209    
210  Read from memory  Read from memory
# Line 225  Read from memory Line 213  Read from memory
213    
214  =cut  =cut
215    
216    my $keyboard_none = 255;
217    
218    my $keyboard = {
219            0x87FC => {
220                    'right'         => 16,
221                    'down'          => 128,
222                    'up'            => 192,
223                    'left'          => 224,
224                    'backspace' => 224,
225            },
226            0x87FD => sub {
227                    my ( $self, $key ) = @_;
228                    if ( $key eq 'return' ) {
229                            M6502::_write( 0xfc, 13 );
230                            warn "return\n";
231                            return 0;
232                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
233                            warn "ctrl\n";
234                            return 16;
235                    }
236                    return $keyboard_none;
237            },
238            0x87FA => {
239                    'f4' => 16,
240                    'f3' => 128,
241                    'f2' => 192,
242                    'f1' => 224,
243            },
244            0x87FB => sub {
245                    my ( $self, $key ) = @_;
246                    if ( $key eq 'space' ) {
247                            return 32;
248                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
249                            warn "shift\n";
250                            return 16;
251    #               } elsif ( $self->tape ) {
252    #                       warn "has tape!";
253    #                       return 0;
254                    }
255                    return $keyboard_none;
256            },
257            0x87F6 => {
258                    '6' => 16,
259                    't' => 128,
260                    'y' => 192,     # hr: z
261                    'r' => 224,
262            },
263            0x87F7 => {
264                    '5' => 32,
265                    '4' => 16,
266            },
267            0x87EE => {
268                    '7' => 16,
269                    'u' => 128,
270                    'i' => 192,
271                    'o' => 224,
272            },
273            0x87EF => {
274                    '8' => 32,
275                    '9' => 16,
276            },
277            0x87DE => {
278                    '1' => 16,
279                    'w' => 128,
280                    'q' => 192,
281                    'e' => 224,
282            },
283            0x87DF => {
284                    '2' => 32,
285                    '3' => 16,
286            },
287            0x87BE => {
288                    'm' => 16,
289                    'k' => 128,
290                    'j' => 192,
291                    'l' => 224,
292            },
293            0x87BF => {
294                    ',' => 32,      # <
295                    '.' => 16,      # >
296            },
297            0x877E => {
298                    'z' => 16,      # hr:y
299                    's' => 128,
300                    'a' => 192,
301                    'd' => 224,
302            },
303            0x877F => {
304                    'x' => 32,
305                    'c' => 16,
306            },
307            0x86FE => {
308                    'n' => 16,
309                    'g' => 128,
310                    'h' => 192,
311                    'f' => 224,
312            },
313            0x86FF => {
314                    'b' => 32,
315                    'v' => 16,
316            },
317            0x85FE => {
318                    '<' => 16,              # :
319                    '\\' => 128,    # ¾
320                    '\'' => 192,    # ę
321                    ';' => 224,             # č
322            },
323            0x85FF => {
324                    '/' => 32,
325                    'f11' => 16,    # ^
326            },
327            0x83FE => {
328                    'f12' => 16,    # ;
329                    '[' => 128,             # ¹
330                    ']' => 192,             # š
331                    'p' => 224,
332            },
333            0x83FF => {
334                    '-' => 32,
335                    '0' => 16,
336            },
337    };
338    
339  sub read {  sub read {
340          my $self = shift;          my $self = shift;
341          my ($addr) = @_;          my ($addr) = @_;
342            return if ( $addr > 0xffff );
343          my $byte = $mem[$addr];          my $byte = $mem[$addr];
344          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
345          $self->mmap_pixel( $addr, 0, $byte, 0 );          warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
346    
347            # keyboard
348    
349            if ( defined( $keyboard->{$addr} ) ) {
350                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
351                    my $key = $self->key_pressed;
352                    if ( defined($key) ) {
353                            my $ret = $keyboard_none;
354                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
355                            if ( ref($r) eq 'CODE' ) {
356                                    $ret = $r->($self, $key);
357                            } elsif ( defined($r->{$key}) ) {
358                                    $ret = $r->{$key};
359                                    if ( ref($ret) eq 'CODE' ) {
360                                            $ret = $ret->($self);
361                                    }
362                            } else {
363                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
364                            }
365                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
366                            return $ret;
367                    }
368                    return $keyboard_none;
369            }
370    
371            if ( $addr == 0x87ff ) {
372                    return $self->read_tape;
373            }
374    
375            $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
376          return $byte;          return $byte;
377  }  }
378    
# Line 244  Write into emory Line 386  Write into emory
386    
387  sub write {  sub write {
388          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
389          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
390            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
391    
         if ( $addr >= 0x6000 && $addr < 0x8000 ) {  
                 $self->vram( $addr - 0x6000 , $byte );  
         }  
   
         if ( $addr > 0xafff ) {  
                 warn sprintf "access to %04x above affff aborting\n", $addr;  
                 return -1;  
         }  
392          if ( $addr == 0x8800 ) {          if ( $addr == 0x8800 ) {
393                    $self->write_tape( $byte );
394                  warn sprintf "sound ignored: %x\n", $byte;                  warn sprintf "sound ignored: %x\n", $byte;
395          }          }
396    
397          $self->mmap_pixel( $addr, $byte, 0, 0 );          if ( $addr > 0xafff ) {
398                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
399            }
400    
401            $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
402          $mem[$addr] = $byte;          $mem[$addr] = $byte;
403            return;
404    }
405    
406    =head1 Architecture specific
407    
408    =head2 render_vram
409    
410    Render one frame of video ram
411    
412      $self->render_vram;
413    
414    =cut
415    
416    sub render_vram {
417            my $self = shift;
418    
419            my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
420    
421            my $vram = SDL::Surface->new(
422                    -width => 256,
423                    -height => 256,
424                    -depth => 1,    # 1 bit per pixel
425                    -pitch => 32,   # bytes per line
426                    -from => $pixels,
427            );
428            $vram->set_colors( 0, $black, $white );
429    
430            $self->render_frame( $vram );
431    }
432    
433    =head2 cpu_PC
434    
435    Helper metod to set or get PC for current architecture
436    
437    =cut
438    
439    sub cpu_PC {
440            my ( $self, $addr ) = @_;
441            if ( defined($addr) ) {
442                    $PC = $addr;
443                    warn sprintf("running from PC %04x\n", $PC);
444            };
445            return $PC;
446  }  }
447    
448    =head1 SEE ALSO
449    
450    L<VRac>, L<M6502>, L<Screen>, L<Tape>
451    
452  =head1 AUTHOR  =head1 AUTHOR
453    
454  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
455    
 =head1 BUGS  
   
456  =head1 ACKNOWLEDGEMENTS  =head1 ACKNOWLEDGEMENTS
457    
458  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.165
  ViewVC Help
Powered by ViewVC 1.1.26