/[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 77 by dpavlin, Wed Aug 1 13:01: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 M6502;
12    
13  use base qw(Class::Accessor M6502 Screen);  use base qw(Class::Accessor M6502 Screen Prefs);
14  __PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));  __PACKAGE__->mk_accessors(qw(run_for));
15    
16  =head1 NAME  =head1 NAME
17    
# Line 32  Emulator or Orao 8-bit 6502 machine popu Line 33  Emulator or Orao 8-bit 6502 machine popu
33    
34  =head2 init  =head2 init
35    
36  Start emulator  Start emulator, open L<Screen>, load initial ROM images, and render memory
37    
38  =cut  =cut
39    
40  our $orao;  our $orao;
41    
42    select(STDERR); $| = 1;
43    
44  sub init {  sub init {
45          my $self = shift;          my $self = shift;
46          warn "call upstream init\n";          warn "Orao calling upstream init\n";
47          $self->SUPER::init( @_ );          $self->SUPER::init( $self, @_ );
48    
49          warn "staring Orao $Orao::VERSION emulation\n";          warn "Orao $Orao::VERSION emulation starting\n";
50    
51          $self->open_screen;          $self->open_screen;
52          $self->load_rom;          $self->load_rom({
53                    0x1000 => 'dump/SCRINV.BIN',
54                    # should be 0x6000, but oraoemu has 2 byte prefix
55                    0x5FFE => 'dump/screen.dmp',
56                    0xC000 => 'rom/BAS12.ROM',
57                    0xE000 => 'rom/CRT12.ROM',
58            });
59    
60    #       $PC = 0xDD11;   # BC
61    #       $PC = 0xC274;   # MC
62    
63          $orao = $self;          $orao = $self;
64    
65          $self->prompt( 0x1000 );  #       $self->prompt( 0x1000 );
 }  
66    
67  my $loaded_files = {          my ( $trace, $debug ) = ( $self->trace, $self->debug );
68          0xC000 => 'rom/BAS12.ROM',          $self->trace( 0 );
69          0xE000 => 'rom/CRT12.ROM',          $self->debug( 0 );
70  };  
71            $self->render( @mem[ 0x6000 .. 0x7fff ] );
72    
73            if ( $self->show_mem ) {
74    
75                    warn "rendering memory map\n";
76    
77                    $self->render_mem( @mem );
78    
79                    my @mmap = (
80                            0x0000, 0x03FF, 'nulti blok',
81                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
82                            0x6000, 0x7FFF, 'video RAM',
83                            0x8000, 0x9FFF, 'sistemske lokacije',
84                            0xA000, 0xAFFF, 'ekstenzija',
85                            0xB000, 0xBFFF, 'DOS',
86                            0xC000, 0xDFFF, 'BASIC ROM',
87                            0xE000, 0xFFFF, 'sistemski ROM',
88                    );
89    
90            } else {
91    
92                    warn "rendering video memory\n";
93                    $self->render( @mem[ 0x6000 .. 0x7fff ] );
94            
95            }
96            $self->sync;
97            $self->trace( $trace );
98            $self->debug( $debug );
99    
100            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
101    
102            warn "Orao init finished",
103                    $self->trace ? ' trace' : '',
104                    $self->debug ? ' debug' : '',
105                    "\n";
106    
107    }
108    
109  =head2 load_rom  =head2 load_rom
110    
# Line 67  called to init memory and load initial r Line 115  called to init memory and load initial r
115  =cut  =cut
116    
117  sub load_rom {  sub load_rom {
118      my ($self) = @_;      my ($self, $loaded_files) = @_;
119    
120      #my $time_base = time();      #my $time_base = time();
121    
122          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
123                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
                 warn sprintf "loading '%s' at %04x\n", $path, $addr;  
124                  $self->load_oraoemu( $path, $addr );                  $self->load_oraoemu( $path, $addr );
125          }          }
126  }  }
127    
128    # write chunk directly into memory, updateing vram if needed
129    sub _write_chunk {
130            my $self = shift;
131            my ( $addr, $chunk ) = @_;
132            $self->write_chunk( $addr, $chunk );
133            my $end = $addr + length($chunk);
134            my ( $f, $t ) = ( 0x6000, 0x7fff );
135    
136            if ( $end < $f || $addr >= $t ) {
137                    warn "skip vram update\n";
138                    return;
139            };
140    
141            $f = $addr if ( $addr > $f );
142            $t = $end if ( $end < $t );
143    
144            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
145    #       foreach my $a ( $f .. $t ) {
146    #               $self->vram( $a - 0x6000 , $mem[ $a ] );
147    #       }
148            $self->render( @mem[ 0x6000 .. 0x7fff ] );
149            $self->render_mem( @mem ) if $self->show_mem;
150    }
151    
152  =head2 load_oraoemu  =head2 load_oraoemu
153    
154    Load binary files, ROM images and Orao Emulator files
155    
156      $orao->load_oraoemu( '/path/to/file', 0x1000 );
157    
158    Returns true on success.
159    
160  =cut  =cut
161    
162  sub load_oraoemu {  sub load_oraoemu {
163          my $self = shift;          my $self = shift;
164          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
165    
166            if ( ! -e $path ) {
167                    warn "ERROR: file $path doesn't exist\n";
168                    return;
169            }
170    
171          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
172    
173          my $buff = read_file( $path );          my $buff = read_file( $path );
174    
175          if ( $size == 65538 ) {          if ( $size == 65538 ) {
176                  $addr = 0;                  $addr = 0;
177                  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;
178                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
179                  return;                  return 1;
180          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
181                  $addr = 0;                  $addr = 0;
182                  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;
183                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
184                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
185          }          }
186          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;
187          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
188            return 1;
189    
190          my $chunk;          my $chunk;
191    
# Line 120  sub load_oraoemu { Line 201  sub load_oraoemu {
201                  $pos += 4;                  $pos += 4;
202          }          }
203    
204          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
205    
206            return 1;
207  };  };
208    
209  =head2 save_dump  =head2 save_dump
# Line 158  sub hexdump { Line 240  sub hexdump {
240          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
241                  join(" ",                  join(" ",
242                          map {                          map {
243                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
244                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
245                                    } else {
246                                            '  '
247                                    }
248                            } @mem[ $a .. $a+8 ]
249                  )                  )
250          );          );
251  }  }
252    
 =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;  
 }  
   
