/[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 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/;
11    use M6502;
12    
13  use base qw(Class::Accessor M6502);  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 29  Emulator or Orao 8-bit 6502 machine popu Line 31  Emulator or Orao 8-bit 6502 machine popu
31    
32  =cut  =cut
33    
34  my $loaded_files = {  =head2 init
35          0xC000 => 'rom/BAS12.ROM',  
36          0xE000 => 'rom/CRT12.ROM',  Start emulator, open L<Screen>, load initial ROM images, and render memory
37  };  
38    =cut
39    
40    our $orao;
41    
42    select(STDERR); $| = 1;
43    
44    sub init {
45            my $self = shift;
46            warn "Orao calling upstream init\n";
47            $self->SUPER::init( $self, @_ );
48    
49            warn "Orao $Orao::VERSION emulation starting\n";
50    
51            $self->open_screen;
52            $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;
64    
65    #       $self->prompt( 0x1000 );
66    
67            my ( $trace, $debug ) = ( $self->trace, $self->debug );
68            $self->trace( 0 );
69            $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 43  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};
                 printf "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          my $size = -s $path || die "no size for $path: $!";          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: $!";
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                  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;
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                  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;
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 96  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 119  sub save_dump { Line 225  sub save_dump {
225          close($fh);          close($fh);
226    
227          my $size = -s $path;          my $size = -s $path;
228          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
229  }  }
230    
231  =head2 hexdump  =head2 hexdump
# Line 134  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    
253    =head1 Memory management
254    
255    Orao implements all I/O using mmap addresses. This was main reason why
256    L<Acme::6502> was just too slow to handle it.
257    
258    =cut
259    
260    =head2 read
261    
262    Read from memory
263    
264      $byte = read( $address );
265    
266    =cut
267    
268    sub read {
269            my $self = shift;
270            my ($addr) = @_;
271            my $byte = $mem[$addr];
272            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
273            $self->mmap_pixel( $addr, 0, $byte, 0 );
274            return $byte;
275    }
276    
277    =head2 write
278    
279    Write into emory
280    
281      write( $address, $byte );
282    
283    =cut
284    
285    sub write {
286            my $self = shift;
287            my ($addr,$byte) = @_;
288            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
289    
290            if ( $addr >= 0x6000 && $addr < 0x8000 ) {
291                    $self->vram( $addr - 0x6000 , $byte );
292            }
293    
294            if ( $addr == 0x8800 ) {
295                    warn sprintf "sound ignored: %x\n", $byte;
296            }
297    
298            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;
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  =head2 prompt
315    
316    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
317    
318  =cut  =cut
319    
320    my $last = 'r 1';
321    
322  sub prompt {  sub prompt {
323          my $self = shift;          my $self = shift;
324            $self->app->sync;
325          my $a = shift;          my $a = shift;
326          my $last = shift;          print STDERR $self->hexdump( $a ),
         print $self->hexdump( $a ),  
327                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
328                  "> ";                  "> ";
329          my $in = <STDIN>;          my $in = <STDIN>;
330          chomp($in);          chomp($in);
331            warn "## prompt got: $in\n" if $self->debug;
332          $in ||= $last;          $in ||= $last;
333          $last = $in;          $last = $in;
334          return split(/\s+/, $in) if $in;          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
Legend:
Removed from v.29  
changed lines
  Added in v.77
  ViewVC Help
Powered by ViewVC 1.1.26