/[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 124 by dpavlin, Sat Aug 4 14:13:28 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/;
7  use lib './lib';  use lib './lib';
8  #use Time::HiRes qw(time);  #use Time::HiRes qw(time);
9  use File::Slurp;  use File::Slurp;
10    use Data::Dump qw/dump/;
11    use M6502;
12    
13  use base qw(Class::Accessor M6502 Screen);  use base qw(Class::Accessor VRac M6502 Screen Prefs Tape);
14  __PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));  #__PACKAGE__->mk_accessors(qw());
15    
16  =head1 NAME  =head1 NAME
17    
# Line 17  Orao - Orao emulator Line 19  Orao - Orao emulator
19    
20  =head1 VERSION  =head1 VERSION
21    
22  Version 0.02  Version 0.04
23    
24  =cut  =cut
25    
26  our $VERSION = '0.02';  our $VERSION = '0.04';
27    
28  =head1 SUMMARY  =head1 SUMMARY
29    
# Line 29  Emulator or Orao 8-bit 6502 machine popu Line 31  Emulator or Orao 8-bit 6502 machine popu
31    
32  =cut  =cut
33    
34  =head2 init  =head1 FUNCTIONS
35    
36  Start emulator  =head2 boot
37    
38    Start emulator, open L<Screen>, load initial ROM images, and render memory
39    
40      my $emu = Orao->new({});
41      $emu->boot;
42    
43  =cut  =cut
44    
45  sub init {  our $emu;
46    
47    select(STDERR); $| = 1;
48    
49    sub boot {
50          my $self = shift;          my $self = shift;
51          warn "call upstream init\n";          warn "Orao calling upstream init\n";
52          $self->SUPER::init( @_ );          $self->SUPER::init(
53                    read => sub { $self->read( @_ ) },
54                    write => sub { $self->write( @_ ) },
55            );
56    
57            warn "Orao $Orao::VERSION emulation starting\n";
58    
59          warn "staring Orao $ORAO::VERSION emulation\n";          warn "emulating ", $#mem, " bytes of memory\n";
60    
61          $self->open_screen;          $self->open_screen;
62          $self->load_rom;          $self->load_rom({
63    #               0x1000 => 'dump/SCRINV.BIN',
64                    # should be 0x6000, but oraoemu has 2 byte prefix
65    #               0x5FFE => 'dump/screen.dmp',
66    #               0xC000 => 'rom/Orao/BAS12.ROM',
67    #               0xE000 => 'rom/Orao/CRT12.ROM',
68                    0xC000 => 'rom/Orao/BAS13.ROM',
69                    0xE000 => 'rom/Orao/CRT13.ROM',
70            });
71    
72    #       $PC = 0xDD11;   # BC
73    #       $PC = 0xC274;   # MC
74    
75            $PC = 0xff89;
76    
77            $emu = $self;
78    
79    #       $self->prompt( 0x1000 );
80    
81            my ( $trace, $debug ) = ( $self->trace, $self->debug );
82            $self->trace( 0 );
83            $self->debug( 0 );
84    
85            warn "rendering video memory\n";
86            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
87    
88            if ( $self->show_mem ) {
89    
90                    warn "rendering memory map\n";
91    
92                    $self->render_mem( @mem );
93    
94                    my @mmap = (
95                            0x0000, 0x03FF, 'nulti blok',
96                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
97                            0x6000, 0x7FFF, 'video RAM',
98                            0x8000, 0x9FFF, 'sistemske lokacije',
99                            0xA000, 0xAFFF, 'ekstenzija',
100                            0xB000, 0xBFFF, 'DOS',
101                            0xC000, 0xDFFF, 'BASIC ROM',
102                            0xE000, 0xFFFF, 'sistemski ROM',
103                    );
104    
105            }
106            $self->sync;
107            $self->trace( $trace );
108            $self->debug( $debug );
109    
110            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
111    
112            warn "Orao boot finished",
113                    $self->trace ? ' trace' : '',
114                    $self->debug ? ' debug' : '',
115                    "\n";
116    
117            M6502::reset();
118    
119            $self->booted( 1 );
120  }  }
121    
122  my $loaded_files = {  =head2 run
         0xC000 => 'rom/BAS12.ROM',  
         0xE000 => 'rom/CRT12.ROM',  
 };  
