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