253  =head1 Memory management  =head1 Memory management
254    
255  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 257  L<Acme::6502> was just too slow to handl
257    
258  =cut  =cut
259    
 my @mem = (0xff) x 0x100000; # 64Mb  
   
260  =head2 read  =head2 read
261    
262  Read from memory  Read from memory
# Line 202  Read from memory Line 266  Read from memory
266  =cut  =cut
267    
268  sub read {  sub read {
269          my $self = $orao;          my $self = shift;
270          my ($addr) = @_;          my ($addr) = @_;
271          my $byte = $mem[$addr];          my $byte = $mem[$addr];
272          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
273          mmap_pixel( $addr, 0, $byte, 0 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
274          return $byte;          return $byte;
275  }  }
276    
# Line 219  Write into emory Line 283  Write into emory
283  =cut  =cut
284    
285  sub write {  sub write {
286          my $self = $orao;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
287          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
288            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
289    
290          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr >= 0x6000 && $addr < 0x8000 ) {
291                  $self->vram( $addr - 0x6000 , $byte );                  $self->vram( $addr - 0x6000 , $byte );
292          }          }
293    
         if ( $addr > 0xafff ) {  
                 warn sprintf "access to %04x above affff aborting\n", $addr;  
                 return -1;  
         }  
294          if ( $addr == 0x8800 ) {          if ( $addr == 0x8800 ) {
295                  warn sprintf "sound ignored: %x\n", $byte;                  warn sprintf "sound ignored: %x\n", $byte;
296          }          }
297    
298          mmap_pixel( $addr, $byte, 0, 0 );          if ( $addr > 0xafff ) {
299                    warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
300                    return;
301            }
302    
303            $self->mmap_pixel( $addr, $byte, 0, 0 );
304    
305          $mem[$addr] = $byte;          $mem[$addr] = $byte;
306            return;
307    }
308    
309    =head1 Command Line
310    
311    Command-line debugging intrerface is implemented for communication with
312    emulated device
313    
314    =head2 prompt
315    
316      my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
317    
318    =cut
319    
320    my $last = 'r 1';
321    
322    sub prompt {
323            my $self = shift;
324            $self->app->sync;
325            my $a = shift;
326            print STDERR $self->hexdump( $a ),
327                    $last ? "[$last] " : '',
328                    "> ";
329            my $in = <STDIN>;
330            chomp($in);
331            warn "## prompt got: $in\n" if $self->debug;
332            $in ||= $last;
333            $last = $in;
334            return ( $in, split(/\s+/, $in) ) if $in;
335  }  }
336    
337    =head2 cli
338    
339      $orao->cli();
340    
341    =cut
342    
343    my $show_R = 0;
344    
345    sub cli {
346            my $self = shift;
347            my $a = $PC || confess "no pc?";
348            warn $self->dump_R() if $show_R;
349            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
350                    my $c = shift @v;
351                    next unless defined($c);
352                    my $v = shift @v;
353                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
354                    @v = map { hex($_) } @v;
355                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
356                    if ( $c =~ m/^[qx]/i ) {
357                            exit;
358                    } elsif ( $c eq '?' ) {
359                            my $t = $self->trace ? 'on' : 'off' ;
360                            my $d = $self->debug ? 'on' : 'off' ;
361                            warn <<__USAGE__;
362    Usage:
363    
364    x|q\t\texit
365    e 6000 6010\tdump memory, +/- to walk forward/backward
366    m 1000 ff 00\tput ff 00 on 1000
367    j|u 1000\t\tjump (change pc)
368    r 42\t\trun 42 instruction opcodes
369    t\t\ttrace [$t]
370    d\t\tdebug [$d]
371    
372    __USAGE__
373                            warn $self->dump_R;
374                    } elsif ( $c =~ m/^e/i ) {
375                            $a = $v if defined($v);
376                            my $to = shift @v;
377                            $to = $a + 32 if ( ! $to || $to <= $a );
378                            $to = 0xffff if ( $to > 0xffff );
379                            my $lines = int( ($to - $a + 8) / 8 );
380                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
381                            while ( --$lines ) {
382                                    print $self->hexdump( $a );
383                                    $a += 8;
384                            }
385                            $last = '+';
386                            $show_R = 0;
387                    } elsif ( $c =~ m/^\+/ ) {
388                            $a += 8;
389                            $show_R = 0;
390                    } elsif ( $c =~ m/^\-/ ) {
391                            $a -= 8;
392                            $show_R = 0;
393                    } elsif ( $c =~ m/^m/i ) {
394                            $a = $v if defined($v);
395                            $self->poke_code( $a, @v );
396                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
397                            $last = '+';
398                            $show_R = 0;
399                    } elsif ( $c =~ m/^l/i ) {
400                            my $to = shift @v || 0x1000;
401                            $a = $to;
402                            $self->load_oraoemu( $v, $a );
403                            $last = '';
404                    } elsif ( $c =~ m/^s/i ) {
405                            $self->save_dump( $v || 'mem.dump', @v );
406                            $last = '';
407                    } elsif ( $c =~ m/^r/i ) {
408                            $run_for = $v || 1;
409                            print "run_for $run_for instructions\n";
410                            $show_R = 1;
411                            last;
412                    } elsif ( $c =~ m/^(u|j)/ ) {
413                            my $to = $v || $a;
414                            printf "set pc to %04x\n", $to;
415                            $PC = $to;      # remember for restart
416                            $run_for = 1;
417                            $last = "r $run_for";
418                            $show_R = 1;
419                            last;
420                    } elsif ( $c =~ m/^t/ ) {
421                            $self->trace( not $self->trace );
422                            print "trace ", $self->trace ? 'on' : 'off', "\n";
423                            $last = '';
424                    } elsif ( $c =~ m/^d/ ) {
425                            $self->debug( not $self->debug );
426                            print "debug ", $self->debug ? 'on' : 'off', "\n";
427                            $last = '';
428                    } else {
429                            warn "# ignored $line\n" if ($line);
430                            $last = '';
431                    }
432            }
433    
434    }
435    
436  =head1 AUTHOR  =head1 AUTHOR
437    
Legend:
Removed from v.32  
changed lines
  Added in v.77
  ViewVC Help
Powered by ViewVC 1.1.26