/[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 31 by dpavlin, Mon Jul 30 18:07:29 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/;
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 "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',
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            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    
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            M6502::reset();
118    
119            $self->booted( 1 );
120  }  }
121    
122  my $loaded_files = {  =head2 run
123          0xC000 => 'rom/BAS12.ROM',  
124          0xE000 => 'rom/CRT12.ROM',  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 60  called to init memory and load initial r Line 145  called to init memory and load initial r
145  =cut  =cut
146    
147  sub load_rom {  sub load_rom {
148      my ($self) = @_;      my ($self, $loaded_files) = @_;
149    
150      #my $time_base = time();      #my $time_base = time();
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                  printf "loading '%s' at %04x\n", $path, $addr;                  $self->load_image( $path, $addr );
                 $self->load_oraoemu( $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            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  =head2 load_oraoemu  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 );
201    
202          if ( $size == 65538 ) {          if ( $size == 65538 ) {
203                  $addr = 0;                  $addr = 0;
204                  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;
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                  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;
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, $size;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
214          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
215            return 1;
216    
217          my $chunk;          my $chunk;
218    
# Line 113  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 136  sub save_dump { Line 252  sub save_dump {
252          close($fh);          close($fh);
253    
254          my $size = -s $path;          my $size = -s $path;
255          printf "saved %s %d %x bytes\n", $path, $size, $size;          warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
256  }  }
257    
258  =head2 hexdump  =head2 hexdump
# Line 151  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    
280    =head1 Memory management
281    
282    Orao implements all I/O using mmap addresses. This was main reason why
283    L<Acme::6502> was just too slow to handle it.
284    
285    =cut
286    
287    =head2 read
288    
289    Read from memory
290    
291      $byte = read( $address );
292    
293    =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 {
416            my $self = shift;
417            my ($addr) = @_;
418            my $byte = $mem[$addr];
419            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 );
447            return $byte;
448    }
449    
450    =head2 write
451    
452    Write into emory
453    
454      write( $address, $byte );
455    
456    =cut
457    
458    sub write {
459            my $self = shift;
460            my ($addr,$byte) = @_;
461            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
462    
463            if ( $addr == 0x8800 ) {
464                    warn sprintf "sound ignored: %x\n", $byte;
465            }
466    
467            if ( $addr > 0xafff ) {
468                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
469            }
470    
471            $self->mmap_pixel( $addr, $byte, 0, 0 );
472    
473            $mem[$addr] = $byte;
474            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  =head2 prompt
483    
484    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
485    
486  =cut  =cut
487    
488    my $last = 'r 1';
489    
490  sub prompt {  sub prompt {
491          my $self = shift;          my $self = shift;
492            $self->app->sync;
493          my $a = shift;          my $a = shift;
         my $last = shift;  
494          print $self->hexdump( $a ),          print $self->hexdump( $a ),
495                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
496                  "> ";                  "> ";
497          my $in = <STDIN>;          my $in = <STDIN>;
498          chomp($in);          chomp($in);
499            warn "## prompt got: $in\n" if $self->debug;
500          $in ||= $last;          $in ||= $last;
501          $last = $in;          $last = $in;
502          return split(/\s+/, $in) if $in;          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.31  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.26