/[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 30 by dpavlin, Mon Jul 30 17:56:13 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/;
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 17  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  sub init {  our $emu;
42    
43    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";          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',
63                    # should be 0x6000, but oraoemu has 2 byte prefix
64    #               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    #       $PC = 0xDD11;   # BC
72    #       $PC = 0xC274;   # MC
73    
74            $PC = 0xff89;
75    
76            $emu = $self;
77    
78    #       $self->prompt( 0x1000 );
79    
80            my ( $trace, $debug ) = ( $self->trace, $self->debug );
81            $self->trace( 0 );
82            $self->debug( 0 );
83    
84            warn "rendering memory\n";
85            $self->render_mem( @mem );
86    
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    
107  my $loaded_files = {          }
108          0xC000 => 'rom/BAS12.ROM',  
109          0xE000 => 'rom/CRT12.ROM',          $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    
 =head2 load_rom  
129    
130  called to init memory and load initial rom images  =head1 Helper functions
131    
132    $orao->load_rom;  =head2 write_chunk
133    
134    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) = @_;          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                  printf "loading '%s' at %04x\n", $path, $addr;          $self->render_mem( @mem );
                 $self->load_oraoemu( $path, $addr );  
         }  
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          my $size = -s $path || die "no size for $path: $!";          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: $!";
180    
181          my $buff = read_file( $path );          my $buff = read_file( $path );
182    
183          if ( $size == 65538 ) {          if ( $size == 65538 ) {
184                  $addr = 0;                  $addr = 0;
185                  printf "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;
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                  printf "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;
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;  
193          }          }
         printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $size;  
         return $self->write_chunk( $addr, $buff );  
194    
195          my $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    
         my $pos = 0;  
200    
201          while ( my $long = substr($buff,$pos,4) ) {  =head1 Memory management
                 my @b = split(//, $long, 4);  
                 $chunk .=  
                         ( $b[3] || '' ) .  
                         ( $b[2] || '' ) .  
                         ( $b[1] || '' ) .  
                         ( $b[0] || '' );  
                 $pos += 4;  
         }  
202    
203          $self->write_chunk( $addr, $chunk );  Orao implements all I/O using mmap addresses. This was main reason why
204    L<Acme::6502> was just too slow to handle it.
205    
206  };  =cut
207    
208    =head2 read
209    
210  =head2 save_dump  Read from memory
211    
212    $orao->save_dump( 'filename', $from, $to );    $byte = read( $address );
213    
214  =cut  =cut
215    
216  sub save_dump {  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 {
340          my $self = shift;          my $self = shift;
341            my ($addr) = @_;
342            return if ( $addr > 0xffff );
343            my $byte = $mem[$addr];
344            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
345            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;
377    }
378    
379    =head2 write
380    
381    Write into emory
382    
383      write( $address, $byte );
384    
385          my ( $path, $from, $to ) = @_;  =cut
386    
387          $from ||= 0;  sub write {
388          $to ||= 0xffff;          my $self = shift;
389            my ($addr,$byte) = @_;
390            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
391    
392          open(my $fh, '>', $path) || die "can't open $path: $!";          if ( $addr == 0x8800 ) {
393          print $fh $self->read_chunk( $from, $to );                  $self->write_tape( $byte );
394          close($fh);                  warn sprintf "sound ignored: %x\n", $byte;
395            }
396    
397          my $size = -s $path;          if ( $addr > 0xafff ) {
398          printf "saved %s %d %x bytes\n", $path, $size, $size;                  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;
403            return;
404  }  }
405    
406  =head2 hexdump  =head1 Architecture specific
407    
408    =head2 render_vram
409    
410    Render one frame of video ram
411    
412    $orao->hexdump( $address );    $self->render_vram;
413    
414  =cut  =cut
415    
416  sub hexdump {  sub render_vram {
417          my $self = shift;          my $self = shift;
418          my $a = shift;  
419          return sprintf(" %04x %s\n", $a,          my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
420                  join(" ",  
421                          map {          my $vram = SDL::Surface->new(
422                                  sprintf( "%02x", $_ )                  -width => 256,
423                          } $self->ram( $a, $a+8 )                  -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 prompt  =head2 cpu_PC
434    
435    $orao->prompt( $address, $last_command );  Helper metod to set or get PC for current architecture
436    
437  =cut  =cut
438    
439  sub prompt {  sub cpu_PC {
440          my $self = shift;          my ( $self, $addr ) = @_;
441          my $a = shift;          if ( defined($addr) ) {
442          my $last = shift;                  $PC = $addr;
443          print $self->hexdump( $a ),                  warn sprintf("running from PC %04x\n", $PC);
444                  $last ? "[$last] " : '',          };
445                  "> ";          return $PC;
         my $in = <STDIN>;  
         chomp($in);  
         $in ||= $last;  
         $last = $in;  
         return split(/\s+/, $in) if $in;  
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.30  
changed lines
  Added in v.165
  ViewVC Help
Powered by ViewVC 1.1.26