/[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 32 by dpavlin, Mon Jul 30 18:37:37 2007 UTC revision 99 by dpavlin, Thu Aug 2 16:21:17 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/;  use Data::Dump qw/dump/;
11    use List::Util qw/first/;
12    use M6502;
13    
14  use base qw(Class::Accessor M6502 Screen);  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 18  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 30  Emulator or Orao 8-bit 6502 machine popu Line 32  Emulator or Orao 8-bit 6502 machine popu
32    
33  =cut  =cut
34    
35  =head2 init  my @kbd_ports = (
36        0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
37        0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
38        0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
39        0x83FE,0x83FF,
40    );
41    
42  Start emulator  =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  =cut
52    
53  our $orao;  our $orao;
54    
55  sub init {  select(STDERR); $| = 1;
56    
57    sub boot {
58          my $self = shift;          my $self = shift;
59          warn "call upstream init\n";          warn "Orao calling upstream init\n";
60          $self->SUPER::init( @_ );          $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 "staring Orao $Orao::VERSION emulation\n";          warn "emulating ", $#mem, " bytes of memory\n";
68    
69          $self->open_screen;          $self->open_screen;
70          $self->load_rom;          $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;          $orao = $self;
84    
85          $self->prompt( 0x1000 );  #       $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  my $loaded_files = {  =head2 run
133          0xC000 => 'rom/BAS12.ROM',  
134          0xE000 => 'rom/CRT12.ROM',  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 67  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                  warn sprintf "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            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: $!";          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                  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;
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                  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;
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 120  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 158  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    
 =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;  
 }  
   
295  =head1 Memory management  =head1 Memory management
296    
297  Orao implements all I/O using mmap addresses. This was main reason why  Orao implements all I/O using mmap addresses. This was main reason why
# Line 191  L<Acme::6502> was just too slow to handl Line 299  L<Acme::6502> was just too slow to handl
299    
300  =cut  =cut
301    
 my @mem = (0xff) x 0x100000; # 64Mb  
   
302  =head2 read  =head2 read
303    
304  Read from memory  Read from memory
# Line 201  Read from memory Line 307  Read from memory
307    
308  =cut  =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 => {
319                    'return' => sub {
320                            M6502::write( 0xfc, 13 );
321                            return 0;
322                    },
323                    'left ctrl'  => 16,
324                    'right ctrl' => 16,
325            },
326            0x87FA => {
327                    'f4' => 16,
328                    'f3' => 128,
329                    'f2' => 192,
330                    'f1' => 224,
331            },
332            0x87FB => {
333                    'space' => 32,
334                    'left shift' => 16,
335                    'right shift' => 16,
336            },
337            0x87F6 => {
338                    '6' => 16,
339                    't' => 128,
340                    'z' => 192,
341                    'r' => 224,
342            },
343            0x87F7 => {
344                    '5' => 32,
345                    '4' => 16,
346            },
347            0x87EE => {
348                    '7' => 16,
349                    'u' => 128,
350                    'i' => 192,
351                    'o' => 224,
352            },
353            0x87EF => {
354                    '8' => 32,
355                    '9' => 16,
356            },
357            0x87DE => {
358                    '1' => 16,
359                    'w' => 128,
360                    'q' => 192,
361                    'e' => 224,
362            },
363            0x87DF => {
364                    '2' => 32,
365                    '3' => 16,
366            },
367            0x87BE => {
368                    'm' => 16,
369                    'k' => 128,
370                    'j' => 192,
371                    'l' => 224,
372            },
373            0x87BF => {
374                    ',' => 32,
375                    '.' => 16,
376            },
377            0x877E => {
378                    'y' => 16,
379                    's' => 128,
380                    'a' => 192,
381                    'd' => 224,
382            },
383            0x877F => {
384                    'x' => 32,
385                    'c' => 16,
386            },
387            0x86FE => {
388                    'n' => 16,
389                    'g' => 128,
390                    'h' => 192,
391                    'f' => 224,
392            },
393            0x86FF => {
394                    'b' => 32,
395                    'c' => 16,
396            },
397            0x85FE => {
398                    ':' => 16,
399                    '\\' => 128,
400                    '\'' => 192,
401                    ';' => 224,
402                    '8' => 16,      # FIXME?
403            },
404            0x85FF => {
405                    '/' => 32,
406                    '6' => 16,      # FIXME?
407            },
408            0x83FE => {
409                    ';' => 16,
410                    '[' => 128,
411                    ']' => 192,
412                    'p' => 224,
413                    '=' => 16,      # FIXME?
414            },
415            0x83FF => {
416                    '-' => 32,
417                    '0' => 16,
418            },
419    };
420    
421    
422  sub read {  sub read {
423          my $self = $orao;          my $self = shift;
424          my ($addr) = @_;          my ($addr) = @_;
425          my $byte = $mem[$addr];          my $byte = $mem[$addr];
426          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
427          mmap_pixel( $addr, 0, $byte, 0 );          warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
428    
429            # keyboard
430    
431            if ( first { $addr == $_ } @kbd_ports ) {
432                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
433                    my $key = $self->key_pressed;
434                    if ( defined($key) ) {
435                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
436                            if ( my $ret = $r->{$key} ) {
437                                    if ( ref($ret) eq 'CODE' ) {
438                                            $ret = $ret->();
439                                            warn "executed $key and got: $ret\n";
440                                    } else {
441                                            warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret);
442                                    }
443                                    $mem[$addr] = $ret;
444                                    return $ret;
445                            } else {
446                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
447                            }
448                            warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace;
449                    }
450            }
451    
452            $self->mmap_pixel( $addr, 0, $byte, 0 );
453          return $byte;          return $byte;
454  }  }
455    
# Line 219  Write into emory Line 462  Write into emory
462  =cut  =cut
463    
464  sub write {  sub write {
465          my $self = $orao;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
466          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
467            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
468    
469          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr >= 0x6000 && $addr < 0x8000 ) {
470                  $self->vram( $addr - 0x6000 , $byte );                  $self->vram( $addr - 0x6000 , $byte );
471          }          }
472    
         if ( $addr > 0xafff ) {  
                 warn sprintf "access to %04x above affff aborting\n", $addr;  
                 return -1;  
         }  
