/[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 107 by dpavlin, Fri Aug 3 08:57:37 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            warn "rendering video memory\n";
86            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
87    
88            if ( $self->show_mem ) {
89    
90                    warn "rendering memory map\n";
91    
92                    $self->render_mem( @mem );
93    
94                    my @mmap = (
95                            0x0000, 0x03FF, 'nulti blok',
96                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
97                            0x6000, 0x7FFF, 'video RAM',
98                            0x8000, 0x9FFF, 'sistemske lokacije',
99                            0xA000, 0xAFFF, 'ekstenzija',
100                            0xB000, 0xBFFF, 'DOS',
101                            0xC000, 0xDFFF, 'BASIC ROM',
102                            0xE000, 0xFFFF, 'sistemski ROM',
103                    );
104    
         my @mmap = (  
                 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',  
         );  
   
         foreach my $i ( 0 .. $#mmap / 3 ) {  
                 my $o = $i * 3;  
                 my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];  
                 printf "%04x - %04x - %s\n", $from, $to, $desc;  
                 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;  
105          }          }
106            $self->sync;
107            $self->trace( $trace );
108            $self->debug( $debug );
109    
110            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
111    
112            warn "Orao boot finished",
113                    $self->trace ? ' trace' : '',
114                    $self->debug ? ' debug' : '',
115                    "\n";
116    
117          warn "Orao init finished\n";          M6502::reset();
118    
119            $self->booted( 1 );
120  }  }
121    
122    =head2 run
123    
124    Run interactive emulation loop
125    
126      $orao->run;
127    
128    =cut
129    
130    sub run {
131            my $self = shift;
132    
133            $self->boot if ( ! $self->booted );
134            $self->loop;
135    };
136    
137    =head1 Helper functions
138    
139  =head2 load_rom  =head2 load_rom
140    
141  called to init memory and load initial rom images  called to init memory and load initial rom images
# Line 108  sub load_rom { Line 151  sub load_rom {
151    
152          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
153                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
154                  $self->load_oraoemu( $path, $addr );                  $self->load_image( $path, $addr );
155          }          }
156  }  }
157    
158    # write chunk directly into memory, updateing vram if needed
159    sub _write_chunk {
160            my $self = shift;
161            my ( $addr, $chunk ) = @_;
162            $self->write_chunk( $addr, $chunk );
163            my $end = $addr + length($chunk);
164            my ( $f, $t ) = ( 0x6000, 0x7fff );
165    
166  =head2 load_oraoemu          if ( $end < $f || $addr >= $t ) {
167                    warn "skip vram update\n";
168                    return;
169            };
170    
171            $f = $addr if ( $addr > $f );
172            $t = $end if ( $end < $t );
173    
174            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
175            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
176            $self->render_mem( @mem ) if $self->show_mem;
177    }
178    
179    =head2 load_image
180    
181    Load binary files, ROM images and Orao Emulator files
182    
183      $orao->load_image( '/path/to/file', 0x1000 );
184    
185    Returns true on success.
186    
187  =cut  =cut
188    
189  sub load_oraoemu {  sub load_image {
190          my $self = shift;          my $self = shift;
191          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
192    
193            if ( ! -e $path ) {
194                    warn "ERROR: file $path doesn't exist\n";
195                    return;
196            }
197    
198          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
199    
200          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 128  sub load_oraoemu { Line 202  sub load_oraoemu {
202          if ( $size == 65538 ) {          if ( $size == 65538 ) {
203                  $addr = 0;                  $addr = 0;
204                  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;
205                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
206                  return;                  return 1;
207          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
208                  $addr = 0;                  $addr = 0;
209                  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;
210                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
211                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
212          }          }
213          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;
214          return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );          $self->_write_chunk( $addr, $buff );
215          return $self->write_chunk( $addr, $buff );          return 1;
216    
217          my $chunk;          my $chunk;
218    
# Line 155  sub load_oraoemu { Line 228  sub load_oraoemu {
228                  $pos += 4;                  $pos += 4;
229          }          }
230    
231          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
232    
233            return 1;
234  };  };
235    
236  =head2 save_dump  =head2 save_dump
# Line 193  sub hexdump { Line 267  sub hexdump {
267          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
268                  join(" ",                  join(" ",
269                          map {                          map {
270                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
271                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
272                                    } else {
273                                            '  '
274                                    }
275                            } @mem[ $a .. $a+8 ]
276                  )                  )
277          );          );
278  }  }
279    
 =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;  
 }  
   
