/[VRac]/M6502/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 /M6502/Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 117 - (show annotations)
Fri Aug 3 22:46:03 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 12389 byte(s)
don't load tape by default
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 Tape);
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 $emu = Orao->new({});
41 $emu->boot;
42
43 =cut
44
45 our $emu;
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 $emu = $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 $emu->run;
127
128 =cut
129
130 sub run {
131 my $self = shift;
132
133 $self->boot if ( ! $self->booted );
134
135 # $self->load_tape( '../oraoigre/bdash.tap' );
136
137 $self->loop;
138 };
139
140 =head1 Helper functions
141
142 =head2 load_rom
143
144 called to init memory and load initial rom images
145
146 $emu->load_rom;
147
148 =cut
149
150 sub load_rom {
151 my ($self, $loaded_files) = @_;
152
153 #my $time_base = time();
154
155 foreach my $addr ( sort keys %$loaded_files ) {
156 my $path = $loaded_files->{$addr};
157 $self->load_image( $path, $addr );
158 }
159 }
160
161 # write chunk directly into memory, updateing vram if needed
162 sub _write_chunk {
163 my $self = shift;
164 my ( $addr, $chunk ) = @_;
165 $self->write_chunk( $addr, $chunk );
166 my $end = $addr + length($chunk);
167 my ( $f, $t ) = ( 0x6000, 0x7fff );
168
169 if ( $end < $f || $addr >= $t ) {
170 warn "skip vram update\n";
171 return;
172 };
173
174 $f = $addr if ( $addr > $f );
175 $t = $end if ( $end < $t );
176
177 warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
178 $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
179 $self->render_mem( @mem ) if $self->show_mem;
180 }
181
182 =head2 load_image
183
184 Load binary files, ROM images and Orao Emulator files
185
186 $emu->load_image( '/path/to/file', 0x1000 );
187
188 Returns true on success.
189
190 =cut
191
192 sub load_image {
193 my $self = shift;
194 my ( $path, $addr ) = @_;
195
196 if ( ! -e $path ) {
197 warn "ERROR: file $path doesn't exist\n";
198 return;
199 }
200
201 my $size = -s $path || confess "no size for $path: $!";
202
203 my $buff = read_file( $path );
204
205 if ( $size == 65538 ) {
206 $addr = 0;
207 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
208 $self->_write_chunk( $addr, substr($buff,2) );
209 return 1;
210 } elsif ( $size == 32800 ) {
211 $addr = 0;
212 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
213 $self->_write_chunk( $addr, substr($buff,0x20) );
214 return 1;
215 }
216 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
217 $self->_write_chunk( $addr, $buff );
218 return 1;
219
220 my $chunk;
221
222 my $pos = 0;
223
224 while ( my $long = substr($buff,$pos,4) ) {
225 my @b = split(//, $long, 4);
226 $chunk .=
227 ( $b[3] || '' ) .
228 ( $b[2] || '' ) .
229 ( $b[1] || '' ) .
230 ( $b[0] || '' );
231 $pos += 4;
232 }
233
234 $self->_write_chunk( $addr, $chunk );
235
236 return 1;
237 };
238
239 =head2 save_dump
240
241 $emu->save_dump( 'filename', $from, $to );
242
243 =cut
244
245 sub save_dump {
246 my $self = shift;
247
248 my ( $path, $from, $to ) = @_;
249
250 $from ||= 0;
251 $to ||= 0xffff;
252
253 open(my $fh, '>', $path) || die "can't open $path: $!";
254 print $fh $self->read_chunk( $from, $to );
255 close($fh);
256
257 my $size = -s $path;
258 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
259 }
260
261 =head2 hexdump
262
263 $emu->hexdump( $address );
264
265 =cut
266
267 sub hexdump {
268 my $self = shift;
269 my $a = shift;
270 return sprintf(" %04x %s\n", $a,
271 join(" ",
272 map {
273 if ( defined($_) ) {
274 sprintf( "%02x", $_ )
275 } else {
276 ' '
277 }
278 } @mem[ $a .. $a+8 ]
279 )
280 );
281 }
282
283 =head1 Memory management
284
285 Orao implements all I/O using mmap addresses. This was main reason why
286 L<Acme::6502> was just too slow to handle it.
287
288 =cut
289
290 =head2 read
291
292 Read from memory
293
294 $byte = read( $address );
295
296 =cut
297
298 my $keyboard_none = 255;
299
300 my $keyboard = {
301 0x87FC => {
302 'right' => 16,
303 'down' => 128,
304 'up' => 192,
305 'left' => 224,
306 'backspace' => 224,
307 },
308 0x87FD => sub {
309 my ( $self, $key ) = @_;
310 if ( $key eq 'return' ) {
311 M6502::_write( 0xfc, 13 );
312 warn "return\n";
313 return 0;
314 } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
315 warn "ctrl\n";
316 return 16;
317 }
318 return $keyboard_none;
319 },
320 0x87FA => {
321 'f4' => 16,
322 'f3' => 128,
323 'f2' => 192,
324 'f1' => 224,
325 },
326 0x87FB => sub {
327 my ( $self, $key ) = @_;
328 if ( $key eq 'space' ) {
329 return 32;
330 } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
331 warn "shift\n";
332 return 16;
333 # } elsif ( $self->tape ) {
334 # warn "has tape!";
335 # return 0;
336 }
337 return $keyboard_none;
338 },
339 0x87F6 => {
340 '6' => 16,
341 't' => 128,
342 'y' => 192, # hr: z
343 'r' => 224,
344 },
345 0x87F7 => {
346 '5' => 32,
347 '4' => 16,
348 },
349 0x87EE => {
350 '7' => 16,
351 'u' => 128,
352 'i' => 192,
353 'o' => 224,
354 },
355 0x87EF => {
356 '8' => 32,
357 '9' => 16,
358 },
359 0x87DE => {
360 '1' => 16,
361 'w' => 128,
362 'q' => 192,
363 'e' => 224,
364 },
365 0x87DF => {
366 '2' => 32,
367 '3' => 16,
368 },
369 0x87BE => {
370 'm' => 16,
371 'k' => 128,
372 'j' => 192,
373 'l' => 224,
374 },
375 0x87BF => {
376 ',' => 32, # <
377 '.' => 16, # >
378 },
379 0x877E => {
380 'z' => 16, # hr:y
381 's' => 128,
382 'a' => 192,
383 'd' => 224,
384 },
385 0x877F => {
386 'x' => 32,
387 'c' => 16,
388 },
389 0x86FE => {
390 'n' => 16,
391 'g' => 128,
392 'h' => 192,
393 'f' => 224,
394 },
395 0x86FF => {
396 'b' => 32,
397 'v' => 16,
398 },
399 0x85FE => {
400 '<' => 16, # :
401 '\\' => 128, # ¾
402 '\'' => 192, # æ
403 ';' => 224, # è
404 },
405 0x85FF => {
406 '/' => 32,
407 'f11' => 16, # ^
408 },
409 0x83FE => {
410 'f12' => 16, # ;
411 '[' => 128, # ¹
412 ']' => 192, # ð
413 'p' => 224,
414 },
415 0x83FF => {
416 '-' => 32,
417 '0' => 16,
418 },
419 };
420
421 sub read {
422 my $self = shift;
423 my ($addr) = @_;
424 my $byte = $mem[$addr];
425 confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
426 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
427
428 # keyboard
429
430 if ( defined( $keyboard->{$addr} ) ) {
431 warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
432 my $key = $self->key_pressed;
433 if ( defined($key) ) {
434 my $ret = $keyboard_none;
435 my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
436 if ( ref($r) eq 'CODE' ) {
437 $ret = $r->($self, $key);
438 } elsif ( defined($r->{$key}) ) {
439 $ret = $r->{$key};
440 if ( ref($ret) eq 'CODE' ) {
441 $ret = $ret->($self);
442 }
443 } else {
444 warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
445 }
446 warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
447 return $ret;
448 }
449 return $keyboard_none;
450 }
451
452 if ( $addr == 0x87ff ) {
453 return $self->read_tape;
454 }
455
456 $self->mmap_pixel( $addr, 0, $byte, 0 );
457 return $byte;
458 }
459
460 =head2 write
461
462 Write into emory
463
464 write( $address, $byte );
465
466 =cut
467
468 sub write {
469 my $self = shift;
470 my ($addr,$byte) = @_;
471 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
472
473 if ( $addr == 0x8800 ) {
474 warn sprintf "sound ignored: %x\n", $byte;
475 }
476
477 if ( $addr > 0xafff ) {
478 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
479 }
480
481 $self->mmap_pixel( $addr, $byte, 0, 0 );
482
483 $mem[$addr] = $byte;
484 return;
485 }
486
487 =head1 Command Line
488
489 Command-line debugging intrerface is implemented for communication with
490 emulated device
491
492 =head2 prompt
493
494 my ( $entered_line, @p ) = $emu->prompt( $address, $last_command );
495
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 print $self->hexdump( $a ),
505 $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 return ( $in, split(/\s+/, $in) ) if $in;
513 }
514
515 =head2 cli
516
517 $emu->cli();
518
519 =cut
520
521 my $show_R = 0;
522
523 sub cli {
524 my $self = shift;
525 my $a = $PC || confess "no pc?";
526 my $run_for = 0;
527 warn $self->dump_R() if $show_R;
528 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
529 my $c = shift @v;
530 next unless defined($c);
531 my $v = shift @v;
532 $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
533 @v = map { hex($_) } @v;
534 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
535 if ( $c =~ m/^[qx]/i ) {
536 exit;
537 } elsif ( $c eq '?' ) {
538 my $t = $self->trace ? 'on' : 'off' ;
539 my $d = $self->debug ? 'on' : 'off' ;
540 warn <<__USAGE__;
541 Usage:
542
543 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 t\t\ttrace [$t]
549 d\t\tdebug [$d]
550
551 __USAGE__
552 warn $self->dump_R;
553 $last = '';
554 } elsif ( $c =~ m/^e/i ) {
555 $a = $v if defined($v);
556 my $to = shift @v;
557 $to = $a + 32 if ( ! $to || $to <= $a );
558 $to = 0xffff if ( $to > 0xffff );
559 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 print $self->hexdump( $a );
563 $a += 8;
564 }
565 $last = '+';
566 $show_R = 0;
567 } elsif ( $c =~ m/^\+/ ) {
568 $a += 8;
569 $show_R = 0;
570 } elsif ( $c =~ m/^\-/ ) {
571 $a -= 8;
572 $show_R = 0;
573 } elsif ( $c =~ m/^m/i ) {
574 $a = $v if defined($v);
575 $self->poke_code( $a, @v );
576 printf "poke %d bytes at %04x\n", $#v + 1, $a;
577 $last = '+';
578 $show_R = 0;
579 } elsif ( $c =~ m/^l/i ) {
580 my $to = shift @v || 0x1000;
581 $a = $to;
582 $self->load_image( $v, $a );
583 $last = '';
584 } elsif ( $c =~ m/^s/i ) {
585 $self->save_dump( $v || 'mem.dump', @v );
586 $last = '';
587 } elsif ( $c =~ m/^re/i ) { # reset
588 M6502::reset();
589 $last = 'r 1';
590 } elsif ( $c =~ m/^r/i ) { # run
591 $run_for = $v || 1;
592 print "run_for $run_for instructions\n";
593 $show_R = 1;
594 last;
595 } elsif ( $c =~ m/^(u|j)/i ) {
596 my $to = $v || $a;
597 printf "set pc to %04x\n", $to;
598 $PC = $to; # remember for restart
599 $run_for = 1;
600 $last = "r $run_for";
601 $show_R = 1;
602 last;
603 } elsif ( $c =~ m/^tape/ ) {
604 if ( $c =~ m/rate/ ) {
605 $self->tape_rate( $v );
606 warn "will read table with rate $v\n";
607 } elsif ( ! $v ) {
608 warn "ERROR: please specify tape name!\n";
609 } elsif ( ! -e $v ) {
610 warn "ERROR: tape $v: $!\n";
611 } else {
612 $self->load_tape( $v );
613 }
614 $last = '';
615 } elsif ( $c =~ m/^t/i ) {
616 $self->trace( not $self->trace );
617 print "trace ", $self->trace ? 'on' : 'off', "\n";
618 $last = '';
619 } elsif ( $c =~ m/^d/i ) {
620 $self->debug( not $self->debug );
621 print "debug ", $self->debug ? 'on' : 'off', "\n";
622 $last = '';
623 } else {
624 warn "# ignored $line\n" if ($line);
625 $last = '';
626 }
627 }
628
629 return $run_for;
630 }
631
632 =head1 AUTHOR
633
634 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
635
636 =head1 BUGS
637
638 =head1 ACKNOWLEDGEMENTS
639
640 See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
641 info about this machine (and even hardware implementation from 2007).
642
643 =head1 COPYRIGHT & LICENSE
644
645 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
646
647 This program is free software; you can redistribute it and/or modify it
648 under the same terms as Perl itself.
649
650 =cut
651
652 1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26