/[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 109 - (show annotations)
Fri Aug 3 10:29:33 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 12103 byte(s)
tape implementation (still doesn't work)
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 $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 if ( $addr == 0x87ff ) {
447 return $self->read_tape;
448 }
449
450 $self->mmap_pixel( $addr, 0, $byte, 0 );
451 return $byte;
452 }
453
454 =head2 write
455
456 Write into emory
457
458 write( $address, $byte );
459
460 =cut
461
462 sub write {
463 my $self = shift;
464 my ($addr,$byte) = @_;
465 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
466
467 if ( $addr == 0x8800 ) {
468 warn sprintf "sound ignored: %x\n", $byte;
469 }
470
471 if ( $addr > 0xafff ) {
472 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
473 }
474
475 $self->mmap_pixel( $addr, $byte, 0, 0 );
476
477 $mem[$addr] = $byte;
478 return;
479 }
480
481 =head1 Command Line
482
483 Command-line debugging intrerface is implemented for communication with
484 emulated device
485
486 =head2 prompt
487
488 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
489
490 =cut
491
492 my $last = 'r 1';
493
494 sub prompt {
495 my $self = shift;
496 $self->app->sync;
497 my $a = shift;
498 print $self->hexdump( $a ),
499 $last ? "[$last] " : '',
500 "> ";
501 my $in = <STDIN>;
502 chomp($in);
503 warn "## prompt got: $in\n" if $self->debug;
504 $in ||= $last;
505 $last = $in;
506 return ( $in, split(/\s+/, $in) ) if $in;
507 }
508
509 =head2 cli
510
511 $orao->cli();
512
513 =cut
514
515 my $show_R = 0;
516
517 sub cli {
518 my $self = shift;
519 my $a = $PC || confess "no pc?";
520 my $run_for = 0;
521 warn $self->dump_R() if $show_R;
522 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
523 my $c = shift @v;
524 next unless defined($c);
525 my $v = shift @v;
526 $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
527 @v = map { hex($_) } @v;
528 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
529 if ( $c =~ m/^[qx]/i ) {
530 exit;
531 } elsif ( $c eq '?' ) {
532 my $t = $self->trace ? 'on' : 'off' ;
533 my $d = $self->debug ? 'on' : 'off' ;
534 warn <<__USAGE__;
535 Usage:
536
537 x|q\t\texit
538 e 6000 6010\tdump memory, +/- to walk forward/backward
539 m 1000 ff 00\tput ff 00 on 1000
540 j|u 1000\t\tjump (change pc)
541 r 42\t\trun 42 instruction opcodes
542 t\t\ttrace [$t]
543 d\t\tdebug [$d]
544
545 __USAGE__
546 warn $self->dump_R;
547 $last = '';
548 } elsif ( $c =~ m/^e/i ) {
549 $a = $v if defined($v);
550 my $to = shift @v;
551 $to = $a + 32 if ( ! $to || $to <= $a );
552 $to = 0xffff if ( $to > 0xffff );
553 my $lines = int( ($to - $a + 8) / 8 );
554 printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
555 while ( --$lines ) {
556 print $self->hexdump( $a );
557 $a += 8;
558 }
559 $last = '+';
560 $show_R = 0;
561 } elsif ( $c =~ m/^\+/ ) {
562 $a += 8;
563 $show_R = 0;
564 } elsif ( $c =~ m/^\-/ ) {
565 $a -= 8;
566 $show_R = 0;
567 } elsif ( $c =~ m/^m/i ) {
568 $a = $v if defined($v);
569 $self->poke_code( $a, @v );
570 printf "poke %d bytes at %04x\n", $#v + 1, $a;
571 $last = '+';
572 $show_R = 0;
573 } elsif ( $c =~ m/^l/i ) {
574 my $to = shift @v || 0x1000;
575 $a = $to;
576 $self->load_image( $v, $a );
577 $last = '';
578 } elsif ( $c =~ m/^s/i ) {
579 $self->save_dump( $v || 'mem.dump', @v );
580 $last = '';
581 } elsif ( $c =~ m/^r/i ) {
582 $run_for = $v || 1;
583 print "run_for $run_for instructions\n";
584 $show_R = 1;
585 last;
586 } elsif ( $c =~ m/^(u|j)/i ) {
587 my $to = $v || $a;
588 printf "set pc to %04x\n", $to;
589 $PC = $to; # remember for restart
590 $run_for = 1;
591 $last = "r $run_for";
592 $show_R = 1;
593 last;
594 } elsif ( $c =~ m/^tape/ ) {
595 if ( ! $v ) {
596 warn "ERROR: please specify tape name!\n";
597 } elsif ( ! -e $v ) {
598 warn "ERROR: tape $v: $!\n";
599 } else {
600 $self->load_tape( $v );
601 }
602 $last = '';
603 } elsif ( $c =~ m/^t/i ) {
604 $self->trace( not $self->trace );
605 print "trace ", $self->trace ? 'on' : 'off', "\n";
606 $last = '';
607 } elsif ( $c =~ m/^d/i ) {
608 $self->debug( not $self->debug );
609 print "debug ", $self->debug ? 'on' : 'off', "\n";
610 $last = '';
611 } else {
612 warn "# ignored $line\n" if ($line);
613 $last = '';
614 }
615 }
616
617 return $run_for;
618 }
619
620 =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