/[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 30 by dpavlin, Mon Jul 30 17:56:13 2007 UTC revision 87 by dpavlin, Thu Aug 2 11:08:10 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 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(run_for));
16    
17  =head1 NAME  =head1 NAME
18    
# 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  =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  =head2 boot
43    
44    Start emulator, open L<Screen>, load initial ROM images, and render memory
45    
46      my $orao = Orao->new({});
47      $orao->boot;
48    
49  =cut  =cut
50    
51  sub init {  our $orao;
52    
53    select(STDERR); $| = 1;
54    
55    sub boot {
56          my $self = shift;          my $self = shift;
57          warn "call upstream init\n";          warn "Orao calling upstream init\n";
58          $self->SUPER::init( @_ );          $self->SUPER::init( $self, @_ );
59    
60          warn "staring Orao $ORAO::VERSION emulation\n";          warn "Orao $Orao::VERSION emulation starting\n";
61    
62          $self->open_screen;          $self->open_screen;
63          $self->load_rom;          $self->load_rom({
64  }                  0x1000 => 'dump/SCRINV.BIN',
65                    # should be 0x6000, but oraoemu has 2 byte prefix
66                    0x5FFE => 'dump/screen.dmp',
67                    0xC000 => 'rom/BAS12.ROM',
68                    0xE000 => 'rom/CRT12.ROM',
69            });
70    
71  my $loaded_files = {  #       $PC = 0xDD11;   # BC
72          0xC000 => 'rom/BAS12.ROM',  #       $PC = 0xC274;   # MC
73          0xE000 => 'rom/CRT12.ROM',  
74  };          $PC = 0xff89;
75    
76            $orao = $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            $self->render( @mem[ 0x6000 .. 0x7fff ] );
85    
86            if ( $self->show_mem ) {
87    
88                    warn "rendering memory map\n";
89    
90                    $self->render_mem( @mem );
91    
92                    my @mmap = (
93                            0x0000, 0x03FF, 'nulti blok',
94                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
95                            0x6000, 0x7FFF, 'video RAM',
96                            0x8000, 0x9FFF, 'sistemske lokacije',
97                            0xA000, 0xAFFF, 'ekstenzija',
98                            0xB000, 0xBFFF, 'DOS',
99                            0xC000, 0xDFFF, 'BASIC ROM',
100                            0xE000, 0xFFFF, 'sistemski ROM',
101                    );
102    
103            } else {
104    
105                    warn "rendering video memory\n";
106                    $self->render( @mem[ 0x6000 .. 0x7fff ] );
107            
108            }
109            $self->sync;
110            $self->trace( $trace );
111            $self->debug( $debug );
112    
113            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
114    
115            warn "Orao boot finished",
116                    $self->trace ? ' trace' : '',
117                    $self->debug ? ' debug' : '',
118                    "\n";
119    
120            M6502::reset();
121    
122    }
123    
124  =head2 load_rom  =head2 load_rom
125    
# Line 60  called to init memory and load initial r Line 130  called to init memory and load initial r
130  =cut  =cut
131    
132  sub load_rom {  sub load_rom {
133      my ($self) = @_;      my ($self, $loaded_files) = @_;
134    
135      #my $time_base = time();      #my $time_base = time();
136    
137          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
138                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
                 printf "loading '%s' at %04x\n", $path, $addr;  
139                  $self->load_oraoemu( $path, $addr );                  $self->load_oraoemu( $path, $addr );
140          }          }
141  }  }
142    
143    # write chunk directly into memory, updateing vram if needed
144    sub _write_chunk {
145            my $self = shift;
146            my ( $addr, $chunk ) = @_;
147            $self->write_chunk( $addr, $chunk );
148            my $end = $addr + length($chunk);
149            my ( $f, $t ) = ( 0x6000, 0x7fff );
150    
151            if ( $end < $f || $addr >= $t ) {
152                    warn "skip vram update\n";
153                    return;
154            };
155    
156            $f = $addr if ( $addr > $f );
157            $t = $end if ( $end < $t );
158    
159            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
160    #       foreach my $a ( $f .. $t ) {
161    #               $self->vram( $a - 0x6000 , $mem[ $a ] );
162    #       }
163            $self->render( @mem[ 0x6000 .. 0x7fff ] );
164            $self->render_mem( @mem ) if $self->show_mem;
165    }
166    
167  =head2 load_oraoemu  =head2 load_oraoemu
168    
169    Load binary files, ROM images and Orao Emulator files
170    
171      $orao->load_oraoemu( '/path/to/file', 0x1000 );
172    
173    Returns true on success.
174    
175  =cut  =cut
176    
177  sub load_oraoemu {  sub load_oraoemu {
178          my $self = shift;          my $self = shift;
179          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
180    
181          my $size = -s $path || die "no size for $path: $!";          if ( ! -e $path ) {
182                    warn "ERROR: file $path doesn't exist\n";
183                    return;
184            }
185    
186            my $size = -s $path || confess "no size for $path: $!";
187    
188          my $buff = read_file( $path );          my $buff = read_file( $path );
189    
190          if ( $size == 65538 ) {          if ( $size == 65538 ) {
191                  $addr = 0;                  $addr = 0;
192                  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;
193                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
194                  return;                  return 1;
195          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
196                  $addr = 0;                  $addr = 0;
197                  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;
198                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
199                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
200          }          }
201          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;
202          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
203            return 1;
204    
205          my $chunk;          my $chunk;
206    
# Line 113  sub load_oraoemu { Line 216  sub load_oraoemu {
216                  $pos += 4;                  $pos += 4;
217          }          }
218    
219          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
220    
221            return 1;
222  };  };
223    
224  =head2 save_dump  =head2 save_dump
# Line 136  sub save_dump { Line 240  sub save_dump {
240          close($fh);          close($fh);
241    
242          my $size = -s $path;          my $size = -s $path;
243          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
244  }  }
245    
246  =head2 hexdump  =head2 hexdump
# Line 151  sub hexdump { Line 255  sub hexdump {
255          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
256                  join(" ",                  join(" ",
257                          map {                          map {
258                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
259                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
260                                    } else {
261                                            '  '
262                                    }
263                            } @mem[ $a .. $a+8 ]
264                  )                  )
265          );          );
266  }  }
267    
268    =head1 Memory management
269    
270    Orao implements all I/O using mmap addresses. This was main reason why
271    L<Acme::6502> was just too slow to handle it.
272    
273    =cut
274    
275    =head2 read
276    
277    Read from memory
278    
279      $byte = read( $address );
280    
281    =cut
282    
283    sub read {
284            my $self = shift;
285            my ($addr) = @_;
286            my $byte = $mem[$addr];
287            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
288    
289            # keyboard
290    
291            if ( first { $addr == $_ } @kbd_ports ) {
292                    warn sprintf("keyboard port: %04x\n",$addr);
293            } elsif ( $addr == 0x87fc ) {
294                    warn "0x87fc - arrows/back\n";
295    =for pascal
296                    if VKey=VK_RIGHT then Result:=16;
297                    if VKey=VK_DOWN then Result:=128;
298                    if VKey=VK_UP then Result:=192;
299                    if VKey=VK_LEFT then Result:=224;
300                    if Ord(KeyPressed)=VK_BACK then Result:=224;
301    =cut
302            } elsif ( $addr == 0x87fd ) {
303                    warn "0x87fd - enter\n";
304    =for pascal
305        if KeyPressed=Chr(13) then begin
306          Mem[$FC]:=13;
307          Result:=0;
308        end;
309    =cut
310            } elsif ( $addr == 0x87fa ) {
311                    warn "0x87fa = F1 - F4\n";
312    =for pascal
313        if VKey=VK_F4 then Result:=16;
314        if VKey=VK_F3 then Result:=128;
315        if VKey=VK_F2 then Result:=192;
316        if VKey=VK_F1 then Result:=224;
317    =cut
318            } elsif ( $addr == 0x87fb ) {
319                    warn "0x87fb\n";
320    =for pascal
321        if KeyPressed=Chr(32) then Result:=32;
322        if KeyPressed='"' then Result:=16;
323        if KeyPressed='!' then Result:=16;
324        if KeyPressed='$' then Result:=16;
325        if KeyPressed='%' then Result:=16;
326        if KeyPressed='&' then Result:=16;
327        if KeyPressed='(' then Result:=16;
328        if KeyPressed=')' then Result:=16;
329        if KeyPressed='=' then Result:=16;
330        if KeyPressed='#' then Result:=16;
331        if KeyPressed='+' then Result:=16;
332        if KeyPressed='*' then Result:=16;
333        if KeyPressed='?' then Result:=16;
334        if KeyPressed='<' then Result:=16;
335        if KeyPressed='>' then Result:=16;
336        if VKey=191 then Result:=16;
337    =cut
338            }
339    
340            $self->mmap_pixel( $addr, 0, $byte, 0 );
341            return $byte;
342    }
343    
344    =head2 write
345    
346    Write into emory
347    
348      write( $address, $byte );
349    
350    =cut
351    
352    sub write {
353            my $self = shift;
354            my ($addr,$byte) = @_;
355            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
356    
357            if ( $addr >= 0x6000 && $addr < 0x8000 ) {
358                    $self->vram( $addr - 0x6000 , $byte );
359            }
360    
361            if ( $addr == 0x8800 ) {
362                    warn sprintf "sound ignored: %x\n", $byte;
363            }
364    
365            if ( $addr > 0xafff ) {
366                    warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
367                    return;
368            }
369    
370            $self->mmap_pixel( $addr, $byte, 0, 0 );
371    
372            $mem[$addr] = $byte;
373            return;
374    }
375    
376    =head1 Command Line
377    
378    Command-line debugging intrerface is implemented for communication with
379    emulated device
380    
381  =head2 prompt  =head2 prompt
382    
383    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
384    
385  =cut  =cut
386    
387    my $last = 'r 1';
388    
389  sub prompt {  sub prompt {
390          my $self = shift;          my $self = shift;
391            $self->app->sync;
392          my $a = shift;          my $a = shift;
393          my $last = shift;          print STDERR $self->hexdump( $a ),
         print $self->hexdump( $a ),  
394                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
395                  "> ";                  "> ";
396          my $in = <STDIN>;          my $in = <STDIN>;
397          chomp($in);          chomp($in);
398            warn "## prompt got: $in\n" if $self->debug;
399          $in ||= $last;          $in ||= $last;
400          $last = $in;          $last = $in;
401          return split(/\s+/, $in) if $in;          return ( $in, split(/\s+/, $in) ) if $in;
402  }  }
403    
404    =head2 cli
405    
406      $orao->cli();
407    
408    =cut
409    
410    my $show_R = 0;
411    
412    sub cli {
413            my $self = shift;
414            my $a = $PC || confess "no pc?";
415            warn $self->dump_R() if $show_R;
416            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
417                    my $c = shift @v;
418                    next unless defined($c);
419                    my $v = shift @v;
420                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
421                    @v = map { hex($_) } @v;
422                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
423                    if ( $c =~ m/^[qx]/i ) {
424                            exit;
425                    } elsif ( $c eq '?' ) {
426                            my $t = $self->trace ? 'on' : 'off' ;
427                            my $d = $self->debug ? 'on' : 'off' ;
428                            warn <<__USAGE__;
429    Usage:
430    
431    x|q\t\texit
432    e 6000 6010\tdump memory, +/- to walk forward/backward
433    m 1000 ff 00\tput ff 00 on 1000
434    j|u 1000\t\tjump (change pc)
435    r 42\t\trun 42 instruction opcodes
436    t\t\ttrace [$t]
437    d\t\tdebug [$d]
438    
439    __USAGE__
440                            warn $self->dump_R;
441                    } elsif ( $c =~ m/^e/i ) {
442                            $a = $v if defined($v);
443                            my $to = shift @v;
444                            $to = $a + 32 if ( ! $to || $to <= $a );
445                            $to = 0xffff if ( $to > 0xffff );
446                            my $lines = int( ($to - $a + 8) / 8 );
447                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
448                            while ( --$lines ) {
449                                    print $self->hexdump( $a );
450                                    $a += 8;
451                            }
452                            $last = '+';
453                            $show_R = 0;
454                    } elsif ( $c =~ m/^\+/ ) {
455                            $a += 8;
456                            $show_R = 0;
457                    } elsif ( $c =~ m/^\-/ ) {
458                            $a -= 8;
459                            $show_R = 0;
460                    } elsif ( $c =~ m/^m/i ) {
461                            $a = $v if defined($v);
462                            $self->poke_code( $a, @v );
463                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
464                            $last = '+';
465                            $show_R = 0;
466                    } elsif ( $c =~ m/^l/i ) {
467                            my $to = shift @v || 0x1000;
468                            $a = $to;
469                            $self->load_oraoemu( $v, $a );
470                            $last = '';
471                    } elsif ( $c =~ m/^s/i ) {
472                            $self->save_dump( $v || 'mem.dump', @v );
473                            $last = '';
474                    } elsif ( $c =~ m/^r/i ) {
475                            $run_for = $v || 1;
476                            print "run_for $run_for instructions\n";
477                            $show_R = 1;
478                            last;
479                    } elsif ( $c =~ m/^(u|j)/ ) {
480                            my $to = $v || $a;
481                            printf "set pc to %04x\n", $to;
482                            $PC = $to;      # remember for restart
483                            $run_for = 1;
484                            $last = "r $run_for";
485                            $show_R = 1;
486                            last;
487                    } elsif ( $c =~ m/^t/ ) {
488                            $self->trace( not $self->trace );
489                            print "trace ", $self->trace ? 'on' : 'off', "\n";
490                            $last = '';
491                    } elsif ( $c =~ m/^d/ ) {
492                            $self->debug( not $self->debug );
493                            print "debug ", $self->debug ? 'on' : 'off', "\n";
494                            $last = '';
495                    } else {
496                            warn "# ignored $line\n" if ($line);
497                            $last = '';
498                    }
499            }
500    
501    }
502    
503  =head1 AUTHOR  =head1 AUTHOR
504    
Legend:
Removed from v.30  
changed lines
  Added in v.87
  ViewVC Help
Powered by ViewVC 1.1.26