473          if ( $addr == 0x8800 ) {          if ( $addr == 0x8800 ) {
474                  warn sprintf "sound ignored: %x\n", $byte;                  warn sprintf "sound ignored: %x\n", $byte;
475          }          }
476    
477          mmap_pixel( $addr, $byte, 0, 0 );          if ( $addr > 0xafff ) {
478                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
479            }
480    
481            $self->mmap_pixel( $addr, $byte, 0, 0 );
482    
483          $mem[$addr] = $byte;          $mem[$addr] = $byte;
484            return;
485    }
486    
487    =head1 Command Line
488    
489    Command-line debugging intrerface is implemented for communication with
490    emulated device
491    
492    =head2 prompt
493    
494      my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
495    
496    =cut
497    
498    my $last = 'r 1';
499    
500    sub prompt {
501            my $self = shift;
502            $self->app->sync;
503            my $a = shift;
504            print $self->hexdump( $a ),
505                    $last ? "[$last] " : '',
506                    "> ";
507            my $in = <STDIN>;
508            chomp($in);
509            warn "## prompt got: $in\n" if $self->debug;
510            $in ||= $last;
511            $last = $in;
512            return ( $in, split(/\s+/, $in) ) if $in;
513  }  }
514    
515    =head2 cli
516    
517      $orao->cli();
518    
519    =cut
520    
521    my $show_R = 0;
522    
523    sub cli {
524            my $self = shift;
525            my $a = $PC || confess "no pc?";
526            my $run_for = 0;
527            warn $self->dump_R() if $show_R;
528            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
529                    my $c = shift @v;
530                    next unless defined($c);
531                    my $v = shift @v;
532                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
533                    @v = map { hex($_) } @v;
534                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
535                    if ( $c =~ m/^[qx]/i ) {
536                            exit;
537                    } elsif ( $c eq '?' ) {
538                            my $t = $self->trace ? 'on' : 'off' ;
539                            my $d = $self->debug ? 'on' : 'off' ;
540                            warn <<__USAGE__;
541    Usage:
542    
543    x|q\t\texit
544    e 6000 6010\tdump memory, +/- to walk forward/backward
545    m 1000 ff 00\tput ff 00 on 1000
546    j|u 1000\t\tjump (change pc)
547    r 42\t\trun 42 instruction opcodes
548    t\t\ttrace [$t]
549    d\t\tdebug [$d]
550    
551    __USAGE__
552                            warn $self->dump_R;
553                            $last = '';
554                    } elsif ( $c =~ m/^e/i ) {
555                            $a = $v if defined($v);
556                            my $to = shift @v;
557                            $to = $a + 32 if ( ! $to || $to <= $a );
558                            $to = 0xffff if ( $to > 0xffff );
559                            my $lines = int( ($to - $a + 8) / 8 );
560                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
561                            while ( --$lines ) {
562                                    print $self->hexdump( $a );
563                                    $a += 8;
564                            }
565                            $last = '+';
566                            $show_R = 0;
567                    } elsif ( $c =~ m/^\+/ ) {
568                            $a += 8;
569                            $show_R = 0;
570                    } elsif ( $c =~ m/^\-/ ) {
571                            $a -= 8;
572                            $show_R = 0;
573                    } elsif ( $c =~ m/^m/i ) {
574                            $a = $v if defined($v);
575                            $self->poke_code( $a, @v );
576                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
577                            $last = '+';
578                            $show_R = 0;
579                    } elsif ( $c =~ m/^l/i ) {
580                            my $to = shift @v || 0x1000;
581                            $a = $to;
582                            $self->load_image( $v, $a );
583                            $last = '';
584                    } elsif ( $c =~ m/^s/i ) {
585                            $self->save_dump( $v || 'mem.dump', @v );
586                            $last = '';
587                    } elsif ( $c =~ m/^r/i ) {
588                            $run_for = $v || 1;
589                            print "run_for $run_for instructions\n";
590                            $show_R = 1;
591                            last;
592                    } elsif ( $c =~ m/^(u|j)/ ) {
593                            my $to = $v || $a;
594                            printf "set pc to %04x\n", $to;
595                            $PC = $to;      # remember for restart
596                            $run_for = 1;
597                            $last = "r $run_for";
598                            $show_R = 1;
599                            last;
600                    } elsif ( $c =~ m/^t/ ) {
601                            $self->trace( not $self->trace );
602                            print "trace ", $self->trace ? 'on' : 'off', "\n";
603                            $last = '';
604                    } elsif ( $c =~ m/^d/ ) {
605                            $self->debug( not $self->debug );
606                            print "debug ", $self->debug ? 'on' : 'off', "\n";
607                            $last = '';
608                    } else {
609                            warn "# ignored $line\n" if ($line);
610                            $last = '';
611                    }
612            }
613    
614            return $run_for;
615    }
616    
617  =head1 AUTHOR  =head1 AUTHOR
618    
Legend:
Removed from v.32  
changed lines
  Added in v.99
  ViewVC Help
Powered by ViewVC 1.1.26