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

  ViewVC Help
Powered by ViewVC 1.1.26