/[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 98 - (hide annotations)
Thu Aug 2 16:01:16 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 11819 byte(s)
non-working keyboard :-/
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     0x87FD => {
319     'return' => sub {
320     M6502::write( 0xfc, 13 );
321     return 0;
322     },
323     'left ctrl' => 16,
324     'right ctrl' => 16,
325     },
326     0x87FA => {
327     'f4' => 16,
328     'f3' => 128,
329     'f2' => 192,
330     'f1' => 224,
331     },
332     0x87FB => {
333     'space' => 32,
334     'left shift' => 16,
335     'right shift' => 16,
336     },
337     0x87F6 => {
338     '6' => 16,
339     't' => 128,
340     'z' => 192,
341     'r' => 224,
342     },
343     0x87F7 => {
344     '5' => 32,
345     '4' => 16,
346     },
347     0x87EE => {
348     '7' => 16,
349     'u' => 128,
350     'i' => 192,
351     'o' => 224,
352     },
353     0x87EF => {
354     '8' => 32,
355     '9' => 16,
356     },
357     0x87DE => {
358     '1' => 16,
359     'w' => 128,
360     'q' => 192,
361     'e' => 224,
362     },
363     0x87DF => {
364     '2' => 32,
365     '3' => 16,
366     },
367     0x87BE => {
368     'm' => 16,
369     'k' => 128,
370     'j' => 192,
371     'l' => 224,
372     },
373     0x87BF => {
374     ',' => 32,
375     '.' => 16,
376     },
377     0x877E => {
378     'y' => 16,
379     's' => 128,
380     'a' => 192,
381     'd' => 224,
382     },
383     0x877F => {
384     'x' => 32,
385     'c' => 16,
386     },
387     0x86FE => {
388     'n' => 16,
389     'g' => 128,
390     'h' => 192,
391     'f' => 224,
392     },
393     0x86FF => {
394     'b' => 32,
395     'c' => 16,
396     },
397     0x85FE => {
398     ':' => 16,
399     '\\' => 128,
400     '\'' => 192,
401     ';' => 224,
402     '8' => 16, # FIXME?
403     },
404     0x85FF => {
405     '/' => 32,
406     '6' => 16, # FIXME?
407     },
408     0x83FE => {
409     ';' => 16,
410     '[' => 128,
411     ']' => 192,
412     'p' => 224,
413     '=' => 16, # FIXME?
414     },
415     0x83FF => {
416     '-' => 32,
417     '0' => 16,
418     },
419     };
420    
421    
422 dpavlin 32 sub read {
423 dpavlin 33 my $self = shift;
424 dpavlin 32 my ($addr) = @_;
425     my $byte = $mem[$addr];
426 dpavlin 90 confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
427 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
428 dpavlin 78
429     # keyboard
430    
431     if ( first { $addr == $_ } @kbd_ports ) {
432 dpavlin 97 warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
433 dpavlin 98 if ( my $key = $self->key_pressed ) {
434     my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
435     if ( my $ret = $r->{$key} ) {
436     if ( ref($ret) eq 'CODE' ) {
437     $ret = $ret->();
438     warn "executed $key and got: $ret\n";
439     } else {
440     warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret);
441     }
442     $mem[$addr] = $ret;
443     return $ret;
444     } else {
445     warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key);
446     }
447     warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace;
448     }
449 dpavlin 78 }
450    
451 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
452 dpavlin 32 return $byte;
453     }
454    
455     =head2 write
456    
457     Write into emory
458    
459     write( $address, $byte );
460    
461     =cut
462    
463     sub write {
464 dpavlin 33 my $self = shift;
465 dpavlin 32 my ($addr,$byte) = @_;
466 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
467 dpavlin 32
468     if ( $addr >= 0x6000 && $addr < 0x8000 ) {
469     $self->vram( $addr - 0x6000 , $byte );
470     }
471    
472     if ( $addr == 0x8800 ) {
473     warn sprintf "sound ignored: %x\n", $byte;
474     }
475    
476 dpavlin 52 if ( $addr > 0xafff ) {
477 dpavlin 90 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
478 dpavlin 52 }
479    
480 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
481 dpavlin 32
482     $mem[$addr] = $byte;
483 dpavlin 36 return;
484 dpavlin 32 }
485    
486 dpavlin 42 =head1 Command Line
487 dpavlin 32
488 dpavlin 42 Command-line debugging intrerface is implemented for communication with
489     emulated device
490    
491 dpavlin 50 =head2 prompt
492    
493 dpavlin 61 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
494 dpavlin 50
495     =cut
496    
497     my $last = 'r 1';
498    
499     sub prompt {
500     my $self = shift;
501     $self->app->sync;
502     my $a = shift;
503 dpavlin 97 print $self->hexdump( $a ),
504 dpavlin 50 $last ? "[$last] " : '',
505     "> ";
506     my $in = <STDIN>;
507     chomp($in);
508     warn "## prompt got: $in\n" if $self->debug;
509     $in ||= $last;
510     $last = $in;
511 dpavlin 61 return ( $in, split(/\s+/, $in) ) if $in;
512 dpavlin 50 }
513    
514 dpavlin 42 =head2 cli
515    
516     $orao->cli();
517    
518     =cut
519    
520 dpavlin 68 my $show_R = 0;
521    
522 dpavlin 42 sub cli {
523     my $self = shift;
524     my $a = $PC || confess "no pc?";
525 dpavlin 96 my $run_for = 0;
526 dpavlin 68 warn $self->dump_R() if $show_R;
527 dpavlin 61 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
528 dpavlin 42 my $c = shift @v;
529 dpavlin 61 next unless defined($c);
530 dpavlin 42 my $v = shift @v;
531     $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
532     @v = map { hex($_) } @v;
533 dpavlin 49 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
534 dpavlin 42 if ( $c =~ m/^[qx]/i ) {
535     exit;
536     } elsif ( $c eq '?' ) {
537 dpavlin 50 my $t = $self->trace ? 'on' : 'off' ;
538     my $d = $self->debug ? 'on' : 'off' ;
539 dpavlin 42 warn <<__USAGE__;
540 dpavlin 50 Usage:
541    
542 dpavlin 42 x|q\t\texit
543     e 6000 6010\tdump memory, +/- to walk forward/backward
544     m 1000 ff 00\tput ff 00 on 1000
545     j|u 1000\t\tjump (change pc)
546     r 42\t\trun 42 instruction opcodes
547 dpavlin 50 t\t\ttrace [$t]
548     d\t\tdebug [$d]
549    
550 dpavlin 42 __USAGE__
551 dpavlin 68 warn $self->dump_R;
552 dpavlin 97 $last = '';
553 dpavlin 42 } elsif ( $c =~ m/^e/i ) {
554 dpavlin 49 $a = $v if defined($v);
555 dpavlin 42 my $to = shift @v;
556     $to = $a + 32 if ( ! $to || $to <= $a );
557 dpavlin 71 $to = 0xffff if ( $to > 0xffff );
558 dpavlin 59 my $lines = int( ($to - $a + 8) / 8 );
559     printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
560     while ( --$lines ) {
561 dpavlin 42 print $self->hexdump( $a );
562     $a += 8;
563     }
564     $last = '+';
565 dpavlin 68 $show_R = 0;
566 dpavlin 42 } elsif ( $c =~ m/^\+/ ) {
567     $a += 8;
568 dpavlin 68 $show_R = 0;
569 dpavlin 42 } elsif ( $c =~ m/^\-/ ) {
570     $a -= 8;
571 dpavlin 68 $show_R = 0;
572 dpavlin 42 } elsif ( $c =~ m/^m/i ) {
573 dpavlin 70 $a = $v if defined($v);
574 dpavlin 42 $self->poke_code( $a, @v );
575     printf "poke %d bytes at %04x\n", $#v + 1, $a;
576 dpavlin 50 $last = '+';
577 dpavlin 68 $show_R = 0;
578 dpavlin 42 } elsif ( $c =~ m/^l/i ) {
579     my $to = shift @v || 0x1000;
580     $a = $to;
581 dpavlin 94 $self->load_image( $v, $a );
582 dpavlin 50 $last = '';
583 dpavlin 42 } elsif ( $c =~ m/^s/i ) {
584     $self->save_dump( $v || 'mem.dump', @v );
585 dpavlin 50 $last = '';
586 dpavlin 42 } elsif ( $c =~ m/^r/i ) {
587     $run_for = $v || 1;
588     print "run_for $run_for instructions\n";
589 dpavlin 68 $show_R = 1;
590 dpavlin 42 last;
591     } elsif ( $c =~ m/^(u|j)/ ) {
592     my $to = $v || $a;
593     printf "set pc to %04x\n", $to;
594     $PC = $to; # remember for restart
595     $run_for = 1;
596 dpavlin 62 $last = "r $run_for";
597 dpavlin 68 $show_R = 1;
598 dpavlin 42 last;
599     } elsif ( $c =~ m/^t/ ) {
600     $self->trace( not $self->trace );
601     print "trace ", $self->trace ? 'on' : 'off', "\n";
602 dpavlin 64 $last = '';
603 dpavlin 49 } elsif ( $c =~ m/^d/ ) {
604     $self->debug( not $self->debug );
605     print "debug ", $self->debug ? 'on' : 'off', "\n";
606 dpavlin 64 $last = '';
607 dpavlin 42 } else {
608 dpavlin 61 warn "# ignored $line\n" if ($line);
609     $last = '';
610 dpavlin 42 }
611     }
612    
613 dpavlin 96 return $run_for;
614 dpavlin 42 }
615    
616 dpavlin 29 =head1 AUTHOR
617    
618     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
619    
620     =head1 BUGS
621    
622     =head1 ACKNOWLEDGEMENTS
623    
624     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
625     info about this machine (and even hardware implementation from 2007).
626    
627     =head1 COPYRIGHT & LICENSE
628    
629     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
630    
631     This program is free software; you can redistribute it and/or modify it
632     under the same terms as Perl itself.
633    
634     =cut
635    
636     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26