/[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

revision 29 by dpavlin, Mon Jul 30 17:32:41 2007 UTC revision 103 by dpavlin, Thu Aug 2 18:01:51 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 List::Util qw/first/;
12    use M6502;
13    
14  use base qw(Class::Accessor M6502);  use base qw(Class::Accessor M6502 Screen Prefs);
15  __PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));  __PACKAGE__->mk_accessors(qw(booted));
16    
17  =head1 NAME  =head1 NAME
18    
# Line 17  Orao - Orao emulator Line 20  Orao - Orao emulator
20    
21  =head1 VERSION  =head1 VERSION
22    
23  Version 0.02  Version 0.04
24    
25  =cut  =cut
26    
27  our $VERSION = '0.02';  our $VERSION = '0.04';
28    
29  =head1 SUMMARY  =head1 SUMMARY
30    
# Line 29  Emulator or Orao 8-bit 6502 machine popu Line 32  Emulator or Orao 8-bit 6502 machine popu
32    
33  =cut  =cut
34    
35  my $loaded_files = {  my @kbd_ports = (
36          0xC000 => 'rom/BAS12.ROM',      0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
37          0xE000 => 'rom/CRT12.ROM',      0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
38        0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
39        0x83FE,0x83FF,
40    );
41    
42    =head1 FUNCTIONS
43    
44    =head2 boot
45    
46    Start emulator, open L<Screen>, load initial ROM images, and render memory
47    
48      my $orao = Orao->new({});
49      $orao->boot;
50    
51    =cut
52    
53    our $orao;
54    
55    select(STDERR); $| = 1;
56    
57    sub boot {
58            my $self = shift;
59            warn "Orao calling upstream init\n";
60            $self->SUPER::init(
61                    read => sub { $self->read( @_ ) },
62                    write => sub { $self->write( @_ ) },
63            );
64    
65            warn "Orao $Orao::VERSION emulation starting\n";
66    
67            warn "emulating ", $#mem, " bytes of memory\n";
68    
69            $self->open_screen;
70            $self->load_rom({
71                    0x1000 => 'dump/SCRINV.BIN',
72                    # should be 0x6000, but oraoemu has 2 byte prefix
73                    0x5FFE => 'dump/screen.dmp',
74                    0xC000 => 'rom/BAS12.ROM',
75                    0xE000 => 'rom/CRT12.ROM',
76            });
77    
78    #       $PC = 0xDD11;   # BC
79    #       $PC = 0xC274;   # MC
80    
81            $PC = 0xff89;
82    
83            $orao = $self;
84    
85    #       $self->prompt( 0x1000 );
86    
87            my ( $trace, $debug ) = ( $self->trace, $self->debug );
88            $self->trace( 0 );
89            $self->debug( 0 );
90    
91            $self->render( @mem[ 0x6000 .. 0x7fff ] );
92    
93            if ( $self->show_mem ) {
94    
95                    warn "rendering memory map\n";
96    
97                    $self->render_mem( @mem );
98    
99                    my @mmap = (
100                            0x0000, 0x03FF, 'nulti blok',
101                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
102                            0x6000, 0x7FFF, 'video RAM',
103                            0x8000, 0x9FFF, 'sistemske lokacije',
104                            0xA000, 0xAFFF, 'ekstenzija',
105                            0xB000, 0xBFFF, 'DOS',
106                            0xC000, 0xDFFF, 'BASIC ROM',
107                            0xE000, 0xFFFF, 'sistemski ROM',
108                    );
109    
110            } else {
111    
112                    warn "rendering video memory\n";
113                    $self->render( @mem[ 0x6000 .. 0x7fff ] );
114            
115            }
116            $self->sync;
117            $self->trace( $trace );
118            $self->debug( $debug );
119    
120            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
121    
122            warn "Orao boot finished",
123                    $self->trace ? ' trace' : '',
124                    $self->debug ? ' debug' : '',
125                    "\n";
126    
127            M6502::reset();
128    
129            $self->booted( 1 );
130    }
131    
132    =head2 run
133    
134    Run interactive emulation loop
135    
136      $orao->run;
137    
138    =cut
139    
140    sub run {
141            my $self = shift;
142    
143            $self->show_mem( 1 );
144    
145            $self->boot if ( ! $self->booted );
146            $self->loop;
147  };  };
148    
149    =head1 Helper functions
150    
151  =head2 load_rom  =head2 load_rom
152    
153  called to init memory and load initial rom images  called to init memory and load initial rom images
# Line 43  called to init memory and load initial r Line 157  called to init memory and load initial r
157  =cut  =cut
158    
159  sub load_rom {  sub load_rom {
160      my ($self) = @_;      my ($self, $loaded_files) = @_;
161    
162      #my $time_base = time();      #my $time_base = time();
163    
164          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
165                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
166                  printf "loading '%s' at %04x\n", $path, $addr;                  $self->load_image( $path, $addr );
                 $self->load_oraoemu( $path, $addr );  
167          }          }
168  }  }
169    
170    # write chunk directly into memory, updateing vram if needed
171    sub _write_chunk {
172            my $self = shift;
173            my ( $addr, $chunk ) = @_;
174            $self->write_chunk( $addr, $chunk );
175            my $end = $addr + length($chunk);
176            my ( $f, $t ) = ( 0x6000, 0x7fff );
177    
178            if ( $end < $f || $addr >= $t ) {
179                    warn "skip vram update\n";
180                    return;
181            };
182    
183            $f = $addr if ( $addr > $f );
184            $t = $end if ( $end < $t );
185    
186            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
187    #       foreach my $a ( $f .. $t ) {
188    #               $self->vram( $a - 0x6000 , $mem[ $a ] );
189    #       }
190            $self->render( @mem[ 0x6000 .. 0x7fff ] );
191            $self->render_mem( @mem ) if $self->show_mem;
192    }
193    
194    =head2 load_image
195    
196    Load binary files, ROM images and Orao Emulator files
197    
198      $orao->load_image( '/path/to/file', 0x1000 );
199    
200  =head2 load_oraoemu  Returns true on success.
201    
202  =cut  =cut
203    
204  sub load_oraoemu {  sub load_image {
205          my $self = shift;          my $self = shift;
206          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
207    
208          my $size = -s $path || die "no size for $path: $!";          if ( ! -e $path ) {
209                    warn "ERROR: file $path doesn't exist\n";
210                    return;
211            }
212    
213            my $size = -s $path || confess "no size for $path: $!";
214    
215          my $buff = read_file( $path );          my $buff = read_file( $path );
216    
217          if ( $size == 65538 ) {          if ( $size == 65538 ) {
218                  $addr = 0;                  $addr = 0;
219                  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;
220                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
221                  return;                  return 1;
222          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
223                  $addr = 0;                  $addr = 0;
224                  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;
225                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
226                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
227          }          }
228          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;
229          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
230            return 1;
231    
232          my $chunk;          my $chunk;
233    
# Line 96  sub load_oraoemu { Line 243  sub load_oraoemu {
243                  $pos += 4;                  $pos += 4;
244          }          }
245    
246          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
247    
248            return 1;
249  };  };
250    
251  =head2 save_dump  =head2 save_dump
# Line 119  sub save_dump { Line 267  sub save_dump {
267          close($fh);          close($fh);
268    
269          my $size = -s $path;          my $size = -s $path;
270          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
271  }  }
272    
273  =head2 hexdump  =head2 hexdump
# Line 134  sub hexdump { Line 282  sub hexdump {
282          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
283                  join(" ",                  join(" ",
284                          map {                          map {
285                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
286                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
287                                    } else {
288                                            '  '
289                                    }
290                            } @mem[ $a .. $a+8 ]
291                  )                  )
292          );          );
293  }  }
294    
295    =head1 Memory management
296    
297    Orao implements all I/O using mmap addresses. This was main reason why
298    L<Acme::6502> was just too slow to handle it.
299    
300    =cut
301    
302    =head2 read
303    
304    Read from memory
305    
306      $byte = read( $address );
307    
308    =cut
309    
310    my $keyboard = {
311            0x87FC => {
312                    'right'         => 16,
313                    'down'          => 128,
314                    'up'            => 192,
315                    'left'          => 224,
316                    'backspace' => 224,
317            },
318            0x87FD => sub {
319                    my ( $self, $key ) = @_;
320                    if ( $key eq 'return' ) {
321                            M6502::_write( 0xfc, 13 );
322                            return 0;
323                    } elsif ( $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
324                            return 16;
325                    }
326            },
327            0x87FA => {
328                    'f4' => 16,
329                    'f3' => 128,
330                    'f2' => 192,
331                    'f1' => 224,
332            },
333            0x87FB => sub {
334                    my ( $self, $key ) = @_;
335                    if ( $key eq 'space' ) {
336                            return 32;
337                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
338                            return 16;
339                    }
340            },
341            0x87F6 => {
342                    '6' => 16,
343                    't' => 128,
344                    'z' => 192,
345                    'r' => 224,
346            },
347            0x87F7 => {
348                    '5' => 32,
349                    '4' => 16,
350            },
351            0x87EE => {
352                    '7' => 16,
353                    'u' => 128,
354                    'i' => 192,
355                    'o' => 224,
356            },
357            0x87EF => {
358                    '8' => 32,
359                    '9' => 16,
360            },
361            0x87DE => {
362                    '1' => 16,
363                    'w' => 128,
364                    'q' => 192,
365                    'e' => 224,
366            },
367            0x87DF => {
368                    '2' => 32,
369                    '3' => 16,
370            },
371            0x87BE => {
372                    'm' => 16,
373                    'k' => 128,
374                    'j' => 192,
375                    'l' => 224,
376            },
377            0x87BF => {
378                    ',' => 32,
379                    '.' => 16,
380            },
381            0x877E => {
382                    'y' => 16,
383                    's' => 128,
384                    'a' => 192,
385                    'd' => 224,
386            },
387            0x877F => {
388                    'x' => 32,
389                    'c' => 16,
390            },
391            0x86FE => {
392                    'n' => 16,
393                    'g' => 128,
394                    'h' => 192,
395                    'f' => 224,
396            },
397            0x86FF => {
398                    'b' => 32,
399                    'v' => 16,
400            },
401            0x85FE => {
402                    ';' => sub { $_[0]->key_down('left shift') ? 16 : 224 },
403                    '\\' => 128,
404                    '\'' => 192,
405    #               ';' => 224,
406                    '8' => 16,      # FIXME?
407            },
408            0x85FF => {
409                    '/' => 32,
410                    '6' => 16,      # FIXME?
411            },
412            0x83FE => {
413                    ';' => 16,
414                    '[' => 128,
415                    ']' => 192,
416                    'p' => 224,
417                    '=' => 16,      # FIXME?
418            },
419            0x83FF => {
420                    '-' => 32,
421                    '0' => 16,
422            },
423    };
424    
425    my $keyboard_none = 255;
426    
427    sub read {
428            my $self = shift;
429            my ($addr) = @_;
430            my $byte = $mem[$addr];
431            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
432            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
433    
434            # keyboard
435    
436            if ( first { $addr == $_ } @kbd_ports ) {
437                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
438                    my $key = $self->key_pressed;
439                    if ( defined($key) ) {
440                            my $ret = $keyboard_none;
441                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
442                            if ( ref($r) eq 'CODE' ) {
443                                    $ret = $r->($self, $key);
444                            } elsif ( $ret = $r->{$key} ) {
445                                    if ( ref($ret) eq 'CODE' ) {
446                                            $ret = $ret->($self);
447                                            warn "executed $key and got: $ret\n";
448                                    } else {
449                                            warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret);
450                                    }
451                                    $mem[$addr] = $ret;
452                                    warn "keypress: $key = $ret\n";
453                                    return $ret;
454                            } else {
455                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
456                            }
457                            warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace;
458                    }
459                    return $keyboard_none;
460            }
461    
462            $self->mmap_pixel( $addr, 0, $byte, 0 );
463            return $byte;
464    }
465    
466    =head2 write
467    
468    Write into emory
469    
470      write( $address, $byte );
471    
472    =cut
473    
474    sub write {
475            my $self = shift;
476            my ($addr,$byte) = @_;
477            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
478    
479            if ( $addr >= 0x6000 && $addr < 0x8000 ) {
480                    $self->vram( $addr - 0x6000 , $byte );
481            }
482    
483            if ( $addr == 0x8800 ) {
484                    warn sprintf "sound ignored: %x\n", $byte;
485            }
486    
487            if ( $addr > 0xafff ) {
488                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
489            }
490    
491            $self->mmap_pixel( $addr, $byte, 0, 0 );
492    
493            $mem[$addr] = $byte;
494            return;
495    }
496    
497    =head1 Command Line
498    
499    Command-line debugging intrerface is implemented for communication with
500    emulated device
501    
502  =head2 prompt  =head2 prompt
503    
504    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
505    
506  =cut  =cut
507    
508    my $last = 'r 1';
509    
510  sub prompt {  sub prompt {
511          my $self = shift;          my $self = shift;
512            $self->app->sync;
513          my $a = shift;          my $a = shift;
         my $last = shift;  
514          print $self->hexdump( $a ),          print $self->hexdump( $a ),
515                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
516                  "> ";                  "> ";
517          my $in = <STDIN>;          my $in = <STDIN>;
518          chomp($in);          chomp($in);
519            warn "## prompt got: $in\n" if $self->debug;
520          $in ||= $last;          $in ||= $last;
521          $last = $in;          $last = $in;
522          return split(/\s+/, $in) if $in;          return ( $in, split(/\s+/, $in) ) if $in;
523    }
524    
525    =head2 cli
526    
527      $orao->cli();
528    
529    =cut
530    
531    my $show_R = 0;
532    
533    sub cli {
534            my $self = shift;
535            my $a = $PC || confess "no pc?";
536            my $run_for = 0;
537            warn $self->dump_R() if $show_R;
538            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
539                    my $c = shift @v;
540                    next unless defined($c);
541                    my $v = shift @v;
542                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
543                    @v = map { hex($_) } @v;
544                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
545                    if ( $c =~ m/^[qx]/i ) {
546                            exit;
547                    } elsif ( $c eq '?' ) {
548                            my $t = $self->trace ? 'on' : 'off' ;
549                            my $d = $self->debug ? 'on' : 'off' ;
550                            warn <<__USAGE__;
551    Usage:
552    
553    x|q\t\texit
554    e 6000 6010\tdump memory, +/- to walk forward/backward
555    m 1000 ff 00\tput ff 00 on 1000
556    j|u 1000\t\tjump (change pc)
557    r 42\t\trun 42 instruction opcodes
558    t\t\ttrace [$t]
559    d\t\tdebug [$d]
560    
561    __USAGE__
562                            warn $self->dump_R;
563                            $last = '';
564                    } elsif ( $c =~ m/^e/i ) {
565                            $a = $v if defined($v);
566                            my $to = shift @v;
567                            $to = $a + 32 if ( ! $to || $to <= $a );
568                            $to = 0xffff if ( $to > 0xffff );
569                            my $lines = int( ($to - $a + 8) / 8 );
570                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
571                            while ( --$lines ) {
572                                    print $self->hexdump( $a );
573                                    $a += 8;
574                            }
575                            $last = '+';
576                            $show_R = 0;
577                    } elsif ( $c =~ m/^\+/ ) {
578                            $a += 8;
579                            $show_R = 0;
580                    } elsif ( $c =~ m/^\-/ ) {
581                            $a -= 8;
582                            $show_R = 0;
583                    } elsif ( $c =~ m/^m/i ) {
584                            $a = $v if defined($v);
585                            $self->poke_code( $a, @v );
586                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
587                            $last = '+';
588                            $show_R = 0;
589                    } elsif ( $c =~ m/^l/i ) {
590                            my $to = shift @v || 0x1000;
591                            $a = $to;
592                            $self->load_image( $v, $a );
593                            $last = '';
594                    } elsif ( $c =~ m/^s/i ) {
595                            $self->save_dump( $v || 'mem.dump', @v );
596                            $last = '';
597                    } elsif ( $c =~ m/^r/i ) {
598                            $run_for = $v || 1;
599                            print "run_for $run_for instructions\n";
600                            $show_R = 1;
601                            last;
602                    } elsif ( $c =~ m/^(u|j)/ ) {
603                            my $to = $v || $a;
604                            printf "set pc to %04x\n", $to;
605                            $PC = $to;      # remember for restart
606                            $run_for = 1;
607                            $last = "r $run_for";
608                            $show_R = 1;
609                            last;
610                    } elsif ( $c =~ m/^t/ ) {
611                            $self->trace( not $self->trace );
612                            print "trace ", $self->trace ? 'on' : 'off', "\n";
613                            $last = '';
614                    } elsif ( $c =~ m/^d/ ) {
615                            $self->debug( not $self->debug );
616                            print "debug ", $self->debug ? 'on' : 'off', "\n";
617                            $last = '';
618                    } else {
619                            warn "# ignored $line\n" if ($line);
620                            $last = '';
621                    }
622            }
623    
624            return $run_for;
625  }  }
626    
627  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.29  
changed lines
  Added in v.103
  ViewVC Help
Powered by ViewVC 1.1.26