/[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

Annotation of /Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 103 - (hide annotations)
Thu Aug 2 18:01:51 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 12278 byte(s)
more work on keyboard. Addresses can now accept callback to handle special
cases, like newly added $self->key_down( $key )
1 dpavlin 29 package Orao;
2    
3     use warnings;
4     use strict;
5    
6 dpavlin 56 use Carp qw/confess/;
7 dpavlin 29 use lib './lib';
8     #use Time::HiRes qw(time);
9     use File::Slurp;
10 dpavlin 32 use Data::Dump qw/dump/;
11 dpavlin 78 use List::Util qw/first/;
12 dpavlin 34 use M6502;
13 dpavlin 29
14 dpavlin 56 use base qw(Class::Accessor M6502 Screen Prefs);
15 dpavlin 96 __PACKAGE__->mk_accessors(qw(booted));
16 dpavlin 29
17     =head1 NAME
18    
19     Orao - Orao emulator
20    
21     =head1 VERSION
22    
23 dpavlin 95 Version 0.04
24 dpavlin 29
25     =cut
26    
27 dpavlin 95 our $VERSION = '0.04';
28 dpavlin 29
29     =head1 SUMMARY
30    
31     Emulator or Orao 8-bit 6502 machine popular in Croatia
32    
33     =cut
34    
35 dpavlin 78 my @kbd_ports = (
36     0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
37     0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
38     0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
39     0x83FE,0x83FF,
40     );
41    
42 dpavlin 95 =head1 FUNCTIONS
43    
44 dpavlin 82 =head2 boot
45 dpavlin 30
46 dpavlin 56 Start emulator, open L<Screen>, load initial ROM images, and render memory
47 dpavlin 30
48 dpavlin 82 my $orao = Orao->new({});
49     $orao->boot;
50    
51 dpavlin 30 =cut
52    
53 dpavlin 32 our $orao;
54    
55 dpavlin 42 select(STDERR); $| = 1;
56    
57 dpavlin 82 sub boot {
58 dpavlin 30 my $self = shift;
59 dpavlin 34 warn "Orao calling upstream init\n";
60 dpavlin 90 $self->SUPER::init(
61     read => sub { $self->read( @_ ) },
62     write => sub { $self->write( @_ ) },
63     );
64 dpavlin 30
65 dpavlin 56 warn "Orao $Orao::VERSION emulation starting\n";
66 dpavlin 30
67 dpavlin 90 warn "emulating ", $#mem, " bytes of memory\n";
68    
69 dpavlin 30 $self->open_screen;
70 dpavlin 33 $self->load_rom({
71     0x1000 => 'dump/SCRINV.BIN',
72 dpavlin 76 # should be 0x6000, but oraoemu has 2 byte prefix
73     0x5FFE => 'dump/screen.dmp',
74 dpavlin 33 0xC000 => 'rom/BAS12.ROM',
75     0xE000 => 'rom/CRT12.ROM',
76     });
77 dpavlin 32
78 dpavlin 73 # $PC = 0xDD11; # BC
79 dpavlin 46 # $PC = 0xC274; # MC
80 dpavlin 35
81 dpavlin 78 $PC = 0xff89;
82    
83 dpavlin 32 $orao = $self;
84    
85 dpavlin 33 # $self->prompt( 0x1000 );
86    
87 dpavlin 49 my ( $trace, $debug ) = ( $self->trace, $self->debug );
88 dpavlin 38 $self->trace( 0 );
89 dpavlin 49 $self->debug( 0 );
90 dpavlin 33
91 dpavlin 73 $self->render( @mem[ 0x6000 .. 0x7fff ] );
92    
93 dpavlin 38 if ( $self->show_mem ) {
94 dpavlin 33
95 dpavlin 38 warn "rendering memory map\n";
96    
97 dpavlin 76 $self->render_mem( @mem );
98    
99 dpavlin 38 my @mmap = (
100     0x0000, 0x03FF, 'nulti blok',
101     0x0400, 0x5FFF, 'korisnièki RAM (23K)',
102     0x6000, 0x7FFF, 'video RAM',
103     0x8000, 0x9FFF, 'sistemske lokacije',
104     0xA000, 0xAFFF, 'ekstenzija',
105     0xB000, 0xBFFF, 'DOS',
106     0xC000, 0xDFFF, 'BASIC ROM',
107     0xE000, 0xFFFF, 'sistemski ROM',
108     );
109    
110     } else {
111    
112     warn "rendering video memory\n";
113 dpavlin 73 $self->render( @mem[ 0x6000 .. 0x7fff ] );
114 dpavlin 38
115 dpavlin 33 }
116 dpavlin 38 $self->sync;
117     $self->trace( $trace );
118 dpavlin 49 $self->debug( $debug );
119 dpavlin 33
120 dpavlin 39 #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
121 dpavlin 34
122 dpavlin 82 warn "Orao boot finished",
123 dpavlin 49 $self->trace ? ' trace' : '',
124     $self->debug ? ' debug' : '',
125     "\n";
126 dpavlin 38
127 dpavlin 82 M6502::reset();
128    
129 dpavlin 95 $self->booted( 1 );
130 dpavlin 30 }
131    
132 dpavlin 95 =head2 run
133    
134     Run interactive emulation loop
135    
136     $orao->run;
137    
138     =cut
139    
140     sub run {
141     my $self = shift;
142    
143 dpavlin 97 $self->show_mem( 1 );
144    
145 dpavlin 95 $self->boot if ( ! $self->booted );
146 dpavlin 96 $self->loop;
147 dpavlin 95 };
148    
149     =head1 Helper functions
150    
151 dpavlin 29 =head2 load_rom
152    
153     called to init memory and load initial rom images
154    
155     $orao->load_rom;
156    
157     =cut
158    
159     sub load_rom {
160 dpavlin 33 my ($self, $loaded_files) = @_;
161 dpavlin 29
162     #my $time_base = time();
163    
164     foreach my $addr ( sort keys %$loaded_files ) {
165     my $path = $loaded_files->{$addr};
166 dpavlin 94 $self->load_image( $path, $addr );
167 dpavlin 29 }
168     }
169    
170 dpavlin 61 # write chunk directly into memory, updateing vram if needed
171 dpavlin 46 sub _write_chunk {
172     my $self = shift;
173     my ( $addr, $chunk ) = @_;
174     $self->write_chunk( $addr, $chunk );
175     my $end = $addr + length($chunk);
176     my ( $f, $t ) = ( 0x6000, 0x7fff );
177    
178     if ( $end < $f || $addr >= $t ) {
179     warn "skip vram update\n";
180     return;
181     };
182    
183     $f = $addr if ( $addr > $f );
184     $t = $end if ( $end < $t );
185    
186     warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
187 dpavlin 73 # foreach my $a ( $f .. $t ) {
188     # $self->vram( $a - 0x6000 , $mem[ $a ] );
189     # }
190     $self->render( @mem[ 0x6000 .. 0x7fff ] );
191 dpavlin 77 $self->render_mem( @mem ) if $self->show_mem;
192 dpavlin 46 }
193    
194 dpavlin 94 =head2 load_image
195 dpavlin 61
196     Load binary files, ROM images and Orao Emulator files
197    
198 dpavlin 94 $orao->load_image( '/path/to/file', 0x1000 );
199 dpavlin 61
200     Returns true on success.
201    
202     =cut
203    
204 dpavlin 94 sub load_image {
205 dpavlin 29 my $self = shift;
206     my ( $path, $addr ) = @_;
207    
208 dpavlin 61 if ( ! -e $path ) {
209     warn "ERROR: file $path doesn't exist\n";
210     return;
211     }
212    
213 dpavlin 31 my $size = -s $path || confess "no size for $path: $!";
214 dpavlin 29
215     my $buff = read_file( $path );
216    
217     if ( $size == 65538 ) {
218     $addr = 0;
219 dpavlin 33 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
220 dpavlin 46 $self->_write_chunk( $addr, substr($buff,2) );
221 dpavlin 61 return 1;
222 dpavlin 29 } elsif ( $size == 32800 ) {
223     $addr = 0;
224 dpavlin 33 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
225 dpavlin 46 $self->_write_chunk( $addr, substr($buff,0x20) );
226 dpavlin 61 return 1;
227 dpavlin 29 }
228 dpavlin 33 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
229 dpavlin 61 $self->_write_chunk( $addr, $buff );
230     return 1;
231 dpavlin 29
232     my $chunk;
233    
234     my $pos = 0;
235    
236     while ( my $long = substr($buff,$pos,4) ) {
237     my @b = split(//, $long, 4);
238     $chunk .=
239     ( $b[3] || '' ) .
240     ( $b[2] || '' ) .
241     ( $b[1] || '' ) .
242     ( $b[0] || '' );
243     $pos += 4;
244     }
245    
246 dpavlin 46 $self->_write_chunk( $addr, $chunk );
247 dpavlin 29
248 dpavlin 61 return 1;
249 dpavlin 29 };
250    
251     =head2 save_dump
252    
253     $orao->save_dump( 'filename', $from, $to );
254    
255     =cut
256    
257     sub save_dump {
258     my $self = shift;
259    
260     my ( $path, $from, $to ) = @_;
261    
262     $from ||= 0;
263     $to ||= 0xffff;
264    
265     open(my $fh, '>', $path) || die "can't open $path: $!";
266     print $fh $self->read_chunk( $from, $to );
267     close($fh);
268    
269     my $size = -s $path;
270 dpavlin 32 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
271 dpavlin 29 }
272    
273     =head2 hexdump
274    
275     $orao->hexdump( $address );
276    
277     =cut
278    
279     sub hexdump {
280     my $self = shift;
281     my $a = shift;
282     return sprintf(" %04x %s\n", $a,
283     join(" ",
284     map {
285 dpavlin 71 if ( defined($_) ) {
286     sprintf( "%02x", $_ )
287     } else {
288     ' '
289     }
290 dpavlin 47 } @mem[ $a .. $a+8 ]
291 dpavlin 29 )
292     );
293     }
294    
295 dpavlin 32 =head1 Memory management
296 dpavlin 30
297 dpavlin 32 Orao implements all I/O using mmap addresses. This was main reason why
298     L<Acme::6502> was just too slow to handle it.
299    
300     =cut
301    
302     =head2 read
303    
304     Read from memory
305    
306     $byte = read( $address );
307    
308     =cut
309    
310 dpavlin 98 my $keyboard = {
311     0x87FC => {
312     'right' => 16,
313     'down' => 128,
314     'up' => 192,
315     'left' => 224,
316     'backspace' => 224,
317     },
318 dpavlin 103 0x87FD => sub {
319     my ( $self, $key ) = @_;
320     if ( $key eq 'return' ) {
321 dpavlin 101 M6502::_write( 0xfc, 13 );
322 dpavlin 98 return 0;
323 dpavlin 103 } elsif ( $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
324     return 16;
325     }
326 dpavlin 98 },
327     0x87FA => {
328     'f4' => 16,
329     'f3' => 128,
330     'f2' => 192,
331     'f1' => 224,
332     },
333 dpavlin 103 0x87FB => sub {
334     my ( $self, $key ) = @_;
335     if ( $key eq 'space' ) {
336     return 32;
337     } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
338     return 16;
339     }
340 dpavlin 98 },
341     0x87F6 => {
342     '6' => 16,
343     't' => 128,
344     'z' => 192,
345     'r' => 224,
346     },
347     0x87F7 => {
348     '5' => 32,
349     '4' => 16,
350     },
351     0x87EE => {
352     '7' => 16,
353     'u' => 128,
354     'i' => 192,
355     'o' => 224,
356     },
357     0x87EF => {
358     '8' => 32,
359     '9' => 16,
360     },
361     0x87DE => {
362     '1' => 16,
363     'w' => 128,
364     'q' => 192,
365     'e' => 224,
366     },
367     0x87DF => {
368     '2' => 32,
369     '3' => 16,
370     },
371     0x87BE => {
372     'm' => 16,
373     'k' => 128,
374     'j' => 192,
375     'l' => 224,
376     },
377     0x87BF => {
378     ',' => 32,
379     '.' => 16,
380     },
381     0x877E => {
382     'y' => 16,
383     's' => 128,
384     'a' => 192,
385     'd' => 224,
386     },
387     0x877F => {
388     'x' => 32,
389     'c' => 16,
390     },
391     0x86FE => {
392     'n' => 16,
393     'g' => 128,
394     'h' => 192,
395     'f' => 224,
396     },
397     0x86FF => {
398     'b' => 32,
399 dpavlin 102 'v' => 16,
400 dpavlin 98 },
401     0x85FE => {
402 dpavlin 103 ';' => sub { $_[0]->key_down('left shift') ? 16 : 224 },
403 dpavlin 98 '\\' => 128,
404     '\'' => 192,
405 dpavlin 103 # ';' => 224,
406 dpavlin 98 '8' => 16, # FIXME?
407     },
408     0x85FF => {
409     '/' => 32,
410     '6' => 16, # FIXME?
411     },
412     0x83FE => {
413     ';' => 16,
414     '[' => 128,
415     ']' => 192,
416     'p' => 224,
417     '=' => 16, # FIXME?
418     },
419     0x83FF => {
420     '-' => 32,
421     '0' => 16,
422     },
423     };
424    
425 dpavlin 101 my $keyboard_none = 255;
426 dpavlin 98
427 dpavlin 32 sub read {
428 dpavlin 33 my $self = shift;
429 dpavlin 32 my ($addr) = @_;
430     my $byte = $mem[$addr];
431 dpavlin 90 confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
432 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
433 dpavlin 78
434     # keyboard
435    
436     if ( first { $addr == $_ } @kbd_ports ) {
437 dpavlin 97 warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
438 dpavlin 99 my $key = $self->key_pressed;
439     if ( defined($key) ) {
440 dpavlin 103 my $ret = $keyboard_none;
441 dpavlin 98 my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
442 dpavlin 103 if ( ref($r) eq 'CODE' ) {
443     $ret = $r->($self, $key);
444     } elsif ( $ret = $r->{$key} ) {
445 dpavlin 98 if ( ref($ret) eq 'CODE' ) {
446 dpavlin 103 $ret = $ret->($self);
447 dpavlin 98 warn "executed $key and got: $ret\n";
448     } else {
449     warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret);
450     }
451     $mem[$addr] = $ret;
452 dpavlin 101 warn "keypress: $key = $ret\n";
453 dpavlin 98 return $ret;
454     } else {
455 dpavlin 99 warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
456 dpavlin 98 }
457     warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace;
458     }
459 dpavlin 101 return $keyboard_none;
460 dpavlin 78 }
461    
462 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
463 dpavlin 32 return $byte;
464     }
465    
466     =head2 write
467    
468     Write into emory
469    
470     write( $address, $byte );
471    
472     =cut
473    
474     sub write {
475 dpavlin 33 my $self = shift;
476 dpavlin 32 my ($addr,$byte) = @_;
477 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
478 dpavlin 32
479     if ( $addr >= 0x6000 && $addr < 0x8000 ) {
480     $self->vram( $addr - 0x6000 , $byte );
481     }
482    
483     if ( $addr == 0x8800 ) {
484     warn sprintf "sound ignored: %x\n", $byte;
485     }
486    
487 dpavlin 52 if ( $addr > 0xafff ) {
488 dpavlin 90 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
489 dpavlin 52 }
490    
491 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
492 dpavlin 32
493     $mem[$addr] = $byte;
494 dpavlin 36 return;
495 dpavlin 32 }
496    
497 dpavlin 42 =head1 Command Line
498 dpavlin 32
499 dpavlin 42 Command-line debugging intrerface is implemented for communication with
500     emulated device
501    
502 dpavlin 50 =head2 prompt
503    
504 dpavlin 61 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
505 dpavlin 50
506     =cut
507    
508     my $last = 'r 1';
509    
510     sub prompt {
511     my $self = shift;
512     $self->app->sync;
513     my $a = shift;
514 dpavlin 97 print $self->hexdump( $a ),
515 dpavlin 50 $last ? "[$last] " : '',
516     "> ";
517     my $in = <STDIN>;
518     chomp($in);
519     warn "## prompt got: $in\n" if $self->debug;
520     $in ||= $last;
521     $last = $in;
522 dpavlin 61 return ( $in, split(/\s+/, $in) ) if $in;
523 dpavlin 50 }
524    
525 dpavlin 42 =head2 cli
526    
527     $orao->cli();
528    
529     =cut
530    
531 dpavlin 68 my $show_R = 0;
532    
533 dpavlin 42 sub cli {
534     my $self = shift;
535     my $a = $PC || confess "no pc?";
536 dpavlin 96 my $run_for = 0;
537 dpavlin 68 warn $self->dump_R() if $show_R;
538 dpavlin 61 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
539 dpavlin 42 my $c = shift @v;
540 dpavlin 61 next unless defined($c);
541 dpavlin 42 my $v = shift @v;
542     $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
543     @v = map { hex($_) } @v;
544 dpavlin 49 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
545 dpavlin 42 if ( $c =~ m/^[qx]/i ) {
546     exit;
547     } elsif ( $c eq '?' ) {
548 dpavlin 50 my $t = $self->trace ? 'on' : 'off' ;
549     my $d = $self->debug ? 'on' : 'off' ;
550 dpavlin 42 warn <<__USAGE__;
551 dpavlin 50 Usage:
552    
553 dpavlin 42 x|q\t\texit
554     e 6000 6010\tdump memory, +/- to walk forward/backward
555     m 1000 ff 00\tput ff 00 on 1000
556     j|u 1000\t\tjump (change pc)
557     r 42\t\trun 42 instruction opcodes
558 dpavlin 50 t\t\ttrace [$t]
559     d\t\tdebug [$d]
560    
561 dpavlin 42 __USAGE__
562 dpavlin 68 warn $self->dump_R;
563 dpavlin 97 $last = '';
564 dpavlin 42 } elsif ( $c =~ m/^e/i ) {
565 dpavlin 49 $a = $v if defined($v);
566 dpavlin 42 my $to = shift @v;
567     $to = $a + 32 if ( ! $to || $to <= $a );
568 dpavlin 71 $to = 0xffff if ( $to > 0xffff );
569 dpavlin 59 my $lines = int( ($to - $a + 8) / 8 );
570     printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
571     while ( --$lines ) {
572 dpavlin 42 print $self->hexdump( $a );
573     $a += 8;
574     }
575     $last = '+';
576 dpavlin 68 $show_R = 0;
577 dpavlin 42 } elsif ( $c =~ m/^\+/ ) {
578     $a += 8;
579 dpavlin 68 $show_R = 0;
580 dpavlin 42 } elsif ( $c =~ m/^\-/ ) {
581     $a -= 8;
582 dpavlin 68 $show_R = 0;
583 dpavlin 42 } elsif ( $c =~ m/^m/i ) {
584 dpavlin 70 $a = $v if defined($v);
585 dpavlin 42 $self->poke_code( $a, @v );
586     printf "poke %d bytes at %04x\n", $#v + 1, $a;
587 dpavlin 50 $last = '+';
588 dpavlin 68 $show_R = 0;
589 dpavlin 42 } elsif ( $c =~ m/^l/i ) {
590     my $to = shift @v || 0x1000;
591     $a = $to;
592 dpavlin 94 $self->load_image( $v, $a );
593 dpavlin 50 $last = '';
594 dpavlin 42 } elsif ( $c =~ m/^s/i ) {
595     $self->save_dump( $v || 'mem.dump', @v );
596 dpavlin 50 $last = '';
597 dpavlin 42 } elsif ( $c =~ m/^r/i ) {
598     $run_for = $v || 1;
599     print "run_for $run_for instructions\n";
600 dpavlin 68 $show_R = 1;
601 dpavlin 42 last;
602     } elsif ( $c =~ m/^(u|j)/ ) {
603     my $to = $v || $a;
604     printf "set pc to %04x\n", $to;
605     $PC = $to; # remember for restart
606     $run_for = 1;
607 dpavlin 62 $last = "r $run_for";
608 dpavlin 68 $show_R = 1;
609 dpavlin 42 last;
610     } elsif ( $c =~ m/^t/ ) {
611     $self->trace( not $self->trace );
612     print "trace ", $self->trace ? 'on' : 'off', "\n";
613 dpavlin 64 $last = '';
614 dpavlin 49 } elsif ( $c =~ m/^d/ ) {
615     $self->debug( not $self->debug );
616     print "debug ", $self->debug ? 'on' : 'off', "\n";
617 dpavlin 64 $last = '';
618 dpavlin 42 } else {
619 dpavlin 61 warn "# ignored $line\n" if ($line);
620     $last = '';
621 dpavlin 42 }
622     }
623    
624 dpavlin 96 return $run_for;
625 dpavlin 42 }
626    
627 dpavlin 29 =head1 AUTHOR
628    
629     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
630    
631     =head1 BUGS
632    
633     =head1 ACKNOWLEDGEMENTS
634    
635     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
636     info about this machine (and even hardware implementation from 2007).
637    
638     =head1 COPYRIGHT & LICENSE
639    
640     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
641    
642     This program is free software; you can redistribute it and/or modify it
643     under the same terms as Perl itself.
644    
645     =cut
646    
647     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26