123    
124  =head2 load_rom  Run interactive emulation loop
125    
126  called to init memory and load initial rom images    $emu->run;
127    
128    $orao->load_rom;  =cut
129    
130    sub run {
131            my $self = shift;
132    
133            $self->boot if ( ! $self->booted );
134    
135    #       $self->load_tape( '../oraoigre/bdash.tap' );
136    
137            $self->loop;
138    };
139    
140    =head1 Helper functions
141    
142  =cut  =cut
143    
144  sub load_rom {  # write chunk directly into memory, updateing vram if needed
145      my ($self) = @_;  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      #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( @mem[ 0x6000 .. 0x7fff ] );
162                  printf "loading '%s' at %04x\n", $path, $addr;          $self->render_mem( @mem ) if $self->show_mem;
                 $self->load_oraoemu( $path, $addr );  
         }  
163  }  }
164    
165    =head2 load_image
166    
167    Load binary files, ROM images and Orao Emulator files
168    
169  =head2 load_oraoemu    $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          my $size = -s $path || die "no size for $path: $!";          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: $!";
185    
186          my $buff = read_file( $path );          my $buff = read_file( $path );
187    
188          if ( $size == 65538 ) {          if ( $size == 65538 ) {
189                  $addr = 0;                  $addr = 0;
190                  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;
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                  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;
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          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $size;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
200          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
201            return 1;
202    
203          my $chunk;          my $chunk;
204    
# Line 113  sub load_oraoemu { Line 214  sub load_oraoemu {
214                  $pos += 4;                  $pos += 4;
215          }          }
216    
217          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
218    
219            return 1;
220  };  };
221    
 =head2 save_dump  
222    
223    $orao->save_dump( 'filename', $from, $to );  =head1 Memory management
224    
225    Orao implements all I/O using mmap addresses. This was main reason why
226    L<Acme::6502> was just too slow to handle it.
227    
228  =cut  =cut
229    
230  sub save_dump {  =head2 read
         my $self = shift;  
231    
232          my ( $path, $from, $to ) = @_;  Read from memory
233    
234          $from ||= 0;    $byte = read( $address );
         $to ||= 0xffff;  
235    
236          open(my $fh, '>', $path) || die "can't open $path: $!";  =cut
         print $fh $self->read_chunk( $from, $to );  
         close($fh);  
237    
238          my $size = -s $path;  my $keyboard_none = 255;
         printf "saved %s %d %x bytes\n", $path, $size, $size;  
 }  
