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