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