/[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 106 by dpavlin, Fri Aug 3 08:44:45 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 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(booted));
15    
16  =head1 NAME  =head1 NAME
17    
# Line 17  Orao - Orao emulator Line 19  Orao - Orao emulator
19    
20  =head1 VERSION  =head1 VERSION
21    
22  Version 0.02  Version 0.04
23    
24  =cut  =cut
25    
26  our $VERSION = '0.02';  our $VERSION = '0.04';
27    
28  =head1 SUMMARY  =head1 SUMMARY
29    
# 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  =head2 init  =head1 FUNCTIONS
35    
36  Start emulator  =head2 boot
37    
38    Start emulator, open L<Screen>, load initial ROM images, and render memory
39    
40      my $orao = Orao->new({});
41      $orao->boot;
42    
43  =cut  =cut
44    
45  sub init {  our $orao;
46    
47    select(STDERR); $| = 1;
48    
49    sub boot {
50          my $self = shift;          my $self = shift;
51          warn "call upstream init\n";          warn "Orao calling upstream init\n";
52          $self->SUPER::init( @_ );          $self->SUPER::init(
53                    read => sub { $self->read( @_ ) },
54                    write => sub { $self->write( @_ ) },
55            );
56    
57            warn "Orao $Orao::VERSION emulation starting\n";
58    
59          warn "staring Orao $ORAO::VERSION emulation\n";          warn "emulating ", $#mem, " bytes of memory\n";
60    
61          $self->open_screen;          $self->open_screen;
62          $self->load_rom;          $self->load_rom({
63                    0x1000 => 'dump/SCRINV.BIN',
64                    # should be 0x6000, but oraoemu has 2 byte prefix
65                    0x5FFE => 'dump/screen.dmp',
66    #               0xC000 => 'rom/BAS12.ROM',
67    #               0xE000 => 'rom/CRT12.ROM',
68                    0xC000 => 'rom/BAS13.ROM',
69                    0xE000 => 'rom/CRT13.ROM',
70            });
71    
72    #       $PC = 0xDD11;   # BC
73    #       $PC = 0xC274;   # MC
74    
75            $PC = 0xff89;
76    
77            $orao = $self;
78    
79    #       $self->prompt( 0x1000 );
80    
81            my ( $trace, $debug ) = ( $self->trace, $self->debug );
82            $self->trace( 0 );
83            $self->debug( 0 );
84    
85            $self->render( @mem[ 0x6000 .. 0x7fff ] );
86    
87            if ( $self->show_mem ) {
88    
89                    warn "rendering memory map\n";
90    
91                    $self->render_mem( @mem );
92    
93                    my @mmap = (
94                            0x0000, 0x03FF, 'nulti blok',
95                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
96                            0x6000, 0x7FFF, 'video RAM',
97                            0x8000, 0x9FFF, 'sistemske lokacije',
98                            0xA000, 0xAFFF, 'ekstenzija',
99                            0xB000, 0xBFFF, 'DOS',
100                            0xC000, 0xDFFF, 'BASIC ROM',
101                            0xE000, 0xFFFF, 'sistemski ROM',
102                    );
103    
104            } else {
105    
106                    warn "rendering video memory\n";
107                    $self->render( @mem[ 0x6000 .. 0x7fff ] );
108            
109            }
110            $self->sync;
111            $self->trace( $trace );
112            $self->debug( $debug );
113    
114            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
115    
116            warn "Orao boot finished",
117                    $self->trace ? ' trace' : '',
118                    $self->debug ? ' debug' : '',
119                    "\n";
120    
121            M6502::reset();
122    
123            $self->booted( 1 );
124  }  }
125    
126  my $loaded_files = {  =head2 run
127          0xC000 => 'rom/BAS12.ROM',  
128          0xE000 => 'rom/CRT12.ROM',  Run interactive emulation loop
129    
130      $orao->run;
131    
132    =cut
133    
134    sub run {
135            my $self = shift;
136    
137            $self->boot if ( ! $self->booted );
138            $self->loop;
139  };  };
140    
141    =head1 Helper functions
142    
143  =head2 load_rom  =head2 load_rom
144    
145  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 149  called to init memory and load initial r
149  =cut  =cut
150    
151  sub load_rom {  sub load_rom {
152      my ($self) = @_;      my ($self, $loaded_files) = @_;
153    
154      #my $time_base = time();      #my $time_base = time();
155    
156          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
157                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
158                  printf "loading '%s' at %04x\n", $path, $addr;                  $self->load_image( $path, $addr );
                 $self->load_oraoemu( $path, $addr );  
159          }          }
160  }  }
161    
162    # write chunk directly into memory, updateing vram if needed
163    sub _write_chunk {
164            my $self = shift;
165            my ( $addr, $chunk ) = @_;
166            $self->write_chunk( $addr, $chunk );
167            my $end = $addr + length($chunk);
168            my ( $f, $t ) = ( 0x6000, 0x7fff );
169    
170            if ( $end < $f || $addr >= $t ) {
171                    warn "skip vram update\n";
172                    return;
173            };
174    
175  =head2 load_oraoemu          $f = $addr if ( $addr > $f );
176            $t = $end if ( $end < $t );
177    
178            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
179    #       foreach my $a ( $f .. $t ) {
180    #               $self->vram( $a - 0x6000 , $mem[ $a ] );
181    #       }
182            $self->render( @mem[ 0x6000 .. 0x7fff ] );
183            $self->render_mem( @mem ) if $self->show_mem;
184    }
185    
186    =head2 load_image
187    
188    Load binary files, ROM images and Orao Emulator files
189    
190      $orao->load_image( '/path/to/file', 0x1000 );
191    
192    Returns true on success.
193    
194  =cut  =cut
195    
196  sub load_oraoemu {  sub load_image {
197          my $self = shift;          my $self = shift;
198          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
199    
200          my $size = -s $path || die "no size for $path: $!";          if ( ! -e $path ) {
201                    warn "ERROR: file $path doesn't exist\n";
202                    return;
203            }
204    
205            my $size = -s $path || confess "no size for $path: $!";
206    
207          my $buff = read_file( $path );          my $buff = read_file( $path );
208    
209          if ( $size == 65538 ) {          if ( $size == 65538 ) {
210                  $addr = 0;                  $addr = 0;
211                  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;
212                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
213                  return;                  return 1;
214          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
215                  $addr = 0;                  $addr = 0;
216                  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;
217                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
218                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
219          }          }
220          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;
221          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
222            return 1;
223    
224          my $chunk;          my $chunk;
225    
# Line 113  sub load_oraoemu { Line 235  sub load_oraoemu {
235                  $pos += 4;                  $pos += 4;
236          }          }
237    
238          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
239    
240            return 1;
241  };  };
242    
243  =head2 save_dump  =head2 save_dump
# Line 136  sub save_dump { Line 259  sub save_dump {
259          close($fh);          close($fh);
260    
261          my $size = -s $path;          my $size = -s $path;
262          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
263  }  }
264    
265  =head2 hexdump  =head2 hexdump
# Line 151  sub hexdump { Line 274  sub hexdump {
274          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
275                  join(" ",                  join(" ",
276                          map {                          map {
277                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
278                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
279                                    } else {
280                                            '  '
281                                    }
282                            } @mem[ $a .. $a+8 ]
283                  )                  )
284          );          );
285  }  }
286    
287    =head1 Memory management
288    
289    Orao implements all I/O using mmap addresses. This was main reason why
290    L<Acme::6502> was just too slow to handle it.
291    
292    =cut
293    
294    =head2 read
295    
296    Read from memory
297    
298      $byte = read( $address );
299    
300    =cut
301    
302    my $keyboard_none = 255;
303    
304    my $keyboard = {
305            0x87FC => {
306                    'right'         => 16,
307                    'down'          => 128,
308                    'up'            => 192,
309                    'left'          => 224,
310                    'backspace' => 224,
311            },
312            0x87FD => sub {
313                    my ( $self, $key ) = @_;
314                    if ( $key eq 'return' ) {
315                            M6502::_write( 0xfc, 13 );
316                            warn "return\n";
317                            return 0;
318                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
319                            warn "ctrl\n";
320                            return 16;
321                    }
322                    return $keyboard_none;
323            },
324            0x87FA => {
325                    'f4' => 16,
326                    'f3' => 128,
327                    'f2' => 192,
328                    'f1' => 224,
329            },
330            0x87FB => sub {
331                    my ( $self, $key ) = @_;
332                    if ( $key eq 'space' ) {
333                            return 32;
334                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
335                            warn "shift\n";
336                            return 16;
337                    }
338                    return $keyboard_none;
339            },
340            0x87F6 => {
341                    '6' => 16,
342                    't' => 128,
343                    'y' => 192,     # hr: z
344                    'r' => 224,
345            },
346            0x87F7 => {
347                    '5' => 32,
348                    '4' => 16,
349            },
350            0x87EE => {
351                    '7' => 16,
352                    'u' => 128,
353                    'i' => 192,
354                    'o' => 224,
355            },
356            0x87EF => {
357                    '8' => 32,
358                    '9' => 16,
359            },
360            0x87DE => {
361                    '1' => 16,
362                    'w' => 128,
363                    'q' => 192,
364                    'e' => 224,
365            },
366            0x87DF => {
367                    '2' => 32,
368                    '3' => 16,
369            },
370            0x87BE => {
371                    'm' => 16,
372                    'k' => 128,
373                    'j' => 192,
374                    'l' => 224,
375            },
376            0x87BF => {
377                    ',' => 32,      # <
378                    '.' => 16,      # >
379            },
380            0x877E => {
381                    'z' => 16,      # hr:y
382                    's' => 128,
383                    'a' => 192,
384                    'd' => 224,
385            },
386            0x877F => {
387                    'x' => 32,
388                    'c' => 16,
389            },
390            0x86FE => {
391                    'n' => 16,
392                    'g' => 128,
393                    'h' => 192,
394                    'f' => 224,
395            },
396            0x86FF => {
397                    'b' => 32,
398                    'v' => 16,
399            },
400            0x85FE => {
401                    '<' => 16,              # :
402                    '\\' => 128,    # ľ
403                    '\'' => 192,    # ć
404                    ';' => 224,             # č
405            },
406            0x85FF => {
407                    '/' => 32,
408                    'f11' => 16,    # ^
409            },
410            0x83FE => {
411                    'f12' => 16,    # ;
412                    '[' => 128,             # ą
413                    ']' => 192,             # đ
414                    'p' => 224,
415            },
416            0x83FF => {
417                    '-' => 32,
418                    '0' => 16,
419            },
420    };
421    
422    sub read {
423            my $self = shift;
424            my ($addr) = @_;
425            my $byte = $mem[$addr];
426            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
427            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
428    
429            # keyboard
430    
431            if ( defined( $keyboard->{$addr} ) ) {
432                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
433                    my $key = $self->key_pressed;
434                    if ( defined($key) ) {
435                            my $ret = $keyboard_none;
436                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
437                            if ( ref($r) eq 'CODE' ) {
438                                    $ret = $r->($self, $key);
439                            } elsif ( defined($r->{$key}) ) {
440                                    $ret = $r->{$key};
441                                    if ( ref($ret) eq 'CODE' ) {
442                                            $ret = $ret->($self);
443                                    }
444                            } else {
445                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
446                            }
447                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
448                            return $ret;
449                    }
450                    return $keyboard_none;
451            }
452    
453            $self->mmap_pixel( $addr, 0, $byte, 0 );
454            return $byte;
455    }
456    
457    =head2 write
458    
459    Write into emory
460    
461      write( $address, $byte );
462    
463    =cut
464    
465    sub write {
466            my $self = shift;
467            my ($addr,$byte) = @_;
468            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
469    
470            if ( $addr >= 0x6000 && $addr < 0x8000 ) {
471    #               $self->vram( $addr - 0x6000 , $byte );
472            }
473    
474            if ( $addr == 0x8800 ) {
475                    warn sprintf "sound ignored: %x\n", $byte;
476            }
477    
478            if ( $addr > 0xafff ) {
479                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
480            }
481    
482            $self->mmap_pixel( $addr, $byte, 0, 0 );
483    
484            $mem[$addr] = $byte;
485            return;
486    }
487    
488    =head1 Command Line
489    
490    Command-line debugging intrerface is implemented for communication with
491    emulated device
492    
493  =head2 prompt  =head2 prompt
494    
495    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
496    
497  =cut  =cut
498    
499    my $last = 'r 1';
500    
501  sub prompt {  sub prompt {
502          my $self = shift;          my $self = shift;
503            $self->app->sync;
504          my $a = shift;          my $a = shift;
         my $last = shift;  
505          print $self->hexdump( $a ),          print $self->hexdump( $a ),
506                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
507                  "> ";                  "> ";
508          my $in = <STDIN>;          my $in = <STDIN>;
509          chomp($in);          chomp($in);
510            warn "## prompt got: $in\n" if $self->debug;
511          $in ||= $last;          $in ||= $last;
512          $last = $in;          $last = $in;
513          return split(/\s+/, $in) if $in;          return ( $in, split(/\s+/, $in) ) if $in;
514  }  }
515    
516    =head2 cli
517    
518      $orao->cli();
519    
520    =cut
521    
522    my $show_R = 0;
523    
524    sub cli {
525            my $self = shift;
526            my $a = $PC || confess "no pc?";
527            my $run_for = 0;
528            warn $self->dump_R() if $show_R;
529            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
530                    my $c = shift @v;
531                    next unless defined($c);
532                    my $v = shift @v;
533                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
534                    @v = map { hex($_) } @v;
535                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
536                    if ( $c =~ m/^[qx]/i ) {
537                            exit;
538                    } elsif ( $c eq '?' ) {
539                            my $t = $self->trace ? 'on' : 'off' ;
540                            my $d = $self->debug ? 'on' : 'off' ;
541                            warn <<__USAGE__;
542    Usage:
543    
544    x|q\t\texit
545    e 6000 6010\tdump memory, +/- to walk forward/backward
546    m 1000 ff 00\tput ff 00 on 1000
547    j|u 1000\t\tjump (change pc)
548    r 42\t\trun 42 instruction opcodes
549    t\t\ttrace [$t]
550    d\t\tdebug [$d]
551    
552    __USAGE__
553                            warn $self->dump_R;
554                            $last = '';
555                    } elsif ( $c =~ m/^e/i ) {
556                            $a = $v if defined($v);
557                            my $to = shift @v;
558                            $to = $a + 32 if ( ! $to || $to <= $a );
559                            $to = 0xffff if ( $to > 0xffff );
560                            my $lines = int( ($to - $a + 8) / 8 );
561                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
562                            while ( --$lines ) {
563                                    print $self->hexdump( $a );
564                                    $a += 8;
565                            }
566                            $last = '+';
567                            $show_R = 0;
568                    } elsif ( $c =~ m/^\+/ ) {
569                            $a += 8;
570                            $show_R = 0;
571                    } elsif ( $c =~ m/^\-/ ) {
572                            $a -= 8;
573                            $show_R = 0;
574                    } elsif ( $c =~ m/^m/i ) {
575                            $a = $v if defined($v);
576                            $self->poke_code( $a, @v );
577                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
578                            $last = '+';
579                            $show_R = 0;
580                    } elsif ( $c =~ m/^l/i ) {
581                            my $to = shift @v || 0x1000;
582                            $a = $to;
583                            $self->load_image( $v, $a );
584                            $last = '';
585                    } elsif ( $c =~ m/^s/i ) {
586                            $self->save_dump( $v || 'mem.dump', @v );
587                            $last = '';
588                    } elsif ( $c =~ m/^r/i ) {
589                            $run_for = $v || 1;
590                            print "run_for $run_for instructions\n";
591                            $show_R = 1;
592                            last;
593                    } elsif ( $c =~ m/^(u|j)/ ) {
594                            my $to = $v || $a;
595                            printf "set pc to %04x\n", $to;
596                            $PC = $to;      # remember for restart
597                            $run_for = 1;
598                            $last = "r $run_for";
599                            $show_R = 1;
600                            last;
601                    } elsif ( $c =~ m/^t/ ) {
602                            $self->trace( not $self->trace );
603                            print "trace ", $self->trace ? 'on' : 'off', "\n";
604                            $last = '';
605                    } elsif ( $c =~ m/^d/ ) {
606                            $self->debug( not $self->debug );
607                            print "debug ", $self->debug ? 'on' : 'off', "\n";
608                            $last = '';
609                    } else {
610                            warn "# ignored $line\n" if ($line);
611                            $last = '';
612                    }
613            }
614    
615            return $run_for;
616    }
617    
618  =head1 AUTHOR  =head1 AUTHOR
619    
Legend:
Removed from v.30  
changed lines
  Added in v.106
  ViewVC Help
Powered by ViewVC 1.1.26