/[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 36 by dpavlin, Mon Jul 30 22:06: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/;  use Data::Dump qw/dump/;
11  use M6502;  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 19  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 31  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  our $orao;  our $orao;
46    
47  sub init {  select(STDERR); $| = 1;
48    
49    sub boot {
50          my $self = shift;          my $self = shift;
51          warn "Orao calling upstream init\n";          warn "Orao calling upstream init\n";
52          $self->SUPER::init( $self, @_ );          $self->SUPER::init(
53                    read => sub { $self->read( @_ ) },
54                    write => sub { $self->write( @_ ) },
55            );
56    
57          warn "staring Orao $Orao::VERSION emulation\n";          warn "Orao $Orao::VERSION emulation starting\n";
58    
59            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',                  0x1000 => 'dump/SCRINV.BIN',
64                  0xC000 => 'rom/BAS12.ROM',                  # should be 0x6000, but oraoemu has 2 byte prefix
65                  0xE000 => 'rom/CRT12.ROM',                  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          $self->load_oraoemu( 'dump/orao-1.2' );  #       $PC = 0xDD11;   # BC
73          $self->load_oraoemu( 'dump/SCRINV.BIN' );  #       $PC = 0xC274;   # MC
74          $PC = 0x1000;  
75            $PC = 0xff89;
76    
77          $orao = $self;          $orao = $self;
78    
79  #       $self->prompt( 0x1000 );  #       $self->prompt( 0x1000 );
80    
81          warn "rendering memory map\n";          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          my @mmap = (          #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
                 0x0000, 0x03FF, 'nulti blok',  
                 0x0400, 0x5FFF, 'korisnički RAM (23K)',  
                 0x6000, 0x7FFF, 'video RAM',  
                 0x8000, 0x9FFF, 'sistemske lokacije',  
                 0xA000, 0xAFFF, 'ekstenzija',  
                 0xB000, 0xBFFF, 'DOS',  
                 0xC000, 0xDFFF, 'BASIC ROM',  
                 0xE000, 0xFFFF, 'sistemski ROM',  
         );  
115    
116          foreach my $i ( 0 .. $#mmap / 3 ) {          warn "Orao boot finished",
117                  my $o = $i * 3;                  $self->trace ? ' trace' : '',
118                  my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];                  $self->debug ? ' debug' : '',
119                  printf "%04x - %04x - %s\n", $from, $to, $desc;                  "\n";
                 for my $a ( $from .. $to ) {  
                         if ( $a >= 0x6000 && $a < 0x8000 ) {  
                                 my $b = $orao->read( $a );  
                                 $orao->vram( $a - 0x6000, $b );  
                         } else {  
                                 $orao->read( $a );  
                         }  
                 }  
                 $self->sync;  
         }  
120    
121          warn "Orao init finished\n";          M6502::reset();
122    
123            $self->booted( 1 );
124  }  }
125    
126    =head2 run
127    
128    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 108  sub load_rom { Line 155  sub load_rom {
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                  $self->load_oraoemu( $path, $addr );                  $self->load_image( $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            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: $!";          my $size = -s $path || confess "no size for $path: $!";
206    
207          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 128  sub load_oraoemu { Line 209  sub load_oraoemu {
209          if ( $size == 65538 ) {          if ( $size == 65538 ) {
210                  $addr = 0;                  $addr = 0;
211                  warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $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                  warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $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-1, $size;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
221          return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );          $self->_write_chunk( $addr, $buff );
222          return $self->write_chunk( $addr, $buff );          return 1;
223    
224          my $chunk;          my $chunk;
225    
# Line 155  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 193  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    
 =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;  
 }  
   
287  =head1 Memory management  =head1 Memory management
288    
289  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 234  Read from memory Line 299  Read from memory
299    
300  =cut  =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 {  sub read {
423          my $self = shift;          my $self = shift;
424          my ($addr) = @_;          my ($addr) = @_;
425          my $byte = $mem[$addr];          my $byte = $mem[$addr];
426          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          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 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
454          return $byte;          return $byte;
455  }  }
# Line 253  Write into emory Line 464  Write into emory
464    
465  sub write {  sub write {
466          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
467          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
468            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
469    
470          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr >= 0x6000 && $addr < 0x8000 ) {
471                  $self->vram( $addr - 0x6000 , $byte );  #               $self->vram( $addr - 0x6000 , $byte );
472          }          }
473    
         if ( $addr > 0xafff ) {  
                 warn sprintf "access to %04x above affff aborting\n", $addr;  
                 return -1;  
         }  
474          if ( $addr == 0x8800 ) {          if ( $addr == 0x8800 ) {
475                  warn sprintf "sound ignored: %x\n", $byte;                  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 );          $self->mmap_pixel( $addr, $byte, 0, 0 );
483    
484          $mem[$addr] = $byte;          $mem[$addr] = $byte;
485          return;          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
494    
495      my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
496    
497    =cut
498    
499    my $last = 'r 1';
500    
501    sub prompt {
502            my $self = shift;
503            $self->app->sync;
504            my $a = shift;
505            print $self->hexdump( $a ),
506                    $last ? "[$last] " : '',
507                    "> ";
508            my $in = <STDIN>;
509            chomp($in);
510            warn "## prompt got: $in\n" if $self->debug;
511            $in ||= $last;
512            $last = $in;
513            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.36  
changed lines
  Added in v.106
  ViewVC Help
Powered by ViewVC 1.1.26