/[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 89 by dpavlin, Thu Aug 2 12:01:09 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            confess sprintf("can't find memory at address %04x",$addr);
288            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
289    
290            # keyboard
291    
292            if ( first { $addr == $_ } @kbd_ports ) {
293                    warn sprintf("keyboard port: %04x\n",$addr);
294            } elsif ( $addr == 0x87fc ) {
295                    warn "0x87fc - arrows/back\n";
296    =for pascal
297                    if VKey=VK_RIGHT then Result:=16;
298                    if VKey=VK_DOWN then Result:=128;
299                    if VKey=VK_UP then Result:=192;
300                    if VKey=VK_LEFT then Result:=224;
301                    if Ord(KeyPressed)=VK_BACK then Result:=224;
302    =cut
303            } elsif ( $addr == 0x87fd ) {
304                    warn "0x87fd - enter\n";
305    =for pascal
306        if KeyPressed=Chr(13) then begin
307          Mem[$FC]:=13;
308          Result:=0;
309        end;
310    =cut
311            } elsif ( $addr == 0x87fa ) {
312                    warn "0x87fa = F1 - F4\n";
313    =for pascal
314        if VKey=VK_F4 then Result:=16;
315        if VKey=VK_F3 then Result:=128;
316        if VKey=VK_F2 then Result:=192;
317        if VKey=VK_F1 then Result:=224;
318    =cut
319            } elsif ( $addr == 0x87fb ) {
320                    warn "0x87fb\n";
321    =for pascal
322        if KeyPressed=Chr(32) then Result:=32;
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 KeyPressed='>' then Result:=16;
337        if VKey=191 then Result:=16;
338    =cut
339            }
340    
341            $self->mmap_pixel( $addr, 0, $byte, 0 );
342            return $byte;
343    }
344    
345    =head2 write
346    
347    Write into emory
348    
349      write( $address, $byte );
350    
351    =cut
352    
353    sub write {
354            my $self = shift;
355            my ($addr,$byte) = @_;
356            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
357    
358            if ( $addr >= 0x6000 && $addr < 0x8000 ) {
359                    $self->vram( $addr - 0x6000 , $byte );
360            }
361    
362            if ( $addr == 0x8800 ) {
363                    warn sprintf "sound ignored: %x\n", $byte;
364            }
365    
366            if ( $addr > 0xafff ) {
367                    warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
368                    return;
369            }
370    
371            $self->mmap_pixel( $addr, $byte, 0, 0 );
372    
373            $mem[$addr] = $byte;
374            return;
375    }
376    
377    =head1 Command Line
378    
379    Command-line debugging intrerface is implemented for communication with
380    emulated device
381    
382  =head2 prompt  =head2 prompt
383    
384    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
385    
386  =cut  =cut
387    
388    my $last = 'r 1';
389    
390  sub prompt {  sub prompt {
391          my $self = shift;          my $self = shift;
392            $self->app->sync;
393          my $a = shift;          my $a = shift;
394          my $last = shift;          print STDERR $self->hexdump( $a ),
         print $self->hexdump( $a ),  
395                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
396                  "> ";                  "> ";
397          my $in = <STDIN>;          my $in = <STDIN>;
398          chomp($in);          chomp($in);
399            warn "## prompt got: $in\n" if $self->debug;
400          $in ||= $last;          $in ||= $last;
401          $last = $in;          $last = $in;
402          return split(/\s+/, $in) if $in;          return ( $in, split(/\s+/, $in) ) if $in;
403  }  }
404    
405    =head2 cli
406    
407      $orao->cli();
408    
409    =cut
410    
411    my $show_R = 0;
412    
413    sub cli {
414            my $self = shift;
415            my $a = $PC || confess "no pc?";
416            warn $self->dump_R() if $show_R;
417            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
418                    my $c = shift @v;
419                    next unless defined($c);
420                    my $v = shift @v;
421                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
422                    @v = map { hex($_) } @v;
423                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
424                    if ( $c =~ m/^[qx]/i ) {
425                            exit;
426                    } elsif ( $c eq '?' ) {
427                            my $t = $self->trace ? 'on' : 'off' ;
428                            my $d = $self->debug ? 'on' : 'off' ;
429                            warn <<__USAGE__;
430    Usage:
431    
432    x|q\t\texit
433    e 6000 6010\tdump memory, +/- to walk forward/backward
434    m 1000 ff 00\tput ff 00 on 1000
435    j|u 1000\t\tjump (change pc)
436    r 42\t\trun 42 instruction opcodes
437    t\t\ttrace [$t]
438    d\t\tdebug [$d]
439    
440    __USAGE__
441                            warn $self->dump_R;
442                    } elsif ( $c =~ m/^e/i ) {
443                            $a = $v if defined($v);
444                            my $to = shift @v;
445                            $to = $a + 32 if ( ! $to || $to <= $a );
446                            $to = 0xffff if ( $to > 0xffff );
447                            my $lines = int( ($to - $a + 8) / 8 );
448                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
449                            while ( --$lines ) {
450                                    print $self->hexdump( $a );
451                                    $a += 8;
452                            }
453                            $last = '+';
454                            $show_R = 0;
455                    } elsif ( $c =~ m/^\+/ ) {
456                            $a += 8;
457                            $show_R = 0;
458                    } elsif ( $c =~ m/^\-/ ) {
459                            $a -= 8;
460                            $show_R = 0;
461                    } elsif ( $c =~ m/^m/i ) {
462                            $a = $v if defined($v);
463                            $self->poke_code( $a, @v );
464                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
465                            $last = '+';
466                            $show_R = 0;
467                    } elsif ( $c =~ m/^l/i ) {
468                            my $to = shift @v || 0x1000;
469                            $a = $to;
470                            $self->load_oraoemu( $v, $a );
471                            $last = '';
472                    } elsif ( $c =~ m/^s/i ) {
473                            $self->save_dump( $v || 'mem.dump', @v );
474                            $last = '';
475                    } elsif ( $c =~ m/^r/i ) {
476                            $run_for = $v || 1;
477                            print "run_for $run_for instructions\n";
478                            $show_R = 1;
479                            last;
480                    } elsif ( $c =~ m/^(u|j)/ ) {
481                            my $to = $v || $a;
482                            printf "set pc to %04x\n", $to;
483                            $PC = $to;      # remember for restart
484                            $run_for = 1;
485                            $last = "r $run_for";
486                            $show_R = 1;
487                            last;
488                    } elsif ( $c =~ m/^t/ ) {
489                            $self->trace( not $self->trace );
490                            print "trace ", $self->trace ? 'on' : 'off', "\n";
491                            $last = '';
492                    } elsif ( $c =~ m/^d/ ) {
493                            $self->debug( not $self->debug );
494                            print "debug ", $self->debug ? 'on' : 'off', "\n";
495                            $last = '';
496                    } else {
497                            warn "# ignored $line\n" if ($line);
498                            $last = '';
499                    }
500            }
501    
502    }
503    
504  =head1 AUTHOR  =head1 AUTHOR
505    

Legend:
Removed from v.30  
changed lines
  Added in v.89

  ViewVC Help
Powered by ViewVC 1.1.26