/[VRac]/M6502/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 /M6502/Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 30 by dpavlin, Mon Jul 30 17:56:13 2007 UTC revision 109 by dpavlin, Fri Aug 3 10:29:33 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 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 17  Orao - Orao emulator Line 19  Orao - Orao emulator
19    
20  =head1 VERSION  =head1 VERSION
21    
22  Version 0.02  Version 0.04
23    
24  =cut  =cut
25    
26  our $VERSION = '0.02';  our $VERSION = '0.04';
27    
28  =head1 SUMMARY  =head1 SUMMARY
29    
# Line 29  Emulator or Orao 8-bit 6502 machine popu Line 31  Emulator or Orao 8-bit 6502 machine popu
31    
32  =cut  =cut
33    
34  =head2 init  =head1 FUNCTIONS
35    
36  Start emulator  =head2 boot
37    
38    Start emulator, open L<Screen>, load initial ROM images, and render memory
39    
40      my $orao = Orao->new({});
41      $orao->boot;
42    
43  =cut  =cut
44    
45  sub init {  our $orao;
46    
47    select(STDERR); $| = 1;
48    
49    sub boot {
50          my $self = shift;          my $self = shift;
51          warn "call upstream init\n";          warn "Orao calling upstream init\n";
52          $self->SUPER::init( @_ );          $self->SUPER::init(
53                    read => sub { $self->read( @_ ) },
54                    write => sub { $self->write( @_ ) },
55            );
56    
57            warn "Orao $Orao::VERSION emulation starting\n";
58    
59          warn "staring Orao $ORAO::VERSION emulation\n";          warn "emulating ", $#mem, " bytes of memory\n";
60    
61          $self->open_screen;          $self->open_screen;
62          $self->load_rom;          $self->load_rom({
63                    0x1000 => 'dump/SCRINV.BIN',
64                    # should be 0x6000, but oraoemu has 2 byte prefix
65                    0x5FFE => 'dump/screen.dmp',
66    #               0xC000 => 'rom/BAS12.ROM',
67    #               0xE000 => 'rom/CRT12.ROM',
68                    0xC000 => 'rom/BAS13.ROM',
69                    0xE000 => 'rom/CRT13.ROM',
70            });
71    
72    #       $PC = 0xDD11;   # BC
73    #       $PC = 0xC274;   # MC
74    
75            $PC = 0xff89;
76    
77            $orao = $self;
78    
79    #       $self->prompt( 0x1000 );
80    
81            my ( $trace, $debug ) = ( $self->trace, $self->debug );
82            $self->trace( 0 );
83            $self->debug( 0 );
84    
85            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  =head2 load_oraoemu    $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          my $size = -s $path || die "no size for $path: $!";          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: $!";
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            if ( $addr == 0x87ff ) {
447                    return $self->read_tape;
448            }
449    
450            $self->mmap_pixel( $addr, 0, $byte, 0 );
451            return $byte;
452    }
453    
454    =head2 write
455    
456    Write into emory
457    
458      write( $address, $byte );
459    
460    =cut
461    
462    sub write {
463            my $self = shift;
464            my ($addr,$byte) = @_;
465            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
466    
467            if ( $addr == 0x8800 ) {
468                    warn sprintf "sound ignored: %x\n", $byte;
469            }
470    
471            if ( $addr > 0xafff ) {
472                    confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
473            }
474    
475            $self->mmap_pixel( $addr, $byte, 0, 0 );
476    
477            $mem[$addr] = $byte;
478            return;
479    }
480    
481    =head1 Command Line
482    
483    Command-line debugging intrerface is implemented for communication with
484    emulated device
485    
486  =head2 prompt  =head2 prompt
487    
488    $orao->prompt( $address, $last_command );    my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
489    
490  =cut  =cut
491    
492    my $last = 'r 1';
493    
494  sub prompt {  sub prompt {
495          my $self = shift;          my $self = shift;
496            $self->app->sync;
497          my $a = shift;          my $a = shift;
         my $last = shift;  
498          print $self->hexdump( $a ),          print $self->hexdump( $a ),
499                  $last ? "[$last] " : '',                  $last ? "[$last] " : '',
500                  "> ";                  "> ";
501          my $in = <STDIN>;          my $in = <STDIN>;
502          chomp($in);          chomp($in);
503            warn "## prompt got: $in\n" if $self->debug;
504          $in ||= $last;          $in ||= $last;
505          $last = $in;          $last = $in;
506          return split(/\s+/, $in) if $in;          return ( $in, split(/\s+/, $in) ) if $in;
507  }  }
508    
509    =head2 cli
510    
511      $orao->cli();
512    
513    =cut
514    
515    my $show_R = 0;
516    
517    sub cli {
518            my $self = shift;
519            my $a = $PC || confess "no pc?";
520            my $run_for = 0;
521            warn $self->dump_R() if $show_R;
522            while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
523                    my $c = shift @v;
524                    next unless defined($c);
525                    my $v = shift @v;
526                    $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
527                    @v = map { hex($_) } @v;
528                    printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
529                    if ( $c =~ m/^[qx]/i ) {
530                            exit;
531                    } elsif ( $c eq '?' ) {
532                            my $t = $self->trace ? 'on' : 'off' ;
533                            my $d = $self->debug ? 'on' : 'off' ;
534                            warn <<__USAGE__;
535    Usage:
536    
537    x|q\t\texit
538    e 6000 6010\tdump memory, +/- to walk forward/backward
539    m 1000 ff 00\tput ff 00 on 1000
540    j|u 1000\t\tjump (change pc)
541    r 42\t\trun 42 instruction opcodes
542    t\t\ttrace [$t]
543    d\t\tdebug [$d]
544    
545    __USAGE__
546                            warn $self->dump_R;
547                            $last = '';
548                    } elsif ( $c =~ m/^e/i ) {
549                            $a = $v if defined($v);
550                            my $to = shift @v;
551                            $to = $a + 32 if ( ! $to || $to <= $a );
552                            $to = 0xffff if ( $to > 0xffff );
553                            my $lines = int( ($to - $a + 8) / 8 );
554                            printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
555                            while ( --$lines ) {
556                                    print $self->hexdump( $a );
557                                    $a += 8;
558                            }
559                            $last = '+';
560                            $show_R = 0;
561                    } elsif ( $c =~ m/^\+/ ) {
562                            $a += 8;
563                            $show_R = 0;
564                    } elsif ( $c =~ m/^\-/ ) {
565                            $a -= 8;
566                            $show_R = 0;
567                    } elsif ( $c =~ m/^m/i ) {
568                            $a = $v if defined($v);
569                            $self->poke_code( $a, @v );
570                            printf "poke %d bytes at %04x\n", $#v + 1, $a;
571                            $last = '+';
572                            $show_R = 0;
573                    } elsif ( $c =~ m/^l/i ) {
574                            my $to = shift @v || 0x1000;
575                            $a = $to;
576                            $self->load_image( $v, $a );
577                            $last = '';
578                    } elsif ( $c =~ m/^s/i ) {
579                            $self->save_dump( $v || 'mem.dump', @v );
580                            $last = '';
581                    } elsif ( $c =~ m/^r/i ) {
582                            $run_for = $v || 1;
583                            print "run_for $run_for instructions\n";
584                            $show_R = 1;
585                            last;
586                    } elsif ( $c =~ m/^(u|j)/i ) {
587                            my $to = $v || $a;
588                            printf "set pc to %04x\n", $to;
589                            $PC = $to;      # remember for restart
590                            $run_for = 1;
591                            $last = "r $run_for";
592                            $show_R = 1;
593                            last;
594                    } elsif ( $c =~ m/^tape/ ) {
595                            if ( ! $v ) {
596                                    warn "ERROR: please specify tape name!\n";
597                            } elsif ( ! -e $v ) {
598                                    warn "ERROR: tape $v: $!\n";
599                            } else {
600                                    $self->load_tape( $v );
601                            }
602                            $last = '';
603                    } elsif ( $c =~ m/^t/i ) {
604                            $self->trace( not $self->trace );
605                            print "trace ", $self->trace ? 'on' : 'off', "\n";
606                            $last = '';
607                    } elsif ( $c =~ m/^d/i ) {
608                            $self->debug( not $self->debug );
609                            print "debug ", $self->debug ? 'on' : 'off', "\n";
610                            $last = '';
611                    } else {
612                            warn "# ignored $line\n" if ($line);
613                            $last = '';
614                    }
615            }
616    
617            return $run_for;
618    }
619    
620  =head1 AUTHOR  =head1 AUTHOR
621    
Legend:
Removed from v.30  
changed lines
  Added in v.109
  ViewVC Help
Powered by ViewVC 1.1.26