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 ## 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;