280  =head1 Memory management  =head1 Memory management
281    
282  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 292  Read from memory
292    
293  =cut  =cut
294    
295    my $keyboard_none = 255;
296    
297    my $keyboard = {
298            0x87FC => {
299                    'right'         => 16,
300                    'down'          => 128,
301                    'up'            => 192,
302                    'left'          => 224,
303                    'backspace' => 224,
304            },
305            0x87FD => sub {
306                    my ( $self, $key ) = @_;
307                    if ( $key eq 'return' ) {
308                            M6502::_write( 0xfc, 13 );
309                            warn "return\n";
310                            return 0;
311                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
312                            warn "ctrl\n";
313                            return 16;
314                    }
315                    return $keyboard_none;
316            },
317            0x87FA => {
318                    'f4' => 16,
319                    'f3' => 128,
320                    'f2' => 192,
321                    'f1' => 224,
322            },
323            0x87FB => sub {
324                    my ( $self, $key ) = @_;
325                    if ( $key eq 'space' ) {
326                            return 32;
327                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
328                            warn "shift\n";
329                            return 16;
330                    }
331                    return $keyboard_none;
332            },
333            0x87F6 => {
334                    '6' => 16,
335                    't' => 128,
336                    'y' => 192,     # hr: z
337                    'r' => 224,
338            },
339            0x87F7 => {
340                    '5' => 32,
341                    '4' => 16,
342            },
343            0x87EE => {
344                    '7' => 16,
345                    'u' => 128,
346                    'i' => 192,
347                    'o' => 224,
348            },
349            0x87EF => {
350                    '8' => 32,
351                    '9' => 16,
352            },
353            0x87DE => {
354                    '1' => 16,
355                    'w' => 128,
356                    'q' => 192,
357                    'e' => 224,
358            },
359            0x87DF => {
360                    '2' => 32,
361                    '3' => 16,
362            },
363            0x87BE => {
364                    'm' => 16,
365                    'k' => 128,
366                    'j' => 192,
367                    'l' => 224,
368            },
369            0x87BF => {
370                    ',' => 32,      # <
371                    '.' => 16,      # >
372            },
373            0x877E => {
374                    'z' => 16,      # hr:y
375                    's' => 128,
376                    'a' => 192,
377                    'd' => 224,
378            },
379            0x877F => {
380                    'x' => 32,
381                    'c' => 16,
382            },
383            0x86FE => {
384                    'n' => 16,
385                    'g' => 128,
386                    'h' => 192,
387                    'f' => 224,
388            },
389            0x86FF => {
390                    'b' => 32,
391                    'v' => 16,
392            },
393            0x85FE => {
394                    '<' => 16,              # :
395                    '\\' => 128,    # ľ
396                    '\'' => 192,    # ć
397                    ';' => 224,             # č
398            },
399            0x85FF => {
400                    '/' => 32,
401                    'f11' => 16,    # ^
402            },
403            0x83FE => {
404                    'f12' => 16,    # ;
405                    '[' => 128,             # ą
406                    ']' => 192,             # đ
407                    'p' => 224,
408            },
409            0x83FF => {
410                    '-' => 32,
411                    '0' => 16,
412            },
413    };
414    
415  sub read {  sub read {
416          my $self = shift;          my $self = shift;
417          my ($addr) = @_;          my ($addr) = @_;
418          my $byte = $mem[$addr];          my $byte = $mem[$addr];
419          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
420            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
421    
422            # keyboard
423    
424            if ( defined( $keyboard->{$addr} ) ) {
425                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
426                    my $key = $self->key_pressed;
427                    if ( defined($key) ) {
428                            my $ret = $keyboard_none;
429                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
430                            if ( ref($r) eq 'CODE' ) {
431                                    $ret = $r->($self, $key);
432                            } elsif ( defined($r->{$key}) ) {
433                                    $ret = $r->{$key};
434                                    if ( ref($ret) eq 'CODE' ) {
435                                            $ret = $ret->($self);
436                                    }
437                            } else {
438                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
439                            }
440                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
441                            return $ret;
442                    }
443                    return $keyboard_none;
444            }
445    
446          $self->mmap_pixel( $addr, 0, $byte, 0 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
447          return $byte;          return $byte;
448  }  }
# Line 253  Write into emory Line 457  Write into emory
457    
458  sub write {  sub write {
459          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
460          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
461            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
462    
463          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr == 0x8800 ) {
464                  $self->vram( $addr - 0x6000 , $byte );                  warn sprintf "sound ignored: %x\n", $byte;
465          }          }
466    
467          if ( $addr > 0xafff ) {          if ( $addr > 0xafff ) {
468                  warn sprintf "access to %04x above affff aborting\n", $addr;                  confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
                 return -1;  
         }  
         if ( $addr == 0x8800 ) {  
                 warn sprintf "sound ignored: %x\n", $byte;  
469          }          }
470    
471          $self->mmap_pixel( $addr, $byte, 0, 0 );          $self->mmap_pixel( $addr, $byte, 0, 0 );
# Line 274  sub write { Line 474  sub write {
474          return;          return;
475  }  }
476    
477    =head1 Command Line
478    
479    Command-line debugging intrerface is implemented for communication with
480    emulated device
481    
482    =head2 prompt
483    
484      my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
485    
486    =cut
487    
488    my $last = 'r 1';
489    
490    sub prompt {
491            my $self = shift;
492            $self->app->sync;
493            my $a = shift;
494            print $self->hexdump( $a ),
495                    $last ? "[$last] " : '',
496                    "> ";
497            my $in = <STDIN>;
498            chomp($in);
499            warn "## prompt got: $in\n" if $self->debug;
500            $in ||= $last;
501            $last = $in;
502            return ( $in, split(/\s+/, $in) ) if $in;
503    }
504    
505    =head2 cli
506    
507      $orao->cli();
508    
509    =cut
510    
511    my $show_R = 0;
512    
513    sub cli {
514            my $self = shift;
515            my $a = $PC || confess "no pc?";
516            my $run_for = 0;
517            warn $self->dump_R() if $show_R;
518            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
519                    my $c = shift @v;
520                    next unless defined($c);
521                    my $v = shift @v;
522                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
523                    @v = map { hex($_) } @v;
524                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
525                    if ( $c =~ m/^[qx]/i ) {
526                            exit;
527                    } elsif ( $c eq '?' ) {
528                            my $t = $self->trace ? 'on' : 'off' ;
529                            my $d = $self->debug ? 'on' : 'off' ;
530                            warn <<__USAGE__;
531    Usage:
532    
533    x|q\t\texit
534    e 6000 6010\tdump memory, +/- to walk forward/backward
535    m 1000 ff 00\tput ff 00 on 1000
536    j|u 1000\t\tjump (change pc)
537    r 42\t\trun 42 instruction opcodes
538    t\t\ttrace [$t]
539    d\t\tdebug [$d]
540    
541    __USAGE__
542                            warn $self->dump_R;
543                            $last = '';
544                    } elsif ( $c =~ m/^e/i ) {
545                            $a = $v if defined($v);
546                            my $to = shift @v;
547                            $to = $a + 32 if ( ! $to || $to <= $a );
548                            $to = 0xffff if ( $to > 0xffff );
549                            my $lines = int( ($to - $a + 8) / 8 );
550                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
551                            while ( --$lines ) {
552                                    print $self->hexdump( $a );
553                                    $a += 8;
554                            }
555                            $last = '+';
556                            $show_R = 0;
557                    } elsif ( $c =~ m/^\+/ ) {
558                            $a += 8;
559                            $show_R = 0;
560                    } elsif ( $c =~ m/^\-/ ) {
561                            $a -= 8;
562                            $show_R = 0;
563                    } elsif ( $c =~ m/^m/i ) {
564                            $a = $v if defined($v);
565                            $self->poke_code( $a, @v );
566                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
567                            $last = '+';
568                            $show_R = 0;
569                    } elsif ( $c =~ m/^l/i ) {
570                            my $to = shift @v || 0x1000;
571                            $a = $to;
572                            $self->load_image( $v, $a );
573                            $last = '';
574                    } elsif ( $c =~ m/^s/i ) {
575                            $self->save_dump( $v || 'mem.dump', @v );
576                            $last = '';
577                    } elsif ( $c =~ m/^r/i ) {
578                            $run_for = $v || 1;
579                            print "run_for $run_for instructions\n";
580                            $show_R = 1;
581                            last;
582                    } elsif ( $c =~ m/^(u|j)/ ) {
583                            my $to = $v || $a;
584                            printf "set pc to %04x\n", $to;
585                            $PC = $to;      # remember for restart
586                            $run_for = 1;
587                            $last = "r $run_for";
588                            $show_R = 1;
589                            last;
590                    } elsif ( $c =~ m/^t/ ) {
591                            $self->trace( not $self->trace );
592                            print "trace ", $self->trace ? 'on' : 'off', "\n";
593                            $last = '';
594                    } elsif ( $c =~ m/^d/ ) {
595                            $self->debug( not $self->debug );
596                            print "debug ", $self->debug ? 'on' : 'off', "\n";
597                            $last = '';
598                    } else {
599                            warn "# ignored $line\n" if ($line);
600                            $last = '';
601                    }
602            }
603    
604            return $run_for;
605    }
606    
607  =head1 AUTHOR  =head1 AUTHOR
608    
Legend:
Removed from v.36  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.26