/[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 82 by dpavlin, Wed Aug 1 21:40: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/;
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(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  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    =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
50    
51    our $orao;
52    
53    select(STDERR); $| = 1;
54    
55    sub boot {
56            my $self = shift;
57            warn "Orao calling upstream init\n";
58            $self->SUPER::init( $self, @_ );
59    
60            warn "Orao $Orao::VERSION emulation starting\n";
61    
62            $self->open_screen;
63            $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    #       $PC = 0xDD11;   # BC
72    #       $PC = 0xC274;   # MC
73    
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            warn dump( M6502->run );
123    }
124    
125  =head2 load_rom  =head2 load_rom
126    
# Line 43  called to init memory and load initial r Line 131  called to init memory and load initial r
131  =cut  =cut
132    
133  sub load_rom {  sub load_rom {
134      my ($self) = @_;      my ($self, $loaded_files) = @_;
135    
136      #my $time_base = time();      #my $time_base = time();
137    
138          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
139                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
                 printf "loading '%s' at %04x\n", $path, $addr;  
140                  $self->load_oraoemu( $path, $addr );                  $self->load_oraoemu( $path, $addr );
141          }          }
142  }  }
143    
144    # write chunk directly into memory, updateing vram if needed
145    sub _write_chunk {
146            my $self = shift;
147            my ( $addr, $chunk ) = @_;
148            $self->write_chunk( $addr, $chunk );
149            my $end = $addr + length($chunk);
150            my ( $f, $t ) = ( 0x6000, 0x7fff );
151    
152            if ( $end < $f || $addr >= $t ) {
153                    warn "skip vram update\n";
154                    return;
155            };
156    
157            $f = $addr if ( $addr > $f );
158            $t = $end if ( $end < $t );
159    
160            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
161    #       foreach my $a ( $f .. $t ) {
162    #               $self->vram( $a - 0x6000 , $mem[ $a ] );
163    #       }
164            $self->render( @mem[ 0x6000 .. 0x7fff ] );
165            $self->render_mem( @mem ) if $self->show_mem;
166    }
167    
168  =head2 load_oraoemu  =head2 load_oraoemu
169    
170    Load binary files, ROM images and Orao Emulator files
171    
172      $orao->load_oraoemu( '/path/to/file', 0x1000 );
173    
174    Returns true on success.
175    
176  =cut  =cut
177    
178  sub load_oraoemu {  sub load_oraoemu {
179          my $self = shift;          my $self = shift;
180          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
181    
182          my $size = -s $path || die "no size for $path: $!";          if ( ! -e $path ) {
183                    warn "ERROR: file $path doesn't exist\n";
184                    return;
185            }
186    
187            my $size = -s $path || confess "no size for $path: $!";
188    
189          my $buff = read_file( $path );          my $buff = read_file( $path );
190    
191          if ( $size == 65538 ) {          if ( $size == 65538 ) {
192                  $addr = 0;                  $addr = 0;
193                  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;
194                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
195                  return;                  return 1;
196          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
197                  $addr = 0;                  $addr = 0;
198                  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;
199                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
200                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
201          }          }
202          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;
203          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
204            return 1;
205    
206          my $chunk;          my $chunk;
207    
# Line 96  sub load_oraoemu { Line 217  sub load_oraoemu {
217                  $pos += 4;                  $pos += 4;
218          }          }
219    
220          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
221    
222            return 1;
223  };  };
224    
225  =head2 save_dump  =head2 save_dump
# Line 119  sub save_dump { Line 241  sub save_dump {
241          close($fh);          close($fh);
242    
243          my $size = -s $path;          my $size = -s $path;
244          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
245  }  }
246    
247  =head2 hexdump  =head2 hexdump
# Line 134  sub hexdump { Line 256  sub hexdump {
256          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
257                  join(" ",                  join(" ",
258                          map {                          map {
259                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
260                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
261                                    } else {
262                                            '  '
263                                    }
264                            } @mem[ $a .. $a+8 ]
265                  )                  )
266          );          );
267  }  }
268    
269    =head1 Memory management
270    
271    Orao implements all I/O using mmap addresses. This was main reason why
272    L<Acme::6502> was just too slow to handle it.
273    
274    =cut
275    
276    =head2 read
277    
278    Read from memory
279    
280      $byte = read( $address );
281    
282    =cut
283    
284    sub read {
285            my $self = shift;
286            my ($addr) = @_;
287            my $byte = $mem[$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
Legend:
Removed from v.29  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.26