/[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 35 by dpavlin, Mon Jul 30 21:53:04 2007 UTC revision 110 by dpavlin, Fri Aug 3 12:21:47 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 Tape);
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 ) {  
                         $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 init finished\n";          warn "Orao boot finished",
113                    $self->trace ? ' trace' : '',
114                    $self->debug ? ' debug' : '',
115                    "\n";
116    
117            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    
135            $self->load_tape( '../oraoigre/bdash.tap' );
136    
137            $self->loop;
138    };
139    
140    =head1 Helper functions
141    
142  =head2 load_rom  =head2 load_rom
143    
144  called to init memory and load initial rom images  called to init memory and load initial rom images
# Line 103  sub load_rom { Line 154  sub load_rom {
154    
155          foreach my $addr ( sort keys %$loaded_files ) {          foreach my $addr ( sort keys %$loaded_files ) {
156                  my $path = $loaded_files->{$addr};                  my $path = $loaded_files->{$addr};
157                  $self->load_oraoemu( $path, $addr );                  $self->load_image( $path, $addr );
158          }          }
159  }  }
160    
161    # write chunk directly into memory, updateing vram if needed
162    sub _write_chunk {
163            my $self = shift;
164            my ( $addr, $chunk ) = @_;
165            $self->write_chunk( $addr, $chunk );
166            my $end = $addr + length($chunk);
167            my ( $f, $t ) = ( 0x6000, 0x7fff );
168    
169  =head2 load_oraoemu          if ( $end < $f || $addr >= $t ) {
170                    warn "skip vram update\n";
171                    return;
172            };
173    
174            $f = $addr if ( $addr > $f );
175            $t = $end if ( $end < $t );
176    
177            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
178            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
179            $self->render_mem( @mem ) if $self->show_mem;
180    }
181    
182    =head2 load_image
183    
184    Load binary files, ROM images and Orao Emulator files
185    
186      $orao->load_image( '/path/to/file', 0x1000 );
187    
188    Returns true on success.
189    
190  =cut  =cut
191    
192  sub load_oraoemu {  sub load_image {
193          my $self = shift;          my $self = shift;
194          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
195    
196            if ( ! -e $path ) {
197                    warn "ERROR: file $path doesn't exist\n";
198                    return;
199            }
200    
201          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
202    
203          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 123  sub load_oraoemu { Line 205  sub load_oraoemu {
205          if ( $size == 65538 ) {          if ( $size == 65538 ) {
206                  $addr = 0;                  $addr = 0;
207                  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;
208                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
209                  return;                  return 1;
210          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
211                  $addr = 0;                  $addr = 0;
212                  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;
213                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
214                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
215          }          }
216          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;
217          return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );          $self->_write_chunk( $addr, $buff );
218          return $self->write_chunk( $addr, $buff );          return 1;
219    
220          my $chunk;          my $chunk;
221    
# Line 150  sub load_oraoemu { Line 231  sub load_oraoemu {
231                  $pos += 4;                  $pos += 4;
232          }          }
233    
234          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
235    
236            return 1;
237  };  };
238    
239  =head2 save_dump  =head2 save_dump
# Line 188  sub hexdump { Line 270  sub hexdump {
270          return sprintf(" %04x %s\n", $a,          return sprintf(" %04x %s\n", $a,
271                  join(" ",                  join(" ",
272                          map {                          map {
273                                  sprintf( "%02x", $_ )                                  if ( defined($_) ) {
274                          } $self->ram( $a, $a+8 )                                          sprintf( "%02x", $_ )
275                                    } else {
276                                            '  '
277                                    }
278                            } @mem[ $a .. $a+8 ]
279                  )                  )
280          );          );
281  }  }
282    
 =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;  
 }  
   
