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

Contents of /Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 107 - (show annotations)
Fri Aug 3 08:57:37 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 11825 byte(s)
cleanup left-overs from byte-by-byte screen rendering and flip bytes on
screen so it's o.k.
1 package Orao;
2
3 use warnings;
4 use strict;
5
6 use Carp qw/confess/;
7 use lib './lib';
8 #use Time::HiRes qw(time);
9 use File::Slurp;
10 use Data::Dump qw/dump/;
11 use M6502;
12
13 use base qw(Class::Accessor M6502 Screen Prefs);
14 __PACKAGE__->mk_accessors(qw(booted));
15
16 =head1 NAME
17
18 Orao - Orao emulator
19
20 =head1 VERSION
21
22 Version 0.04
23
24 =cut
25
26 our $VERSION = '0.04';
27
28 =head1 SUMMARY
29
30 Emulator or Orao 8-bit 6502 machine popular in Croatia
31
32 =cut
33
34 =head1 FUNCTIONS
35
36 =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
44
45 our $orao;
46
47 select(STDERR); $| = 1;
48
49 sub boot {
50 my $self = shift;
51 warn "Orao calling upstream init\n";
52 $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 "emulating ", $#mem, " bytes of memory\n";
60
61 $self->open_screen;
62 $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 =head2 run
123
124 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
140
141 called to init memory and load initial rom images
142
143 $orao->load_rom;
144
145 =cut
146
147 sub load_rom {
148 my ($self, $loaded_files) = @_;
149
150 #my $time_base = time();
151
152 foreach my $addr ( sort keys %$loaded_files ) {
153 my $path = $loaded_files->{$addr};
154 $self->load_image( $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 $orao->load_image( '/path/to/file', 0x1000 );
184
185 Returns true on success.
186
187 =cut
188
189 sub load_image {
190 my $self = shift;
191 my ( $path, $addr ) = @_;
192
193 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 );
201
202 if ( $size == 65538 ) {
203 $addr = 0;
204 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) );
206 return 1;
207 } elsif ( $size == 32800 ) {
208 $addr = 0;
209 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) );
211 return 1;
212 }
213 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
214 $self->_write_chunk( $addr, $buff );
215 return 1;
216
217 my $chunk;
218
219 my $pos = 0;
220
221 while ( my $long = substr($buff,$pos,4) ) {
222 my @b = split(//, $long, 4);
223 $chunk .=
224 ( $b[3] || '' ) .
225 ( $b[2] || '' ) .
226 ( $b[1] || '' ) .
227 ( $b[0] || '' );
228 $pos += 4;
229 }
230
231 $self->_write_chunk( $addr, $chunk );
232
233 return 1;
234 };
235
236 =head2 save_dump
237
238 $orao->save_dump( 'filename', $from, $to );
239
240 =cut
241
242 sub save_dump {
243 my $self = shift;
244
245 my ( $path, $from, $to ) = @_;
246
247 $from ||= 0;
248 $to ||= 0xffff;
249
250 open(my $fh, '>', $path) || die "can't open $path: $!";
251 print $fh $self->read_chunk( $from, $to );
252 close($fh);
253
254 my $size = -s $path;
255 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
256 }
257
258 =head2 hexdump
259
260 $orao->hexdump( $address );
261
262 =cut
263
264 sub hexdump {
265 my $self = shift;
266 my $a = shift;
267 return sprintf(" %04x %s\n", $a,
268 join(" ",
269 map {
270 if ( defined($_) ) {
271 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 $self->mmap_pixel( $addr, 0, $byte, 0 );
447 return $byte;
448 }
449
450 =head2 write
451
452 Write into emory
453
454 write( $address, $byte );
455
456 =cut
457
458 sub write {
459 my $self = shift;
460 my ($addr,$byte) = @_;
461 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
462
463 if ( $addr == 0x8800 ) {
464 warn sprintf "sound ignored: %x\n", $byte;
465 }
466
467 if ( $addr > 0xafff ) {
468 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
469 }
470
471 $self->mmap_pixel( $addr, $byte, 0, 0 );
472
473 $mem[$addr] = $byte;
474 return;
475 }
476
477 =head1 Command Line
478
479 Command-line debugging intrerface is implemented for communication with
480 emulated device
481
482 =head2 prompt
483
484 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
485
486 =cut
487
488 my $last = 'r 1';
489
490 sub prompt {
491 my $self = shift;
492 $self->app->sync;
493 my $a = shift;
494 print $self->hexdump( $a ),
495 $last ? "[$last] " : '',
496 "> ";
497 my $in = <STDIN>;
498 chomp($in);
499 warn "## prompt got: $in\n" if $self->debug;
500 $in ||= $last;
501 $last = $in;
502 return ( $in, split(/\s+/, $in) ) if $in;
503 }
504
505 =head2 cli
506
507 $orao->cli();
508
509 =cut
510
511 my $show_R = 0;
512
513 sub cli {
514 my $self = shift;
515 my $a = $PC || confess "no pc?";
516 my $run_for = 0;
517 warn $self->dump_R() if $show_R;
518 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
519 my $c = shift @v;
520 next unless defined($c);
521 my $v = shift @v;
522 $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
523 @v = map { hex($_) } @v;
524 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
525 if ( $c =~ m/^[qx]/i ) {
526 exit;
527 } elsif ( $c eq '?' ) {
528 my $t = $self->trace ? 'on' : 'off' ;
529 my $d = $self->debug ? 'on' : 'off' ;
530 warn <<__USAGE__;
531 Usage:
532
533 x|q\t\texit
534 e 6000 6010\tdump memory, +/- to walk forward/backward
535 m 1000 ff 00\tput ff 00 on 1000
536 j|u 1000\t\tjump (change pc)
537 r 42\t\trun 42 instruction opcodes
538 t\t\ttrace [$t]
539 d\t\tdebug [$d]
540
541 __USAGE__
542 warn $self->dump_R;
543 $last = '';
544 } elsif ( $c =~ m/^e/i ) {
545 $a = $v if defined($v);
546 my $to = shift @v;
547 $to = $a + 32 if ( ! $to || $to <= $a );
548 $to = 0xffff if ( $to > 0xffff );
549 my $lines = int( ($to - $a + 8) / 8 );
550 printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
551 while ( --$lines ) {
552 print $self->hexdump( $a );
553 $a += 8;
554 }
555 $last = '+';
556 $show_R = 0;
557 } elsif ( $c =~ m/^\+/ ) {
558 $a += 8;
559 $show_R = 0;
560 } elsif ( $c =~ m/^\-/ ) {
561 $a -= 8;
562 $show_R = 0;
563 } elsif ( $c =~ m/^m/i ) {
564 $a = $v if defined($v);
565 $self->poke_code( $a, @v );
566 printf "poke %d bytes at %04x\n", $#v + 1, $a;
567 $last = '+';
568 $show_R = 0;
569 } elsif ( $c =~ m/^l/i ) {
570 my $to = shift @v || 0x1000;
571 $a = $to;
572 $self->load_image( $v, $a );
573 $last = '';
574 } elsif ( $c =~ m/^s/i ) {
575 $self->save_dump( $v || 'mem.dump', @v );
576 $last = '';
577 } elsif ( $c =~ m/^r/i ) {
578 $run_for = $v || 1;
579 print "run_for $run_for instructions\n";
580 $show_R = 1;
581 last;
582 } elsif ( $c =~ m/^(u|j)/ ) {
583 my $to = $v || $a;
584 printf "set pc to %04x\n", $to;
585 $PC = $to; # remember for restart
586 $run_for = 1;
587 $last = "r $run_for";
588 $show_R = 1;
589 last;
590 } elsif ( $c =~ m/^t/ ) {
591 $self->trace( not $self->trace );
592 print "trace ", $self->trace ? 'on' : 'off', "\n";
593 $last = '';
594 } elsif ( $c =~ m/^d/ ) {
595 $self->debug( not $self->debug );
596 print "debug ", $self->debug ? 'on' : 'off', "\n";
597 $last = '';
598 } else {
599 warn "# ignored $line\n" if ($line);
600 $last = '';
601 }
602 }
603
604 return $run_for;
605 }
606
607 =head1 AUTHOR
608
609 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
610
611 =head1 BUGS
612
613 =head1 ACKNOWLEDGEMENTS
614
615 See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
616 info about this machine (and even hardware implementation from 2007).
617
618 =head1 COPYRIGHT & LICENSE
619
620 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
621
622 This program is free software; you can redistribute it and/or modify it
623 under the same terms as Perl itself.
624
625 =cut
626
627 1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26