DASM
|
00001 #!/usr/bin/perl -w 00002 ## 00003 # DCPU-16 assembler context class. 00004 # 00005 # Holds the current state of our assembler context as we build and the methods 00006 # to perform the assembly. We manage a number of IO objects which can provide 00007 # file read and write formats. The IO objects can process the files based on 00008 # their extension, or be explicitly requested to read or write data by 00009 # giving their type. 00010 # 00011 # Possible use: 00012 # 00013 # @code 00014 # my $dasm = new DASM(); 00015 # $dasm->readfile($inputname); 00016 # $dasm->writefile($output); 00017 # $dasm->dump(); 00018 # @endcode 00019 # 00020 # @file 00021 # @author Justin Fletcher 00022 # 00023 00024 package DASM; 00025 00026 use Carp; 00027 use DCPU; 00028 00029 ## Whether we're debugging the store operations 00030 my $debug_store = 0; 00031 00032 ## Whether we're debugging the assembly operations 00033 my $debug_asm = 0; 00034 00035 ## Whether we're debugging the symbols 00036 my $debug_sym = 0; 00037 00038 00039 ## 00040 # Construct a new assembler object. 00041 # 00042 # @param[in] $proto This class object, or prototype to add to 00043 # 00044 # @return Assembler object 00045 sub new 00046 { 00047 my $proto = shift; 00048 my $class = ref($proto) || $proto; 00049 my $self = {}; 00050 00051 bless $self, $class; 00052 00053 # A list of values to store in the core 00054 # Address => value 00055 $self->{'core'} = {}; 00056 00057 # Mapping of symbol to addresses, values or constants 00058 # in the form of a hashref: 00059 # 'type' => 'address', 'constant' 00060 # 'value' => the value 00061 $self->{'symbols'} = {}; 00062 00063 # Relocations within the core 00064 # Relocation types are: 00065 # 'symbol' => symbol to relocate by 00066 $self->{'relocations'} = {}; 00067 00068 # Current PC whilst assembling 00069 $self->{'pc'} = 0; 00070 00071 ## 00072 # Hashref of IO types that we can process, keyed by name. 00073 # The value is an initialised object. 00074 $self->{'io'} = {}; 00075 00076 ## 00077 # Hashref of all the hardware devices we have registered, keyed 00078 # by the address they live at. Each value is an object which contains 00079 # the definition of the hardware. 00080 $self->{'hardware'} = {}; 00081 00082 # Initialise the IO lists 00083 $self->initio(); 00084 00085 # Stack of locations we've been invoked from. 00086 # The stack is a list of hashrefs in the form: 00087 # 'line' => line number 00088 # 'file' => filename 00089 $self->{'sourcestack'} = [ { 'line' => 0, 00090 'file' => '[toplevel]' } ]; 00091 00092 return $self; 00093 } 00094 00095 ## 00096 # Initialise all the IO types so that we know about them. 00097 # 00098 # We try to initialise all the objects in the DASMIO directory, and for 00099 # those objects we create an object. 00100 # 00101 # @param[in] $self DASM object 00102 sub initio 00103 { 00104 my ($self) = @_; 00105 my %io; 00106 00107 opendir(my $dirfh, "DASMIO") || return; 00108 while (my $file = readdir($dirfh)) 00109 { 00110 if ($file =~ /^(.*)\.pm$/) 00111 { 00112 my $ioname = $1; 00113 my $ioh = eval " 00114 require 'DASMIO/$ioname.pm'; 00115 DASMIO::$ioname->new(\$self); 00116 "; 00117 if ($@) 00118 { 00119 print STDERR "Failed to create DASMIO::$ioname - $@\n"; 00120 } 00121 else 00122 { 00123 $io{$ioname} = $ioh; 00124 $ioh->{'name'} = $ioname; 00125 } 00126 } 00127 } 00128 closedir($dirfh); 00129 00130 $self->{'io'} = \%io; 00131 } 00132 00133 00134 ## 00135 # List the IO methods available. 00136 # 00137 # @param[in] $self DASM object 00138 # 00139 # @return arrayref of IO objects 00140 sub listio 00141 { 00142 my ($self) = @_; 00143 return [ sort { $a->{'name'} cmp $b->{'name'} } values %{ $self->{'io'} } ]; 00144 } 00145 00146 00147 ## 00148 # Find the correct IO object to use for a given file operation. 00149 # 00150 # If a type is explicitly given, we attempt to use it. 00151 # If not, each io object is queried to identify whether they understand the 00152 # file by its name. 00153 # 00154 # If no type is recognised, we die. 00155 # 00156 # @param[in] $self DASM object 00157 # @param[in] $filename Filename to access 00158 # @param[in] $type Type name (optional) 00159 # @param[in] $access Access type; 'read' or 'write' 00160 # 00161 # @return IO object for accessing the file 00162 sub findio 00163 { 00164 my ($self, $filename, $type, $access) = @_; 00165 my $io; 00166 00167 # First try to recognise based on the type 00168 if (defined $type && 00169 $type ne '') 00170 { 00171 if (!defined $self->{'io'}->{$type}) 00172 { 00173 $self->error("Unknown file IO type: unrecognised type '$type'"); 00174 } 00175 00176 $io = $self->{'io'}->{$type}; 00177 } 00178 elsif (defined $filename) 00179 { 00180 # No type was given; we should determine the type by the name 00181 for my $type (sort keys %{ $self->{'io'} }) 00182 { 00183 if ($self->{'io'}->{$type}->identify($filename, $access)) 00184 { 00185 $io = $self->{'io'}->{$type}; 00186 last; 00187 } 00188 } 00189 00190 if (!defined $io) 00191 { 00192 $self->error("Unknown file IO: unrecognised filename '$filename' for $access"); 00193 } 00194 } 00195 else 00196 { 00197 $self->error("Unknown file IO: no filename or type given"); 00198 } 00199 00200 return $io; 00201 } 00202 00203 00204 ## 00205 # Read a file of a given type. 00206 # 00207 # If the type cannot be found, or some other error occurs, we die. 00208 # 00209 # @param[in] $self DASM object 00210 # @param[in] $filename Filename to read 00211 # @param[in] $type Type of file to read (a DASMIO object) 00212 sub readfile 00213 { 00214 my ($self, $filename, $type) = @_; 00215 my $io = $self->findio($filename, $type, 'read'); 00216 00217 my $content = ""; 00218 $self->error("Cannot read $filename") if (!-f $filename); 00219 open(my $fh, "<", $filename); 00220 sysread $fh, $content, -s $filename; 00221 close($fh); 00222 00223 $self->startfile($filename); 00224 if ($io->can('read')) 00225 { 00226 # If they provide a routine to slurp the entire content in, 00227 # we use it. 00228 $io->read($content, $filename); 00229 } 00230 elsif ($io->can('parseline')) 00231 { 00232 # Otherwise, they should provide a 'parseline' function 00233 for my $line (split /\r?\n\r?/, $content) 00234 { 00235 $self->stepline(); 00236 $io->parseline($line); 00237 } 00238 } 00239 else 00240 { 00241 $self->error("No read functions provided by IO type $io->{'name'}"); 00242 } 00243 $self->endfile(); 00244 } 00245 00246 00247 ## 00248 # Write a file of a given type 00249 # 00250 # If the type cannot be found, or some other error occurs, we die. 00251 # 00252 # @param[in] $self DASM object 00253 # @param[in] $filename Filename to read; just an extension starting with 00254 # a period will print to the screen, eg '.dasm' 00255 # @param[in] $type Type of file to write (a DASMIO object) 00256 sub writefile 00257 { 00258 my ($self, $filename, $type) = @_; 00259 00260 my $io = $self->findio($filename, $type, 'write'); 00261 00262 my $content = $io->write($filename); 00263 00264 if ($filename =~ /^\./) 00265 { 00266 # Just print to the screen 00267 print $content; 00268 } 00269 else 00270 { 00271 open(my $fh, ">", $filename) || die "Cannot write to file '$filename': $!"; 00272 print $fh $content; 00273 close($fh); 00274 } 00275 } 00276 00277 00278 ## 00279 # Report a parsing error to the user. 00280 # 00281 # @param[in] $error Error message 00282 # 00283 # @note never returns 00284 sub error 00285 { 00286 my ($self, $error) = @_; 00287 00288 my $location = $self->parsestack(); 00289 00290 die "Parse error: $error $location\n"; 00291 } 00292 00293 00294 ## 00295 # Return the location in the parser stack we currently are at 00296 # 00297 # @param[in] $self DASM object 00298 # 00299 # @return Description of the line stack, from most recent to oldest 00300 # over multiple lines 00301 sub parsestack 00302 { 00303 my ($self) = @_; 00304 my $string; 00305 00306 # Return only the positions that have been set 00307 return join "\n", 00308 map { 00309 "at line $_->{'line'} in $_->{'file'}"; 00310 } grep { $_->{'line'} != 0 } 00311 reverse @{ $self->{'sourcestack'} }; 00312 } 00313 00314 00315 ## 00316 # Begin processing a file at a given line. 00317 # 00318 # @param[in] $self DASM object 00319 # @param[in] $file File we start beginning processing 00320 # @param[in] $line Line we are parsing at (or undef for start of file) 00321 sub startfile 00322 { 00323 my ($self, $file, $line) = @_; 00324 00325 $line ||= 1; # Default to the first line 00326 00327 # Create a new stack entry 00328 push @{ $self->{'sourcestack'} }, 00329 { 00330 # We always store the line before the current one in our 00331 # stack structure. This means that unprocessed files are 00332 # given line 0. When processing a line we increment at the 00333 # start of processing so that whilst processing it, the value 00334 # on the stack is correct. 00335 'line' => $line-1, 00336 'file' => $file 00337 }; 00338 } 00339 00340 00341 ## 00342 # End processing a file 00343 # 00344 # @param[in] $self DASM object 00345 sub endfile 00346 { 00347 my ($self) = @_; 00348 00349 # Just pop an entry off the stack 00350 pop @{ $self->{'sourcestack'} }; 00351 } 00352 00353 00354 ## 00355 # Step to the next line. 00356 # 00357 # @param[in] $self DASM object 00358 # @param[in] $line Explicitly move to a given line (optional) 00359 sub stepline 00360 { 00361 my ($self, $line) = @_; 00362 00363 if (defined $line) 00364 { 00365 # They want to explicitly override the line number 00366 $self->{'sourcestack'}->[-1]->{'line'} = $line; 00367 } 00368 else 00369 { 00370 # We've parsed a line from the input, so increment our counter 00371 $self->{'sourcestack'}->[-1]->{'line'}++; 00372 } 00373 } 00374 00375 ## 00376 # Set the PC value 00377 # 00378 # @param[in] $self DASM object 00379 # @param[in] $pc New PC value 00380 # @param[in] $value Value to store 00381 sub setpc 00382 { 00383 my ($self, $pc) = @_; 00384 00385 if ($pc < 0 || $pc > 0xffff) 00386 { 00387 $self->error(sprintf "PC out of range %x", $pc); 00388 } 00389 00390 $self->{'pc'} = $pc; 00391 } 00392 00393 ## 00394 # Store a value in the core 00395 # 00396 # @param[in] $self DASM object 00397 # @param[in] $addr Address to store at 00398 # @param[in] $value Value to store 00399 sub store 00400 { 00401 my ($self, $addr, $value) = @_; 00402 00403 confess "No address supplied to store" if (!defined $addr); 00404 confess "No value supplied to store" if (!defined $value); 00405 00406 if ($addr > 0xFFFF || $addr < 0x0) 00407 { 00408 $self->error(sprintf "Attempt to store outside of core at 0x%x", $addr); 00409 } 00410 00411 # Do not dereference the hardware's value; just store it. 00412 #if (ref $value ne '') 00413 #{ 00414 # $value = $value->read(); 00415 # $value = 0 if (!defined $value); 00416 #} 00417 00418 00419 if (ref $value eq '') 00420 { 00421 $value = $value & 0xFFFF; 00422 } 00423 00424 if (defined $self->{'core'}->{$addr} && 00425 ref $self->{'core'}->{$addr} ne '') 00426 { 00427 $self->{'core'}->{$addr}->write($value); 00428 } 00429 else 00430 { 00431 $self->{'core'}->{$addr} = $value; 00432 } 00433 00434 print "STORE: $addr : $value\n" if ($debug_store); 00435 } 00436 00437 00438 ## 00439 # Store a value at the current PC, incrementing after 00440 # 00441 # @param[in] $self DASM object 00442 # @param[in] $value Value to store 00443 sub storetopc 00444 { 00445 my ($self, $value) = @_; 00446 00447 confess "No value supplied to storetopc" if (!defined $value); 00448 00449 if (ref $value ne '') 00450 { 00451 $value = $value->read(); 00452 $value = 0 if (!defined $value); 00453 } 00454 00455 $value = $value & 0xFFFF; 00456 00457 my $addr = $self->{'pc'}++; 00458 00459 if (defined $self->{'core'}->{$addr} && 00460 ref $self->{'core'}->{$addr} ne '') 00461 { 00462 $self->{'core'}->{$addr}->write($value); 00463 } 00464 else 00465 { 00466 $self->{'core'}->{$addr} = $value; 00467 } 00468 00469 print "STORETOPC: $addr : $value\n" if ($debug_store); 00470 } 00471 00472 00473 ## 00474 # Store and increment value in the core 00475 # 00476 # @param[in] $self DASM object 00477 # @param[in] $addr Address to store at 00478 # @param[in] $value Value to store 00479 sub storeinc 00480 { 00481 my ($self, $addr, $value) = @_; 00482 00483 confess "No address supplied to storeinc" if (!defined $addr); 00484 confess "No value supplied to storeinc" if (!defined $value); 00485 00486 if ($addr > 0xFFFF || $addr < 0x0) 00487 { 00488 $self->error(sprintf "Attempt to store outside of core at 0x%x", $addr); 00489 } 00490 if (ref $value ne '') 00491 { 00492 $value = $value->read(); 00493 $value = 0 if (!defined $value); 00494 } 00495 00496 $value += $self->read($addr); 00497 $value = $value & 0xFFFF; 00498 00499 if (defined $self->{'core'}->{$addr} && 00500 ref $self->{'core'}->{$addr} ne '') 00501 { 00502 $self->{'core'}->{$addr}->write($value); 00503 } 00504 else 00505 { 00506 $self->{'core'}->{$addr} = $value; 00507 } 00508 00509 print "STOREINC: $addr : $value\n" if ($debug_store); 00510 } 00511 00512 ## 00513 # Read a value from the core 00514 # 00515 # @param[in] $self DASM object 00516 # @param[in] $addr Address to read from 00517 sub read 00518 { 00519 my ($self, $addr) = @_; 00520 00521 confess "No address supplied to read" if (!defined $addr); 00522 00523 if ($addr > 0xFFFF || $addr < 0x0) 00524 { 00525 $self->error(sprintf "Attempt to read outside of core at 0x%x", $addr); 00526 } 00527 00528 my $value = $self->{'core'}->{$addr}; 00529 return 0 if (!defined $value); 00530 00531 if (ref $value ne '') 00532 { 00533 $value = $value->read(); 00534 } 00535 if (defined $value) 00536 { 00537 $value = $value & 0xFFFF; 00538 } 00539 return $value; 00540 } 00541 00542 00543 ## 00544 # Assign a label to an address. 00545 # 00546 # @param[in] $self DASM object 00547 # @param[in] $addr Address to store at 00548 # @param[in] $label Label to assign 00549 sub label 00550 { 00551 my ($self, $addr, $label) = @_; 00552 00553 if (defined $self->{'symbols'}->{$label}) 00554 { 00555 $self->error("Attempt to redefine label '$label'"); 00556 } 00557 $self->{'symbols'}->{$label} = { 00558 'type' => 'address', 00559 'value' => $addr, 00560 }; 00561 } 00562 00563 00564 ## 00565 # Set a symbol to a value 00566 # 00567 # @param[in] $self DASM object 00568 # @param[in] $symname Symbol name 00569 # @param[in] $value The value of the symbol 00570 # @param[in] $type The type of symbol to set 00571 sub setsymbol 00572 { 00573 my ($self, $symname, $value, $type) = @_; 00574 00575 confess "No symbol supplied" if (!defined $symname || $symname eq ''); 00576 confess "No value supplied" if (!defined $value || $value eq ''); 00577 confess "No type supplied" if (!defined $value || $type eq ''); 00578 00579 if (defined $self->{'symbols'}->{$symname}) 00580 { 00581 $self->error("Attempt to redefine symbol '$symname'"); 00582 } 00583 00584 print "SETSYMBOL: $symname = $value\n" if ($debug_sym); 00585 00586 $self->{'symbols'}->{$symname} = { 00587 'type' => $type, 00588 'value' => $value, 00589 }; 00590 } 00591 00592 00593 ## 00594 # Return a given symbol name. 00595 # 00596 # @param[in] $self DASM object 00597 # @param[in] $symname Symbol name 00598 # 00599 # @return hashref for symbol, or undef if not known: 00600 # 'type' => 'address' or 'constant' 00601 # 'value' => 'value' of the symbol 00602 sub getsymbol 00603 { 00604 my ($self, $symname) = @_; 00605 00606 confess "No symbol supplied to getsymbol()" if (!defined $symname); 00607 00608 return $self->{'symbols'}->{$symname}; 00609 } 00610 00611 00612 ## 00613 # Resolve any unresolved relocations, where possible. 00614 # 00615 # @param[in] $self DASM object 00616 # 00617 # @retval 1 if everything was resolved 00618 # @retval 0 if there were symbols unresolved 00619 sub resolve 00620 { 00621 my ($self) = @_; 00622 00623 # Step through all the relocations checking to see if we know 00624 # the symbols - if we do, we can resolve them now. 00625 for my $address (keys %{ $self->{'relocations'} }) 00626 { 00627 my $symname = $self->{'relocations'}->{$address}; 00628 my $symbol = $self->{'symbols'}->{$symname}; 00629 00630 if (defined $symbol) 00631 { 00632 delete $self->{'relocations'}->{$address}; 00633 $self->storeinc($address, $symbol->{'value'}); 00634 } 00635 } 00636 00637 # Check if we managed to resolve everything 00638 return scalar(keys %{ $self->{'relocations'} }) == 0 00639 } 00640 00641 00642 ## 00643 # Record the hardware provided by a device. 00644 # 00645 # @param[in] $self DASM object 00646 # @param[in] $address Base address of the device 00647 # @param[in] $object Device object 00648 sub addhardware 00649 { 00650 my ($self, $address, $object) = @_; 00651 00652 confess "No address supplied to addhardware" if (!defined $address); 00653 confess "No object supplied to addhardware" if (!defined $object); 00654 00655 $self->{'hardware'}->{$address} = $object; 00656 # FIXME: Consider whether the 'register' interface in DASMIO/Hardware.pm 00657 # shouldn't live here instead. 00658 } 00659 00660 00661 ## 00662 # Display a dump of the code that we've compiled so far 00663 # 00664 # @param[in] $self DASM object 00665 sub dump 00666 { 00667 my ($self) = @_; 00668 00669 print "Core:\n"; 00670 00671 # Local reference to make this easier 00672 my $symbols = $self->{'symbols'}; 00673 my $relocs = $self->{'relocations'}; 00674 00675 # Collect a list of address symbols 00676 my %addressSymbols = map { 00677 $symbols->{$_}->{'value'} => $_ 00678 } grep { 00679 $symbols->{$_}->{'type'} eq 'address' 00680 } keys %$symbols; 00681 00682 # Step through the core in order, printing out the values 00683 # we have got: 00684 for my $address (sort { $a <=> $b } keys %{ $self->{'core'} }) 00685 { 00686 my $corevalue = $self->{'core'}->{$address}; 00687 00688 # Skip anything that's not a bare value 00689 if (ref $corevalue ne '') 00690 { 00691 next; 00692 } 00693 00694 my $value = $self->read($address); 00695 if (defined $addressSymbols{$address}) 00696 { 00697 print ":$addressSymbols{$address}\n"; 00698 } 00699 printf "%04x : %04x", $address, $value; 00700 00701 if (defined $relocs->{$address}) 00702 { 00703 printf " +%s", $relocs->{$address}; 00704 } 00705 print "\n"; 00706 } 00707 00708 print "\nSymbols:\n"; 00709 for my $symbol (sort keys %$symbols) 00710 { 00711 printf "%-24s : %-10s : ", $symbol, $symbols->{$symbol}->{'type'}; 00712 if ($symbols->{$symbol}->{'type'} eq 'address') 00713 { 00714 printf "0x%04x (%d)", $symbols->{$symbol}->{'value'}, $symbols->{$symbol}->{'value'}; 00715 } 00716 elsif ($symbols->{$symbol}->{'type'} eq 'constant') 00717 { 00718 printf "0x%04x (%d)", $symbols->{$symbol}->{'value'}, $symbols->{$symbol}->{'value'}; 00719 } 00720 print "\n"; 00721 } 00722 00723 print "\nRelocations:\n"; 00724 for my $address (sort { $a <=> $b } keys %$relocs) 00725 { 00726 printf "%04x : %s\n", $address, $relocs->{$address}; 00727 } 00728 } 00729 00730 00731 # End with a true value 00732 1;