283  =head1 Memory management  =head1 Memory management
284    
285  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 229  Read from memory Line 295  Read from memory
295    
296  =cut  =cut
297    
298    my $keyboard_none = 255;
299    
300    my $keyboard = {
301            0x87FC => {
302                    'right'         => 16,
303                    'down'          => 128,
304                    'up'            => 192,
305                    'left'          => 224,
306                    'backspace' => 224,
307            },
308            0x87FD => sub {
309                    my ( $self, $key ) = @_;
310                    if ( $key eq 'return' ) {
311                            M6502::_write( 0xfc, 13 );
312                            warn "return\n";
313                            return 0;
314                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
315                            warn "ctrl\n";
316                            return 16;
317                    }
318                    return $keyboard_none;
319            },
320            0x87FA => {
321                    'f4' => 16,
322                    'f3' => 128,
323                    'f2' => 192,
324                    'f1' => 224,
325            },
326            0x87FB => sub {
327                    my ( $self, $key ) = @_;
328                    if ( $key eq 'space' ) {
329                            return 32;
330                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
331                            warn "shift\n";
332                            return 16;
333    #               } elsif ( $self->tape ) {
334    #                       warn "has tape!";
335    #                       return 0;
336                    }
337                    return $keyboard_none;
338            },
339            0x87F6 => {
340                    '6' => 16,
341                    't' => 128,
342                    'y' => 192,     # hr: z
343                    'r' => 224,
344            },
345            0x87F7 => {
346                    '5' => 32,
347                    '4' => 16,
348            },
349            0x87EE => {
350                    '7' => 16,
351                    'u' => 128,
352                    'i' => 192,
353                    'o' => 224,
354            },
355            0x87EF => {
356                    '8' => 32,
357                    '9' => 16,
358            },
359            0x87DE => {
360                    '1' => 16,
361                    'w' => 128,
362                    'q' => 192,
363                    'e' => 224,
364            },
365            0x87DF => {
366                    '2' => 32,
367                    '3' => 16,
368            },
369            0x87BE => {
370                    'm' => 16,
371                    'k' => 128,
372                    'j' => 192,
373                    'l' => 224,
374            },
375            0x87BF => {
376                    ',' => 32,      # <
377                    '.' => 16,      # >
378            },
379            0x877E => {
380                    'z' => 16,      # hr:y
381                    's' => 128,
382                    'a' => 192,
383                    'd' => 224,
384            },
385            0x877F => {
386                    'x' => 32,
387                    'c' => 16,
388            },
389            0x86FE => {
390                    'n' => 16,
391                    'g' => 128,
392                    'h' => 192,
393                    'f' => 224,
394            },
395            0x86FF => {
396                    'b' => 32,
397                    'v' => 16,
398            },
399            0x85FE => {
400                    '<' => 16,              # :
401                    '\\' => 128,    # ľ
402                    '\'' => 192,    # ć
403                    ';' => 224,             # č
404            },
405            0x85FF => {
406                    '/' => 32,
407                    'f11' => 16,    # ^
408            },
409            0x83FE => {
410                    'f12' => 16,    # ;
411                    '[' => 128,             # ą
412                    ']' => 192,             # đ
413                    'p' => 224,
414            },
415            0x83FF => {
416                    '-' => 32,
417                    '0' => 16,
418            },
419    };
420    
421  sub read {  sub read {
422          my $self = shift;          my $self = shift;
423          my ($addr) = @_;          my ($addr) = @_;
424          my $byte = $mem[$addr];          my $byte = $mem[$addr];
425          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
426            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
427    
428            # keyboard
429    
430            if ( defined( $keyboard->{$addr} ) ) {
431                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
432                    my $key = $self->key_pressed;
433                    if ( defined($key) ) {
434                            my $ret = $keyboard_none;
435                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
436                            if ( ref($r) eq 'CODE' ) {
437                                    $ret = $r->($self, $key);
438                            } elsif ( defined($r->{$key}) ) {
439                                    $ret = $r->{$key};
440                                    if ( ref($ret) eq 'CODE' ) {
441                                            $ret = $ret->($self);
442                                    }
443                            } else {
444                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
445                            }
446                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
447                            return $ret;
448                    }
449                    return $keyboard_none;
450            }
451    
452            if ( $addr == 0x87ff ) {
453                    return $self->read_tape;
454            }
455    
456          $self->mmap_pixel( $addr, 0, $byte, 0 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
457          return $byte;          return $byte;
458  }  }
# Line 248  Write into emory Line 467  Write into emory
467    
468  sub write {  sub write {
469          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
470          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
471            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
472    
473          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr == 0x8800 ) {
474                  $self->vram( $addr - 0x6000 , $byte );                  warn sprintf "sound ignored: %x\n", $byte;
475          }          }
476    
477          if ( $addr > 0xafff ) {          if ( $addr > 0xafff ) {
478                  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;  
479          }          }
480    
481          $self->mmap_pixel( $addr, $byte, 0, 0 );          $self->mmap_pixel( $addr, $byte, 0, 0 );
482    
483          $mem[$addr] = $byte;          $mem[$addr] = $byte;
484            return;
485    }
486    
487    =head1 Command Line
488    
489    Command-line debugging intrerface is implemented for communication with
490    emulated device
491    
492    =head2 prompt
493    
494      my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
495    
496    =cut
497    
498    my $last = 'r 1';
499    
500    sub prompt {
501            my $self = shift;
502            $self->app->sync;
503            my $a = shift;
504            print $self->hexdump( $a ),
505                    $last ? "[$last] " : '',
506                    "> ";
507            my $in = <STDIN>;
508            chomp($in);
509            warn "## prompt got: $in\n" if $self->debug;
510            $in ||= $last;
511            $last = $in;
512            return ( $in, split(/\s+/, $in) ) if $in;
513  }  }
514    
515    =head2 cli
516    
517      $orao->cli();
518    
519    =cut
520    
521    my $show_R = 0;
522    
523    sub cli {
524            my $self = shift;
525            my $a = $PC || confess "no pc?";
526            my $run_for = 0;
527            warn $self->dump_R() if $show_R;
528            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
529                    my $c = shift @v;
530                    next unless defined($c);
531                    my $v = shift @v;
532                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
533                    @v = map { hex($_) } @v;
534                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
535                    if ( $c =~ m/^[qx]/i ) {
536                            exit;
537                    } elsif ( $c eq '?' ) {
538                            my $t = $self->trace ? 'on' : 'off' ;
539                            my $d = $self->debug ? 'on' : 'off' ;
540                            warn <<__USAGE__;
541    Usage:
542    
543    x|q\t\texit
544    e 6000 6010\tdump memory, +/- to walk forward/backward
545    m 1000 ff 00\tput ff 00 on 1000
546    j|u 1000\t\tjump (change pc)
547    r 42\t\trun 42 instruction opcodes
548    t\t\ttrace [$t]
549    d\t\tdebug [$d]
550    
551    __USAGE__
552                            warn $self->dump_R;
553                            $last = '';
554                    } elsif ( $c =~ m/^e/i ) {
555                            $a = $v if defined($v);
556                            my $to = shift @v;
557                            $to = $a + 32 if ( ! $to || $to <= $a );
558                            $to = 0xffff if ( $to > 0xffff );
559                            my $lines = int( ($to - $a + 8) / 8 );
560                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
561                            while ( --$lines ) {
562                                    print $self->hexdump( $a );
563                                    $a += 8;
564                            }
565                            $last = '+';
566                            $show_R = 0;
567                    } elsif ( $c =~ m/^\+/ ) {
568                            $a += 8;
569                            $show_R = 0;
570                    } elsif ( $c =~ m/^\-/ ) {
571                            $a -= 8;
572                            $show_R = 0;
573                    } elsif ( $c =~ m/^m/i ) {
574                            $a = $v if defined($v);
575                            $self->poke_code( $a, @v );
576                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
577                            $last = '+';
578                            $show_R = 0;
579                    } elsif ( $c =~ m/^l/i ) {
580                            my $to = shift @v || 0x1000;
581                            $a = $to;
582                            $self->load_image( $v, $a );
583                            $last = '';
584                    } elsif ( $c =~ m/^s/i ) {
585                            $self->save_dump( $v || 'mem.dump', @v );
586                            $last = '';
587                    } elsif ( $c =~ m/^re/i ) { # reset
588                            M6502::reset();
589                            $last = 'r 1';
590                    } elsif ( $c =~ m/^r/i ) {      # run
591                            $run_for = $v || 1;
592                            print "run_for $run_for instructions\n";
593                            $show_R = 1;
594                            last;
595                    } elsif ( $c =~ m/^(u|j)/i ) {
596                            my $to = $v || $a;
597                            printf "set pc to %04x\n", $to;
598                            $PC = $to;      # remember for restart
599                            $run_for = 1;
600                            $last = "r $run_for";
601                            $show_R = 1;
602                            last;
603                    } elsif ( $c =~ m/^tape/ ) {
604                            if ( $c =~ m/rate/ ) {
605                                    $self->tape_rate( $v );
606                                    warn "will read table with rate $v\n";
607                            } elsif ( ! $v ) {
608                                    warn "ERROR: please specify tape name!\n";
609                            } elsif ( ! -e $v ) {
610                                    warn "ERROR: tape $v: $!\n";
611                            } else {
612                                    $self->load_tape( $v );
613                            }
614                            $last = '';
615                    } elsif ( $c =~ m/^t/i ) {
616                            $self->trace( not $self->trace );
617                            print "trace ", $self->trace ? 'on' : 'off', "\n";
618                            $last = '';
619                    } elsif ( $c =~ m/^d/i ) {
620                            $self->debug( not $self->debug );
621                            print "debug ", $self->debug ? 'on' : 'off', "\n";
622                            $last = '';
623                    } else {
624                            warn "# ignored $line\n" if ($line);
625                            $last = '';
626                    }
627            }
628    
629            return $run_for;
630    }
631    
632  =head1 AUTHOR  =head1 AUTHOR
633    
Legend:
Removed from v.35  
changed lines
  Added in v.110
  ViewVC Help
Powered by ViewVC 1.1.26