/[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 115 - (hide annotations)
Fri Aug 3 20:04:00 2007 UTC (16 years, 7 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 12388 byte(s)
fix singleton var name in preparation of merge
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 34 use M6502;
12 dpavlin 29
13 dpavlin 109 use base qw(Class::Accessor M6502 Screen Prefs Tape);
14 dpavlin 96 __PACKAGE__->mk_accessors(qw(booted));
15 dpavlin 29
16     =head1 NAME
17    
18     Orao - Orao emulator
19    
20     =head1 VERSION
21    
22 dpavlin 95 Version 0.04
23 dpavlin 29
24     =cut
25    
26 dpavlin 95 our $VERSION = '0.04';
27 dpavlin 29
28     =head1 SUMMARY
29    
30     Emulator or Orao 8-bit 6502 machine popular in Croatia
31    
32     =cut
33    
34 dpavlin 95 =head1 FUNCTIONS
35    
36 dpavlin 82 =head2 boot
37 dpavlin 30
38 dpavlin 56 Start emulator, open L<Screen>, load initial ROM images, and render memory
39 dpavlin 30
40 dpavlin 115 my $emu = Orao->new({});
41     $emu->boot;
42 dpavlin 82
43 dpavlin 30 =cut
44    
45 dpavlin 115 our $emu;
46 dpavlin 32
47 dpavlin 42 select(STDERR); $| = 1;
48    
49 dpavlin 82 sub boot {
50 dpavlin 30 my $self = shift;
51 dpavlin 34 warn "Orao calling upstream init\n";
52 dpavlin 90 $self->SUPER::init(
53     read => sub { $self->read( @_ ) },
54     write => sub { $self->write( @_ ) },
55     );
56 dpavlin 30
57 dpavlin 56 warn "Orao $Orao::VERSION emulation starting\n";
58 dpavlin 30
59 dpavlin 90 warn "emulating ", $#mem, " bytes of memory\n";
60    
61 dpavlin 30 $self->open_screen;
62 dpavlin 33 $self->load_rom({
63     0x1000 => 'dump/SCRINV.BIN',
64 dpavlin 76 # should be 0x6000, but oraoemu has 2 byte prefix
65     0x5FFE => 'dump/screen.dmp',
66 dpavlin 106 # 0xC000 => 'rom/BAS12.ROM',
67     # 0xE000 => 'rom/CRT12.ROM',
68     0xC000 => 'rom/BAS13.ROM',
69     0xE000 => 'rom/CRT13.ROM',
70 dpavlin 33 });
71 dpavlin 32
72 dpavlin 73 # $PC = 0xDD11; # BC
73 dpavlin 46 # $PC = 0xC274; # MC
74 dpavlin 35
75 dpavlin 78 $PC = 0xff89;
76    
77 dpavlin 115 $emu = $self;
78 dpavlin 32
79 dpavlin 33 # $self->prompt( 0x1000 );
80    
81 dpavlin 49 my ( $trace, $debug ) = ( $self->trace, $self->debug );
82 dpavlin 38 $self->trace( 0 );
83 dpavlin 49 $self->debug( 0 );
84 dpavlin 33
85 dpavlin 107 warn "rendering video memory\n";
86     $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
87 dpavlin 73
88 dpavlin 38 if ( $self->show_mem ) {
89 dpavlin 33
90 dpavlin 38 warn "rendering memory map\n";
91    
92 dpavlin 76 $self->render_mem( @mem );
93    
94 dpavlin 38 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 dpavlin 33 }
106 dpavlin 38 $self->sync;
107     $self->trace( $trace );
108 dpavlin 49 $self->debug( $debug );
109 dpavlin 33
110 dpavlin 39 #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
111 dpavlin 34
112 dpavlin 82 warn "Orao boot finished",
113 dpavlin 49 $self->trace ? ' trace' : '',
114     $self->debug ? ' debug' : '',
115     "\n";
116 dpavlin 38
117 dpavlin 82 M6502::reset();
118    
119 dpavlin 95 $self->booted( 1 );
120 dpavlin 30 }
121    
122 dpavlin 95 =head2 run
123    
124     Run interactive emulation loop
125    
126 dpavlin 115 $emu->run;
127 dpavlin 95
128     =cut
129    
130     sub run {
131     my $self = shift;
132    
133     $self->boot if ( ! $self->booted );
134 dpavlin 110
135     $self->load_tape( '../oraoigre/bdash.tap' );
136    
137 dpavlin 96 $self->loop;
138 dpavlin 95 };
139    
140     =head1 Helper functions
141    
142 dpavlin 29 =head2 load_rom
143    
144     called to init memory and load initial rom images
145    
146 dpavlin 115 $emu->load_rom;
147 dpavlin 29
148     =cut
149    
150     sub load_rom {
151 dpavlin 33 my ($self, $loaded_files) = @_;
152 dpavlin 29
153     #my $time_base = time();
154    
155     foreach my $addr ( sort keys %$loaded_files ) {
156     my $path = $loaded_files->{$addr};
157 dpavlin 94 $self->load_image( $path, $addr );
158 dpavlin 29 }
159     }
160    
161 dpavlin 61 # write chunk directly into memory, updateing vram if needed
162 dpavlin 46 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 dpavlin 107 $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
179 dpavlin 77 $self->render_mem( @mem ) if $self->show_mem;
180 dpavlin 46 }
181    
182 dpavlin 94 =head2 load_image
183 dpavlin 61
184     Load binary files, ROM images and Orao Emulator files
185    
186 dpavlin 115 $emu->load_image( '/path/to/file', 0x1000 );
187 dpavlin 61
188     Returns true on success.
189    
190     =cut
191    
192 dpavlin 94 sub load_image {
193 dpavlin 29 my $self = shift;
194     my ( $path, $addr ) = @_;
195    
196 dpavlin 61 if ( ! -e $path ) {
197     warn "ERROR: file $path doesn't exist\n";
198     return;
199     }
200    
201 dpavlin 31 my $size = -s $path || confess "no size for $path: $!";
202 dpavlin 29
203     my $buff = read_file( $path );
204    
205     if ( $size == 65538 ) {
206     $addr = 0;
207 dpavlin 33 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
208 dpavlin 46 $self->_write_chunk( $addr, substr($buff,2) );
209 dpavlin 61 return 1;
210 dpavlin 29 } elsif ( $size == 32800 ) {
211     $addr = 0;
212 dpavlin 33 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
213 dpavlin 46 $self->_write_chunk( $addr, substr($buff,0x20) );
214 dpavlin 61 return 1;
215 dpavlin 29 }
216 dpavlin 33 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
217 dpavlin 61 $self->_write_chunk( $addr, $buff );
218     return 1;
219 dpavlin 29
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 dpavlin 46 $self->_write_chunk( $addr, $chunk );
235 dpavlin 29
236 dpavlin 61 return 1;
237 dpavlin 29 };
238    
239     =head2 save_dump
240    
241 dpavlin 115 $emu->save_dump( 'filename', $from, $to );
242 dpavlin 29
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 dpavlin 32 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
259 dpavlin 29 }
260    
261     =head2 hexdump
262    
263 dpavlin 115 $emu->hexdump( $address );
264 dpavlin 29
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 dpavlin 71 if ( defined($_) ) {
274     sprintf( "%02x", $_ )
275     } else {
276     ' '
277     }
278 dpavlin 47 } @mem[ $a .. $a+8 ]
279 dpavlin 29 )
280     );
281     }
282    
283 dpavlin 32 =head1 Memory management
284 dpavlin 30
285 dpavlin 32 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 dpavlin 105 my $keyboard_none = 255;
299    
300 dpavlin 98 my $keyboard = {
301     0x87FC => {
302     'right' => 16,
303     'down' => 128,
304     'up' => 192,
305     'left' => 224,
306     'backspace' => 224,
307     },
308 dpavlin 103 0x87FD => sub {
309     my ( $self, $key ) = @_;
310     if ( $key eq 'return' ) {
311 dpavlin 101 M6502::_write( 0xfc, 13 );
312 dpavlin 105 warn "return\n";
313 dpavlin 98 return 0;
314 dpavlin 105 } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
315     warn "ctrl\n";
316 dpavlin 103 return 16;
317     }
318 dpavlin 105 return $keyboard_none;
319 dpavlin 98 },
320     0x87FA => {
321     'f4' => 16,
322     'f3' => 128,
323     'f2' => 192,
324     'f1' => 224,
325     },
326 dpavlin 103 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 dpavlin 105 warn "shift\n";
332 dpavlin 103 return 16;
333 dpavlin 110 # } elsif ( $self->tape ) {
334     # warn "has tape!";
335     # return 0;
336 dpavlin 103 }
337 dpavlin 105 return $keyboard_none;
338 dpavlin 98 },
339     0x87F6 => {
340     '6' => 16,
341     't' => 128,
342 dpavlin 105 'y' => 192, # hr: z
343 dpavlin 98 '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 dpavlin 105 ',' => 32, # <
377     '.' => 16, # >
378 dpavlin 98 },
379     0x877E => {
380 dpavlin 105 'z' => 16, # hr:y
381 dpavlin 98 '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 dpavlin 102 'v' => 16,
398 dpavlin 98 },
399     0x85FE => {
400 dpavlin 105 '<' => 16, # :
401     '\\' => 128, # ¾
402     '\'' => 192, # æ
403     ';' => 224, # è
404 dpavlin 98 },
405     0x85FF => {
406     '/' => 32,
407 dpavlin 105 'f11' => 16, # ^
408 dpavlin 98 },
409     0x83FE => {
410 dpavlin 105 'f12' => 16, # ;
411     '[' => 128, # ¹
412     ']' => 192, # ð
413 dpavlin 98 'p' => 224,
414     },
415     0x83FF => {
416     '-' => 32,
417     '0' => 16,
418     },
419     };
420    
421 dpavlin 32 sub read {
422 dpavlin 33 my $self = shift;
423 dpavlin 32 my ($addr) = @_;
424     my $byte = $mem[$addr];
425 dpavlin 90 confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
426 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
427 dpavlin 78
428     # keyboard
429    
430 dpavlin 105 if ( defined( $keyboard->{$addr} ) ) {
431 dpavlin 97 warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
432 dpavlin 99 my $key = $self->key_pressed;
433     if ( defined($key) ) {
434 dpavlin 103 my $ret = $keyboard_none;
435 dpavlin 98 my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
436 dpavlin 103 if ( ref($r) eq 'CODE' ) {
437     $ret = $r->($self, $key);
438 dpavlin 105 } elsif ( defined($r->{$key}) ) {
439     $ret = $r->{$key};
440 dpavlin 98 if ( ref($ret) eq 'CODE' ) {
441 dpavlin 103 $ret = $ret->($self);
442 dpavlin 98 }
443     } else {
444 dpavlin 99 warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
445 dpavlin 98 }
446 dpavlin 105 warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
447     return $ret;
448 dpavlin 98 }
449 dpavlin 101 return $keyboard_none;
450 dpavlin 78 }
451    
452 dpavlin 109 if ( $addr == 0x87ff ) {
453     return $self->read_tape;
454     }
455    
456 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
457 dpavlin 32 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 dpavlin 33 my $self = shift;
470 dpavlin 32 my ($addr,$byte) = @_;
471 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
472 dpavlin 32
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 115 my ( $entered_line, @p ) = $emu->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 dpavlin 115 $emu->cli();
518 dpavlin 42
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 110 } elsif ( $c =~ m/^re/i ) { # reset
588     M6502::reset();
589     $last = 'r 1';
590     } elsif ( $c =~ m/^r/i ) { # run
591 dpavlin 42 $run_for = $v || 1;
592     print "run_for $run_for instructions\n";
593 dpavlin 68 $show_R = 1;
594 dpavlin 42 last;
595 dpavlin 109 } elsif ( $c =~ m/^(u|j)/i ) {
596 dpavlin 42 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 dpavlin 109 } elsif ( $c =~ m/^tape/ ) {
604 dpavlin 110 if ( $c =~ m/rate/ ) {
605     $self->tape_rate( $v );
606     warn "will read table with rate $v\n";
607     } elsif ( ! $v ) {
608 dpavlin 109 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 dpavlin 42 $self->trace( not $self->trace );
617     print "trace ", $self->trace ? 'on' : 'off', "\n";
618 dpavlin 64 $last = '';
619 dpavlin 109 } elsif ( $c =~ m/^d/i ) {
620 dpavlin 49 $self->debug( not $self->debug );
621     print "debug ", $self->debug ? 'on' : 'off', "\n";
622 dpavlin 64 $last = '';
623 dpavlin 42 } else {
624 dpavlin 61 warn "# ignored $line\n" if ($line);
625     $last = '';
626 dpavlin 42 }
627     }
628    
629 dpavlin 96 return $run_for;
630 dpavlin 42 }
631    
632 dpavlin 29 =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