DASM
DASM.pm
Go to the documentation of this file.
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;