/[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 99 - (hide annotations)
Thu Aug 2 16:21:17 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 11846 byte(s)
keyboard works, but it's *soooooo* slow... :-(
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 99 my $key = $self->key_pressed;
434     if ( defined($key) ) {
435 dpavlin 98 my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
436     if ( my $ret = $r->{$key} ) {
437     if ( ref($ret) eq 'CODE' ) {
438     $ret = $ret->();
439     warn "executed $key and got: $ret\n";
440     } else {
441     warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret);
442     }
443     $mem[$addr] = $ret;
444     return $ret;
445     } else {
446 dpavlin 99 warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
447 dpavlin 98 }
448     warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace;
449     }
450 dpavlin 78 }
451    
452 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
453 dpavlin 32 return $byte;
454     }
455    
456     =head2 write
457    
458     Write into emory
459    
460     write( $address, $byte );
461    
462     =cut
463    
464     sub write {
465 dpavlin 33 my $self = shift;
466 dpavlin 32 my ($addr,$byte) = @_;
467 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
468 dpavlin 32
469     if ( $addr >= 0x6000 && $addr < 0x8000 ) {
470     $self->vram( $addr - 0x6000 , $byte );
471     }
472    
473     if ( $addr == 0x8800 ) {
474     warn sprintf "sound ignored: %x\n", $byte;
475     }
476    
477 dpavlin 52 if ( $addr > 0xafff ) {
478 dpavlin 90 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
479 dpavlin 52 }
480    
481 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
482 dpavlin 32
483     $mem[$addr] = $byte;
484 dpavlin 36 return;
485 dpavlin 32 }
486    
487 dpavlin 42 =head1 Command Line
488 dpavlin 32
489 dpavlin 42 Command-line debugging intrerface is implemented for communication with
490     emulated device
491    
492 dpavlin 50 =head2 prompt
493    
494 dpavlin 61 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
495 dpavlin 50
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 dpavlin 97 print $self->hexdump( $a ),
505 dpavlin 50 $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 dpavlin 61 return ( $in, split(/\s+/, $in) ) if $in;
513 dpavlin 50 }
514    
515 dpavlin 42 =head2 cli
516    
517     $orao->cli();
518    
519     =cut
520    
521 dpavlin 68 my $show_R = 0;
522    
523 dpavlin 42 sub cli {
524     my $self = shift;
525     my $a = $PC || confess "no pc?";
526 dpavlin 96 my $run_for = 0;
527 dpavlin 68 warn $self->dump_R() if $show_R;
528 dpavlin 61 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
529 dpavlin 42 my $c = shift @v;
530 dpavlin 61 next unless defined($c);
531 dpavlin 42 my $v = shift @v;
532     $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
533     @v = map { hex($_) } @v;
534 dpavlin 49 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
535 dpavlin 42 if ( $c =~ m/^[qx]/i ) {
536     exit;
537     } elsif ( $c eq '?' ) {
538 dpavlin 50 my $t = $self->trace ? 'on' : 'off' ;
539     my $d = $self->debug ? 'on' : 'off' ;
540 dpavlin 42 warn <<__USAGE__;
541 dpavlin 50 Usage:
542    
543 dpavlin 42 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 dpavlin 50 t\t\ttrace [$t]
549     d\t\tdebug [$d]
550    
551 dpavlin 42 __USAGE__
552 dpavlin 68 warn $self->dump_R;
553 dpavlin 97 $last = '';
554 dpavlin 42 } elsif ( $c =~ m/^e/i ) {
555 dpavlin 49 $a = $v if defined($v);
556 dpavlin 42 my $to = shift @v;
557     $to = $a + 32 if ( ! $to || $to <= $a );
558 dpavlin 71 $to = 0xffff if ( $to > 0xffff );
559 dpavlin 59 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 dpavlin 42 print $self->hexdump( $a );
563     $a += 8;
564     }
565     $last = '+';
566 dpavlin 68 $show_R = 0;
567 dpavlin 42 } elsif ( $c =~ m/^\+/ ) {
568     $a += 8;
569 dpavlin 68 $show_R = 0;
570 dpavlin 42 } elsif ( $c =~ m/^\-/ ) {
571     $a -= 8;
572 dpavlin 68 $show_R = 0;
573 dpavlin 42 } elsif ( $c =~ m/^m/i ) {
574 dpavlin 70 $a = $v if defined($v);
575 dpavlin 42 $self->poke_code( $a, @v );
576     printf "poke %d bytes at %04x\n", $#v + 1, $a;
577 dpavlin 50 $last = '+';
578 dpavlin 68 $show_R = 0;
579 dpavlin 42 } elsif ( $c =~ m/^l/i ) {
580     my $to = shift @v || 0x1000;
581     $a = $to;
582 dpavlin 94 $self->load_image( $v, $a );
583 dpavlin 50 $last = '';
584 dpavlin 42 } elsif ( $c =~ m/^s/i ) {
585     $self->save_dump( $v || 'mem.dump', @v );
586 dpavlin 50 $last = '';
587 dpavlin 42 } elsif ( $c =~ m/^r/i ) {
588     $run_for = $v || 1;
589     print "run_for $run_for instructions\n";
590 dpavlin 68 $show_R = 1;
591 dpavlin 42 last;
592     } elsif ( $c =~ m/^(u|j)/ ) {
593     my $to = $v || $a;
594     printf "set pc to %04x\n", $to;
595     $PC = $to; # remember for restart
596     $run_for = 1;
597 dpavlin 62 $last = "r $run_for";
598 dpavlin 68 $show_R = 1;
599 dpavlin 42 last;
600     } elsif ( $c =~ m/^t/ ) {
601     $self->trace( not $self->trace );
602     print "trace ", $self->trace ? 'on' : 'off', "\n";
603 dpavlin 64 $last = '';
604 dpavlin 49 } elsif ( $c =~ m/^d/ ) {
605     $self->debug( not $self->debug );
606     print "debug ", $self->debug ? 'on' : 'off', "\n";
607 dpavlin 64 $last = '';
608 dpavlin 42 } else {
609 dpavlin 61 warn "# ignored $line\n" if ($line);
610     $last = '';
611 dpavlin 42 }
612     }
613    
614 dpavlin 96 return $run_for;
615 dpavlin 42 }
616    
617 dpavlin 29 =head1 AUTHOR
618    
619     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
620    
621     =head1 BUGS
622    
623     =head1 ACKNOWLEDGEMENTS
624    
625     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
626     info about this machine (and even hardware implementation from 2007).
627    
628     =head1 COPYRIGHT & LICENSE
629    
630     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
631    
632     This program is free software; you can redistribute it and/or modify it
633     under the same terms as Perl itself.
634    
635     =cut
636    
637     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26