239    
240  =head2 hexdump  my $keyboard = {
241            0x87FC => {
242                    'right'         => 16,
243                    'down'          => 128,
244                    'up'            => 192,
245                    'left'          => 224,
246                    'backspace' => 224,
247            },
248            0x87FD => sub {
249                    my ( $self, $key ) = @_;
250                    if ( $key eq 'return' ) {
251                            M6502::_write( 0xfc, 13 );
252                            warn "return\n";
253                            return 0;
254                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
255                            warn "ctrl\n";
256                            return 16;
257                    }
258                    return $keyboard_none;
259            },
260            0x87FA => {
261                    'f4' => 16,
262                    'f3' => 128,
263                    'f2' => 192,
264                    'f1' => 224,
265            },
266            0x87FB => sub {
267                    my ( $self, $key ) = @_;
268                    if ( $key eq 'space' ) {
269                            return 32;
270                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
271                            warn "shift\n";
272                            return 16;
273    #               } elsif ( $self->tape ) {
274    #                       warn "has tape!";
275    #                       return 0;
276                    }
277                    return $keyboard_none;
278            },
279            0x87F6 => {
280                    '6' => 16,
281                    't' => 128,
282                    'y' => 192,     # hr: z
283                    'r' => 224,
284            },
285            0x87F7 => {
286                    '5' => 32,
287                    '4' => 16,
288            },
289            0x87EE => {
290                    '7' => 16,
291                    'u' => 128,
292                    'i' => 192,
293                    'o' => 224,
294            },
295            0x87EF => {
296                    '8' => 32,
297                    '9' => 16,
298            },
299            0x87DE => {
300                    '1' => 16,
301                    'w' => 128,
302                    'q' => 192,
303                    'e' => 224,
304            },
305            0x87DF => {
306                    '2' => 32,
307                    '3' => 16,
308            },
309            0x87BE => {
310                    'm' => 16,
311                    'k' => 128,
312                    'j' => 192,
313                    'l' => 224,
314            },
315            0x87BF => {
316                    ',' => 32,      # <
317                    '.' => 16,      # >
318            },
319            0x877E => {
320                    'z' => 16,      # hr:y
321                    's' => 128,
322                    'a' => 192,
323                    'd' => 224,
324            },
325            0x877F => {
326                    'x' => 32,
327                    'c' => 16,
328            },
329            0x86FE => {
330                    'n' => 16,
331                    'g' => 128,
332                    'h' => 192,
333                    'f' => 224,
334            },
335            0x86FF => {
336                    'b' => 32,
337                    'v' => 16,
338            },
339            0x85FE => {
340                    '<' => 16,              # :
341                    '\\' => 128,    # ¾
342                    '\'' => 192,    # ę
343                    ';' => 224,             # č
344            },
345            0x85FF => {
346                    '/' => 32,
347                    'f11' => 16,    # ^
348            },
349            0x83FE => {
350                    'f12' => 16,    # ;
351                    '[' => 128,             # ¹
352                    ']' => 192,             # š
353                    'p' => 224,
354            },
355            0x83FF => {
356                    '-' => 32,
357                    '0' => 16,
358            },
359    };
360    
361    $orao->hexdump( $address );  sub read {
362            my $self = shift;
363            my ($addr) = @_;
364            my $byte = $mem[$addr];
365            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
366            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
367    
368            # keyboard
369    
370            if ( defined( $keyboard->{$addr} ) ) {
371                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
372                    my $key = $self->key_pressed;
373                    if ( defined($key) ) {
374                            my $ret = $keyboard_none;
375                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
376                            if ( ref($r) eq 'CODE' ) {
377                                    $ret = $r->($self, $key);
378                            } elsif ( defined($r->{$key}) ) {
379                                    $ret = $r->{$key};
380                                    if ( ref($ret) eq 'CODE' ) {
381                                            $ret = $ret->($self);
382                                    }
383                            } else {
384                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
385                            }
386                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
387                            return $ret;
388                    }
389                    return $keyboard_none;
390            }
391    
392  =cut          if ( $addr == 0x87ff ) {
393                    return $self->read_tape;
394            }
395    
396  sub hexdump {          $self->mmap_pixel( $addr, 0, $byte, 0 );
397          my $self = shift;          return $byte;
         my $a = shift;  
         return sprintf(" %04x %s\n", $a,  
                 join(" ",  
                         map {  
                                 sprintf( "%02x", $_ )  
                         } $self->ram( $a, $a+8 )  
                 )  
         );  
398  }  }
399    
400  =head2 prompt  =head2 write
401    
402    Write into emory
403    
404    $orao->prompt( $address, $last_command );    write( $address, $byte );
405    
406  =cut  =cut
407    
408  sub prompt {  sub write {
409          my $self = shift;          my $self = shift;
410          my $a = shift;          my ($addr,$byte) = @_;
411          my $last = shift;          warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
         print $self->hexdump( $a ),  
                 $last ? "[$last] " : '',  
                 "> ";  
         my $in = <STDIN>;  
         chomp($in);  
         $in ||= $last;  
         $last = $in;  
         return split(/\s+/, $in) if $in;  
 }  
412    
413            if ( $addr == 0x8800 ) {
414                    warn sprintf "sound ignored: %x\n", $byte;
415            }
416    
417            if ( $addr > 0xafff ) {
418                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
419            }
420    
421            $self->mmap_pixel( $addr, $byte, 0, 0 );
422    
423            $mem[$addr] = $byte;
424            return;
425    }
426    
427  =head1 AUTHOR  =head1 AUTHOR
428    
Legend:
Removed from v.30  
changed lines
  Added in v.124
  ViewVC Help
Powered by ViewVC 1.1.26