/[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 71 - (hide annotations)
Tue Jul 31 17:42:03 2007 UTC (16 years, 8 months ago) by dpavlin
Original Path: M6502/Orao.pm
File size: 9122 byte(s)
other minor tweaks: j ff89 works for the first time!
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 56 use base qw(Class::Accessor M6502 Screen Prefs);
14     __PACKAGE__->mk_accessors(qw(run_for));
15 dpavlin 29
16     =head1 NAME
17    
18     Orao - Orao emulator
19    
20     =head1 VERSION
21    
22     Version 0.02
23    
24     =cut
25    
26     our $VERSION = '0.02';
27    
28     =head1 SUMMARY
29    
30     Emulator or Orao 8-bit 6502 machine popular in Croatia
31    
32     =cut
33    
34 dpavlin 30 =head2 init
35    
36 dpavlin 56 Start emulator, open L<Screen>, load initial ROM images, and render memory
37 dpavlin 30
38     =cut
39    
40 dpavlin 32 our $orao;
41    
42 dpavlin 42 select(STDERR); $| = 1;
43    
44 dpavlin 30 sub init {
45     my $self = shift;
46 dpavlin 34 warn "Orao calling upstream init\n";
47 dpavlin 33 $self->SUPER::init( $self, @_ );
48 dpavlin 30
49 dpavlin 56 warn "Orao $Orao::VERSION emulation starting\n";
50 dpavlin 30
51     $self->open_screen;
52 dpavlin 33 $self->load_rom({
53     0x1000 => 'dump/SCRINV.BIN',
54     0xC000 => 'rom/BAS12.ROM',
55     0xE000 => 'rom/CRT12.ROM',
56     });
57 dpavlin 32
58 dpavlin 46 $PC = 0xDD11; # BC
59     # $PC = 0xC274; # MC
60 dpavlin 35
61 dpavlin 32 $orao = $self;
62    
63 dpavlin 33 # $self->prompt( 0x1000 );
64    
65 dpavlin 49 my ( $trace, $debug ) = ( $self->trace, $self->debug );
66 dpavlin 38 $self->trace( 0 );
67 dpavlin 49 $self->debug( 0 );
68 dpavlin 33
69 dpavlin 38 if ( $self->show_mem ) {
70 dpavlin 33
71 dpavlin 38 warn "rendering memory map\n";
72    
73     my @mmap = (
74     0x0000, 0x03FF, 'nulti blok',
75     0x0400, 0x5FFF, 'korisnièki RAM (23K)',
76     0x6000, 0x7FFF, 'video RAM',
77     0x8000, 0x9FFF, 'sistemske lokacije',
78     0xA000, 0xAFFF, 'ekstenzija',
79     0xB000, 0xBFFF, 'DOS',
80     0xC000, 0xDFFF, 'BASIC ROM',
81     0xE000, 0xFFFF, 'sistemski ROM',
82     );
83    
84     foreach my $i ( 0 .. $#mmap / 3 ) {
85     my $o = $i * 3;
86     my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
87     printf "%04x - %04x - %s\n", $from, $to, $desc;
88     for my $a ( $from .. $to ) {
89     if ( $a >= 0x6000 && $a < 0x8000 ) {
90     my $b = $self->read( $a );
91     $self->vram( $a - 0x6000, $b );
92     } else {
93     $self->read( $a );
94     }
95 dpavlin 36 }
96 dpavlin 34 }
97 dpavlin 38
98     } else {
99    
100     warn "rendering video memory\n";
101     for my $a ( 0x6000 .. 0x7fff ) {
102     $self->vram( $a - 0x6000, $mem[$a] );
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 49 warn "Orao init finished",
113     $self->trace ? ' trace' : '',
114     $self->debug ? ' debug' : '',
115     "\n";
116 dpavlin 38
117 dpavlin 30 }
118    
119 dpavlin 29 =head2 load_rom
120    
121     called to init memory and load initial rom images
122    
123     $orao->load_rom;
124    
125     =cut
126    
127     sub load_rom {
128 dpavlin 33 my ($self, $loaded_files) = @_;
129 dpavlin 29
130     #my $time_base = time();
131    
132     foreach my $addr ( sort keys %$loaded_files ) {
133     my $path = $loaded_files->{$addr};
134     $self->load_oraoemu( $path, $addr );
135     }
136     }
137    
138 dpavlin 61 # write chunk directly into memory, updateing vram if needed
139 dpavlin 46 sub _write_chunk {
140     my $self = shift;
141     my ( $addr, $chunk ) = @_;
142     $self->write_chunk( $addr, $chunk );
143     my $end = $addr + length($chunk);
144     my ( $f, $t ) = ( 0x6000, 0x7fff );
145    
146     if ( $end < $f || $addr >= $t ) {
147     warn "skip vram update\n";
148     return;
149     };
150    
151     $f = $addr if ( $addr > $f );
152     $t = $end if ( $end < $t );
153    
154     warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
155     foreach my $a ( $f .. $t ) {
156     $self->vram( $a - 0x6000 , $mem[ $a ] );
157     }
158     }
159    
160 dpavlin 61 =head2 load_oraoemu
161    
162     Load binary files, ROM images and Orao Emulator files
163    
164     $orao->load_oraoemu( '/path/to/file', 0x1000 );
165    
166     Returns true on success.
167    
168     =cut
169    
170 dpavlin 29 sub load_oraoemu {
171     my $self = shift;
172     my ( $path, $addr ) = @_;
173    
174 dpavlin 61 if ( ! -e $path ) {
175     warn "ERROR: file $path doesn't exist\n";
176     return;
177     }
178    
179 dpavlin 31 my $size = -s $path || confess "no size for $path: $!";
180 dpavlin 29
181     my $buff = read_file( $path );
182    
183     if ( $size == 65538 ) {
184     $addr = 0;
185 dpavlin 33 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
186 dpavlin 46 $self->_write_chunk( $addr, substr($buff,2) );
187 dpavlin 61 return 1;
188 dpavlin 29 } elsif ( $size == 32800 ) {
189     $addr = 0;
190 dpavlin 33 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
191 dpavlin 46 $self->_write_chunk( $addr, substr($buff,0x20) );
192 dpavlin 61 return 1;
193 dpavlin 29 }
194 dpavlin 33 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
195 dpavlin 61 $self->_write_chunk( $addr, $buff );
196     return 1;
197 dpavlin 29
198     my $chunk;
199    
200     my $pos = 0;
201    
202     while ( my $long = substr($buff,$pos,4) ) {
203     my @b = split(//, $long, 4);
204     $chunk .=
205     ( $b[3] || '' ) .
206     ( $b[2] || '' ) .
207     ( $b[1] || '' ) .
208     ( $b[0] || '' );
209     $pos += 4;
210     }
211    
212 dpavlin 46 $self->_write_chunk( $addr, $chunk );
213 dpavlin 29
214 dpavlin 61 return 1;
215 dpavlin 29 };
216    
217     =head2 save_dump
218    
219     $orao->save_dump( 'filename', $from, $to );
220    
221     =cut
222    
223     sub save_dump {
224     my $self = shift;
225    
226     my ( $path, $from, $to ) = @_;
227    
228     $from ||= 0;
229     $to ||= 0xffff;
230    
231     open(my $fh, '>', $path) || die "can't open $path: $!";
232     print $fh $self->read_chunk( $from, $to );
233     close($fh);
234    
235     my $size = -s $path;
236 dpavlin 32 warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
237 dpavlin 29 }
238    
239     =head2 hexdump
240    
241     $orao->hexdump( $address );
242    
243     =cut
244    
245     sub hexdump {
246     my $self = shift;
247     my $a = shift;
248     return sprintf(" %04x %s\n", $a,
249     join(" ",
250     map {
251 dpavlin 71 if ( defined($_) ) {
252     sprintf( "%02x", $_ )
253     } else {
254     ' '
255     }
256 dpavlin 47 } @mem[ $a .. $a+8 ]
257 dpavlin 29 )
258     );
259     }
260    
261 dpavlin 32 =head1 Memory management
262 dpavlin 30
263 dpavlin 32 Orao implements all I/O using mmap addresses. This was main reason why
264     L<Acme::6502> was just too slow to handle it.
265    
266     =cut
267    
268     =head2 read
269    
270     Read from memory
271    
272     $byte = read( $address );
273    
274     =cut
275    
276     sub read {
277 dpavlin 33 my $self = shift;
278 dpavlin 32 my ($addr) = @_;
279     my $byte = $mem[$addr];
280 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
281 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
282 dpavlin 32 return $byte;
283     }
284    
285     =head2 write
286    
287     Write into emory
288    
289     write( $address, $byte );
290    
291     =cut
292    
293     sub write {
294 dpavlin 33 my $self = shift;
295 dpavlin 32 my ($addr,$byte) = @_;
296 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
297 dpavlin 32
298     if ( $addr >= 0x6000 && $addr < 0x8000 ) {
299     $self->vram( $addr - 0x6000 , $byte );
300     }
301    
302     if ( $addr == 0x8800 ) {
303     warn sprintf "sound ignored: %x\n", $byte;
304     }
305    
306 dpavlin 52 if ( $addr > 0xafff ) {
307 dpavlin 65 warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
308     return;
309 dpavlin 52 }
310    
311 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
312 dpavlin 32
313     $mem[$addr] = $byte;
314 dpavlin 36 return;
315 dpavlin 32 }
316    
317 dpavlin 42 =head1 Command Line
318 dpavlin 32
319 dpavlin 42 Command-line debugging intrerface is implemented for communication with
320     emulated device
321    
322 dpavlin 50 =head2 prompt
323    
324 dpavlin 61 my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
325 dpavlin 50
326     =cut
327    
328     my $last = 'r 1';
329    
330     sub prompt {
331     my $self = shift;
332     $self->app->sync;
333     my $a = shift;
334     print STDERR $self->hexdump( $a ),
335     $last ? "[$last] " : '',
336     "> ";
337     my $in = <STDIN>;
338     chomp($in);
339     warn "## prompt got: $in\n" if $self->debug;
340     $in ||= $last;
341     $last = $in;
342 dpavlin 61 return ( $in, split(/\s+/, $in) ) if $in;
343 dpavlin 50 }
344    
345 dpavlin 42 =head2 cli
346    
347     $orao->cli();
348    
349     =cut
350    
351 dpavlin 68 my $show_R = 0;
352    
353 dpavlin 42 sub cli {
354     my $self = shift;
355     my $a = $PC || confess "no pc?";
356 dpavlin 68 warn $self->dump_R() if $show_R;
357 dpavlin 61 while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
358 dpavlin 42 my $c = shift @v;
359 dpavlin 61 next unless defined($c);
360 dpavlin 42 my $v = shift @v;
361     $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
362     @v = map { hex($_) } @v;
363 dpavlin 49 printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
364 dpavlin 42 if ( $c =~ m/^[qx]/i ) {
365     exit;
366     } elsif ( $c eq '?' ) {
367 dpavlin 50 my $t = $self->trace ? 'on' : 'off' ;
368     my $d = $self->debug ? 'on' : 'off' ;
369 dpavlin 42 warn <<__USAGE__;
370 dpavlin 50 Usage:
371    
372 dpavlin 42 x|q\t\texit
373     e 6000 6010\tdump memory, +/- to walk forward/backward
374     m 1000 ff 00\tput ff 00 on 1000
375     j|u 1000\t\tjump (change pc)
376     r 42\t\trun 42 instruction opcodes
377 dpavlin 50 t\t\ttrace [$t]
378     d\t\tdebug [$d]
379    
380 dpavlin 42 __USAGE__
381 dpavlin 68 warn $self->dump_R;
382 dpavlin 42 } elsif ( $c =~ m/^e/i ) {
383 dpavlin 49 $a = $v if defined($v);
384 dpavlin 42 my $to = shift @v;
385     $to = $a + 32 if ( ! $to || $to <= $a );
386 dpavlin 71 $to = 0xffff if ( $to > 0xffff );
387 dpavlin 59 my $lines = int( ($to - $a + 8) / 8 );
388     printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
389     while ( --$lines ) {
390 dpavlin 42 print $self->hexdump( $a );
391     $a += 8;
392     }
393     $last = '+';
394 dpavlin 68 $show_R = 0;
395 dpavlin 42 } elsif ( $c =~ m/^\+/ ) {
396     $a += 8;
397 dpavlin 68 $show_R = 0;
398 dpavlin 42 } elsif ( $c =~ m/^\-/ ) {
399     $a -= 8;
400 dpavlin 68 $show_R = 0;
401 dpavlin 42 } elsif ( $c =~ m/^m/i ) {
402 dpavlin 70 $a = $v if defined($v);
403 dpavlin 42 $self->poke_code( $a, @v );
404     printf "poke %d bytes at %04x\n", $#v + 1, $a;
405 dpavlin 50 $last = '+';
406 dpavlin 68 $show_R = 0;
407 dpavlin 42 } elsif ( $c =~ m/^l/i ) {
408     my $to = shift @v || 0x1000;
409     $a = $to;
410     $self->load_oraoemu( $v, $a );
411 dpavlin 50 $last = '';
412 dpavlin 42 } elsif ( $c =~ m/^s/i ) {
413     $self->save_dump( $v || 'mem.dump', @v );
414 dpavlin 50 $last = '';
415 dpavlin 42 } elsif ( $c =~ m/^r/i ) {
416     $run_for = $v || 1;
417     print "run_for $run_for instructions\n";
418 dpavlin 68 $show_R = 1;
419 dpavlin 42 last;
420     } elsif ( $c =~ m/^(u|j)/ ) {
421     my $to = $v || $a;
422     printf "set pc to %04x\n", $to;
423     $PC = $to; # remember for restart
424     $run_for = 1;
425 dpavlin 62 $last = "r $run_for";
426 dpavlin 68 $show_R = 1;
427 dpavlin 42 last;
428     } elsif ( $c =~ m/^t/ ) {
429     $self->trace( not $self->trace );
430     print "trace ", $self->trace ? 'on' : 'off', "\n";
431 dpavlin 64 $last = '';
432 dpavlin 49 } elsif ( $c =~ m/^d/ ) {
433     $self->debug( not $self->debug );
434     print "debug ", $self->debug ? 'on' : 'off', "\n";
435 dpavlin 64 $last = '';
436 dpavlin 42 } else {
437 dpavlin 61 warn "# ignored $line\n" if ($line);
438     $last = '';
439 dpavlin 42 }
440     }
441    
442     }
443    
444 dpavlin 29 =head1 AUTHOR
445    
446     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
447    
448     =head1 BUGS
449    
450     =head1 ACKNOWLEDGEMENTS
451    
452     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
453     info about this machine (and even hardware implementation from 2007).
454    
455     =head1 COPYRIGHT & LICENSE
456    
457     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
458    
459     This program is free software; you can redistribute it and/or modify it
460     under the same terms as Perl itself.
461    
462     =cut
463    
464     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26