1199 lines
42 KiB
Perl
1199 lines
42 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
|
||
|
|
my $indent = ' ' x 2;
|
||
|
|
my $separator = '-' x 80;
|
||
|
|
|
||
|
|
################################################################################
|
||
|
|
# Input arguments
|
||
|
|
#
|
||
|
|
use Getopt::Std;
|
||
|
|
my %opts;
|
||
|
|
getopts('hva:d:r:kc', \%opts);
|
||
|
|
|
||
|
|
die("\n".
|
||
|
|
"Usage: $0 [options] fileSpec\n".
|
||
|
|
"\n".
|
||
|
|
"Options:\n".
|
||
|
|
"${indent}-h display this help message\n".
|
||
|
|
"${indent}-v verbose\n".
|
||
|
|
"${indent}-a bitNb the number of program address bits\n".
|
||
|
|
"${indent}-d bitNb the number of data bits\n".
|
||
|
|
"${indent}-r bitNb the number of register address bits\n".
|
||
|
|
"${indent}-k keep intermediate files\n".
|
||
|
|
"${indent}-c clean temporary work files\n".
|
||
|
|
"\n".
|
||
|
|
"Compiles a Pascal program to assembler code for the nanoBlaze processor.\n".
|
||
|
|
"\n".
|
||
|
|
"More information with: perldoc $0\n".
|
||
|
|
"\n".
|
||
|
|
""
|
||
|
|
) if ($opts{h});
|
||
|
|
|
||
|
|
my $verbose = $opts{v};
|
||
|
|
my $keepIntermediateFiles= $opts{k};
|
||
|
|
my $cleanTempFiles = $opts{c};
|
||
|
|
my $addressBitNb = $opts{a} || 10;
|
||
|
|
my $registerBitNb = $opts{d} || 8;
|
||
|
|
my $registerAddressBitNb = $opts{r} || 4;
|
||
|
|
|
||
|
|
my $pascalFileSpec = $ARGV[0] || 'nanoTest.pas';
|
||
|
|
my $asmFileSpec = $ARGV[1] || 'nanoTest.asm';
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# System constants
|
||
|
|
#
|
||
|
|
my $mainProgram = 'mainProgram';
|
||
|
|
my $wordHexCharNb = 4;
|
||
|
|
my $firstRegister = 2; # reserve 2 registers for internal calculations
|
||
|
|
my $functionReturnRegister = 's0';
|
||
|
|
my $conditionRegister = 's1';
|
||
|
|
my $memoryAccessRegister = 's1';
|
||
|
|
my $partialOperationRegister = 's1';
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Derived values
|
||
|
|
#
|
||
|
|
# file specs
|
||
|
|
my $baseFileSpec = $pascalFileSpec;
|
||
|
|
$baseFileSpec =~ s/\..*//i;
|
||
|
|
my $temp1FileSpec = "$baseFileSpec.tmp1";
|
||
|
|
my $temp2FileSpec = "$baseFileSpec.tmp2";
|
||
|
|
my $registersFileSpec = "${baseFileSpec}_registers.txt"; # register assignments
|
||
|
|
my $asm1FileSpec = "$baseFileSpec.asm1";
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Assembler file formatting constants
|
||
|
|
#
|
||
|
|
my $asmFirstIndent = ' ' x 24;
|
||
|
|
my $asmLineLength = 80;
|
||
|
|
my $commentStart = $asmFirstIndent . ';';
|
||
|
|
my $separator1 = fillString($commentStart, '=', $asmLineLength);
|
||
|
|
my $separator2 = fillString($commentStart, '-', $asmLineLength);
|
||
|
|
my $opcodeLength = 10;
|
||
|
|
my $firstArgumentLength = 6;
|
||
|
|
my $constantMaxLength = 8;
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# System variables
|
||
|
|
#
|
||
|
|
my $currentPass = 0;
|
||
|
|
my %constants = ();
|
||
|
|
my %variables = ();
|
||
|
|
my %registers = ();
|
||
|
|
my @routines = ();
|
||
|
|
|
||
|
|
################################################################################
|
||
|
|
# Functions
|
||
|
|
#
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Swap temporary filespecs from one pass to the other
|
||
|
|
#
|
||
|
|
sub swapTempFileSpecs {
|
||
|
|
my ($inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec) = @_;
|
||
|
|
# swap to tmp1 -> tmp2
|
||
|
|
if ($outputFileSpec eq $temp1FileSpec) {
|
||
|
|
$inputFileSpec = $temp1FileSpec;
|
||
|
|
$outputFileSpec = $temp2FileSpec;
|
||
|
|
}
|
||
|
|
# swap to tmp2 -> tmp2
|
||
|
|
else {
|
||
|
|
$inputFileSpec = $temp2FileSpec;
|
||
|
|
$outputFileSpec = $temp1FileSpec;
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($inputFileSpec, $outputFileSpec);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Fill string to a fixed length with a given character
|
||
|
|
#
|
||
|
|
sub fillString {
|
||
|
|
my ($string, $character, $length) = @_;
|
||
|
|
# fill string
|
||
|
|
$string .= $character x ($length - length($string));
|
||
|
|
|
||
|
|
return ($string);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Assign registers to all variables
|
||
|
|
#
|
||
|
|
sub buildConstants {
|
||
|
|
my ($mainProgram, %constants) = @_;
|
||
|
|
# loop on routines
|
||
|
|
foreach my $subroutine (keys(%constants)) {
|
||
|
|
#print "$subroutine:\n";
|
||
|
|
# build array
|
||
|
|
$constants{$subroutine} =~ s/\s*\;\Z//;
|
||
|
|
$constants{$subroutine} =~ s/\s*=\s*/=/g;
|
||
|
|
my @procedureConstants = split(/\;/, $constants{$subroutine});
|
||
|
|
# build hash
|
||
|
|
my %procedureConstants;
|
||
|
|
for my $index (0 .. $#procedureConstants) {
|
||
|
|
my ($name, $value) = split(/\=/, $procedureConstants[$index]);
|
||
|
|
#print "$name: $value\n";
|
||
|
|
$value =~ s/\$([0-9A-Fa-f]+)/0x$1/g;
|
||
|
|
foreach my $alreadyDeclared (keys(%procedureConstants)) {
|
||
|
|
$value =~ s/$alreadyDeclared/($procedureConstants{$alreadyDeclared})/g;
|
||
|
|
}
|
||
|
|
$value = eval($value);
|
||
|
|
$procedureConstants{$name} = $value;
|
||
|
|
#print " $name = $procedureConstants{$name}\n";
|
||
|
|
}
|
||
|
|
$constants{$subroutine} = \%procedureConstants;
|
||
|
|
}
|
||
|
|
# convert to hexadecimal
|
||
|
|
foreach my $subroutine (keys(%constants)) {
|
||
|
|
my $replacement_ref = $constants{$subroutine};
|
||
|
|
foreach my $name (keys(%$replacement_ref)) {
|
||
|
|
my $value = $$replacement_ref{$name};
|
||
|
|
$value = '$' . sprintf('%X', $value);
|
||
|
|
$$replacement_ref{$name} = $value;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach my $subroutine (keys(%constants)) {
|
||
|
|
$line =~ s/$name/$$replacement_ref{$name}/g;
|
||
|
|
}
|
||
|
|
|
||
|
|
return (%constants);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Assign registers to variables within a routine
|
||
|
|
#
|
||
|
|
sub assignRegistersToRoutine {
|
||
|
|
my ($startIndex, $variables) = @_;
|
||
|
|
# build array
|
||
|
|
$variables =~ s/\;\Z//;
|
||
|
|
my @variables = split(/\;/, $variables);
|
||
|
|
# loop on variables
|
||
|
|
my $registerIndex = $startIndex;
|
||
|
|
for my $index (0 .. $#variables) {
|
||
|
|
$variables[$index] =~ s/word/s$registerIndex/;
|
||
|
|
$variables[$index] =~ s/uint8/s$registerIndex/;
|
||
|
|
$registerIndex = $registerIndex + 1;
|
||
|
|
#print " $variables[$index]\n";
|
||
|
|
}
|
||
|
|
# assign registers to main program
|
||
|
|
|
||
|
|
return ($registerIndex-1, join(';', @variables));
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Assign registers to all variables
|
||
|
|
#
|
||
|
|
sub assignRegisters {
|
||
|
|
my ($mainProgram, $firstRegister, %variables) = @_;
|
||
|
|
# loop on routines
|
||
|
|
my $registerMaxNb = 0;
|
||
|
|
foreach my $subroutine (keys(%variables)) {
|
||
|
|
# remove spaces
|
||
|
|
$variables{$subroutine} =~ s/\s*\:\s*/:/g;
|
||
|
|
$variables{$subroutine} =~ s/\s*\,\s*/,/g;
|
||
|
|
# distribute type definitions
|
||
|
|
my $type;
|
||
|
|
do {
|
||
|
|
$variables{$subroutine} =~ s/\,(.*?)\:(.*?)\;/:$2;$1:$2;/;
|
||
|
|
$type = $2;
|
||
|
|
} while ($type ne '');
|
||
|
|
# assign registers to routine internal variables
|
||
|
|
if ($subroutine ne $mainProgram) {
|
||
|
|
#print "$subroutine:\n";
|
||
|
|
my ($registerNb, $routineVariables) = assignRegistersToRoutine(
|
||
|
|
$firstRegister,
|
||
|
|
$variables{$subroutine}
|
||
|
|
);
|
||
|
|
if ($registerNb > $registerMaxNb) {
|
||
|
|
$registerMaxNb = $registerNb;
|
||
|
|
}
|
||
|
|
$variables{$subroutine} = $routineVariables;
|
||
|
|
#print " $variables{$subroutine}\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# assign registers to main program
|
||
|
|
#print "$mainProgram:\n";
|
||
|
|
my ($registerNb, $routineVariables) = assignRegistersToRoutine(
|
||
|
|
$registerMaxNb + 1,
|
||
|
|
$variables{$mainProgram}
|
||
|
|
);
|
||
|
|
$variables{$mainProgram} = $routineVariables;
|
||
|
|
#print " $variables{$mainProgram}\n";
|
||
|
|
# build hash of hashes
|
||
|
|
foreach my $subroutine (keys(%variables)) {
|
||
|
|
my @registers = split(/\;/, $variables{$subroutine});
|
||
|
|
my %assignedRegisters;
|
||
|
|
foreach my $variable (@registers) {
|
||
|
|
my ($var, $register) = split(/\:/, $variable);
|
||
|
|
$assignedRegisters{$var} = $register;
|
||
|
|
}
|
||
|
|
$variables{$subroutine} = \%assignedRegisters;
|
||
|
|
}
|
||
|
|
return (%variables);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Translate Pascal second operand to assembler source operand if possible
|
||
|
|
#
|
||
|
|
sub translateArgument {
|
||
|
|
my ($pascalOperand, $wordHexCharNb) = @_;
|
||
|
|
my $assemblerOperand = '';
|
||
|
|
# register
|
||
|
|
if ($pascalOperand =~ m/\As(\d+)\Z/) {
|
||
|
|
$assemblerOperand = "s$1";
|
||
|
|
}
|
||
|
|
# decimal numeric constant
|
||
|
|
elsif ($pascalOperand =~ m/\A(\d+)\Z/) {
|
||
|
|
$assemblerOperand = sprintf("%0${wordHexCharNb}X", $pascalOperand);
|
||
|
|
}
|
||
|
|
# hexadecimal numeric constant
|
||
|
|
elsif ($pascalOperand =~ m/\A\$([0-9A-Fa-f]+)\Z/) {
|
||
|
|
$assemblerOperand = sprintf("%0${wordHexCharNb}X", hex($1));
|
||
|
|
}
|
||
|
|
# declared constant
|
||
|
|
else {
|
||
|
|
foreach my $routine (keys(%constants)) {
|
||
|
|
my $constants_ref = $constants{$routine};
|
||
|
|
foreach my $constant (sort(keys(%$constants_ref))) {
|
||
|
|
if ($pascalOperand eq $constant) {
|
||
|
|
$assemblerOperand = $pascalOperand;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($assemblerOperand);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Format assignment in ters of space characters
|
||
|
|
#
|
||
|
|
sub formatAssignment {
|
||
|
|
my ($assignment) = @_;
|
||
|
|
# unary operators
|
||
|
|
$assignment =~ s/\A\s*\-\s*/0 - /g;
|
||
|
|
# arithmetic operations
|
||
|
|
$assignment =~ s/\s*\+\s*/ + /g;
|
||
|
|
$assignment =~ s/\s*\-\s*/ - /g;
|
||
|
|
$assignment =~ s/\s*\*\s*/ * /g;
|
||
|
|
$assignment =~ s/\s*\/\s*/ \/ /g;
|
||
|
|
# logic operations
|
||
|
|
$assignment =~ s/\s+and\s+/ and /ig;
|
||
|
|
$assignment =~ s/\s+or\s+/ or /ig;
|
||
|
|
$assignment =~ s/\s+xor\s+/ xor /ig;
|
||
|
|
$assignment =~ s/\s+shl\s+/ shl /ig;
|
||
|
|
$assignment =~ s/\s+shr\s+/ shr /ig;
|
||
|
|
# parenthesis
|
||
|
|
$assignment =~ s/\(\s+/(/g;
|
||
|
|
$assignment =~ s/\s+\)/)/g;
|
||
|
|
$assignment =~ s/\s*\[\s+/[/g;
|
||
|
|
$assignment =~ s/\s+\]/]/g;
|
||
|
|
|
||
|
|
return ($assignment);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Extract first argument of an assignment
|
||
|
|
#
|
||
|
|
sub extractFirsrtArgument {
|
||
|
|
my ($assignment) = @_;
|
||
|
|
my $operator = '';
|
||
|
|
my $restOfAssignment = '';
|
||
|
|
# starts with parenthesis
|
||
|
|
if ($assignment =~ m/\A\(/) {
|
||
|
|
my $index = 0;
|
||
|
|
my $level = 0;
|
||
|
|
my @characters = split(//, $assignment);
|
||
|
|
foreach my $character (@characters) {
|
||
|
|
if ($character eq '(') {$level = $level+1};
|
||
|
|
if ($character eq '[') {$level = $level+1};
|
||
|
|
if ($character eq ']') {$level = $level-1};
|
||
|
|
if ($character eq ')') {$level = $level-1};
|
||
|
|
if ($level == 0) {
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
$index = $index+1;
|
||
|
|
}
|
||
|
|
$firstArgument = substr($assignment, 0, $index+1);
|
||
|
|
$restOfAssignment = substr($assignment, $index+1);
|
||
|
|
}
|
||
|
|
# to first whitespace
|
||
|
|
else {
|
||
|
|
my $index = 0;
|
||
|
|
my $level = 0;
|
||
|
|
my @characters = split(//, $assignment);
|
||
|
|
foreach my $character (@characters) {
|
||
|
|
if ($character eq '(') {$level = $level+1};
|
||
|
|
if ($character eq '[') {$level = $level+1};
|
||
|
|
if ($character eq ']') {$level = $level-1};
|
||
|
|
if ($character eq ')') {$level = $level-1};
|
||
|
|
if ( ($character eq ' ') and ($level == 0) ) {
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
$index = $index+1;
|
||
|
|
}
|
||
|
|
$firstArgument = substr($assignment, 0, $index);
|
||
|
|
$restOfAssignment = substr($assignment, $index);
|
||
|
|
}
|
||
|
|
$restOfAssignment =~ s/\A //;
|
||
|
|
#print "|$firstArgument|$restOfAssignment|\n";
|
||
|
|
# extract operator
|
||
|
|
if ($restOfAssignment ne '') {
|
||
|
|
($operator, $restOfAssignment) = split(/ /, $restOfAssignment, 2);
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($firstArgument, $operator, $restOfAssignment);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Build expression out of argument and operator list
|
||
|
|
#
|
||
|
|
sub buildExpression {
|
||
|
|
my ($arguments_ref, $operators_ref) = @_;
|
||
|
|
my @arguments = @$arguments_ref;
|
||
|
|
my @operators = @$operators_ref;
|
||
|
|
# loop on list elements
|
||
|
|
my $expression = $arguments[0];
|
||
|
|
#print "0: $expression\n";
|
||
|
|
for my $index (1 .. $#arguments) {
|
||
|
|
#print "$index: $operators[$index] $arguments[$index]\n";
|
||
|
|
$expression .= " $operators[$index] $arguments[$index]";
|
||
|
|
}
|
||
|
|
return ($expression);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Expand operation to 2 lines
|
||
|
|
#
|
||
|
|
sub expandTwo {
|
||
|
|
my ($destinationRegister, $arguments_ref, $operators_ref) = @_;
|
||
|
|
my @arguments = @$arguments_ref;
|
||
|
|
my @operators = @$operators_ref;
|
||
|
|
my $line = '';
|
||
|
|
#print " -> ";
|
||
|
|
#for my $index (0..scalar(@arguments)-1) { print "$operators[$index] $arguments[$index] ";}
|
||
|
|
#print "\n";
|
||
|
|
# last argument is constant
|
||
|
|
my $lastArgument = $arguments[$#arguments];
|
||
|
|
my $lastOperator = $operators[$#operators];
|
||
|
|
my $isDeclaredConstant = 0;
|
||
|
|
foreach my $routine (keys(%constants)) {
|
||
|
|
my $constants_ref = $constants{$routine};
|
||
|
|
foreach my $constant (sort(keys(%$constants_ref))) {
|
||
|
|
if ($lastArgument eq $constant) {
|
||
|
|
$isDeclaredConstant = 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (
|
||
|
|
($lastArgument =~ m/\A\d+\Z/) or
|
||
|
|
($lastArgument =~ m/\A\$[0-9A-Fa-f]+\Z/) or
|
||
|
|
($isDeclaredConstant)
|
||
|
|
) {
|
||
|
|
pop(@arguments);
|
||
|
|
pop(@operators);
|
||
|
|
my $firstArgument = buildExpression(\@arguments, \@operators);
|
||
|
|
if ($destinationRegister ne $firstArgument) {
|
||
|
|
$line = "$destinationRegister := $firstArgument;\n";
|
||
|
|
}
|
||
|
|
$line .= "$destinationRegister := $destinationRegister $lastOperator $lastArgument;";
|
||
|
|
#print "$line\n";
|
||
|
|
}
|
||
|
|
# last argument is compund
|
||
|
|
elsif ($lastArgument =~ m/\A\((.+)\)\Z/) {
|
||
|
|
my $firstArgument = $1;
|
||
|
|
pop(@arguments);
|
||
|
|
pop(@operators);
|
||
|
|
$lastArgument = buildExpression(\@arguments, \@operators);
|
||
|
|
if ($firstArgument =~ m/ $destinationRegister /) {
|
||
|
|
$line = "$partialOperationRegister := $firstArgument;\n";
|
||
|
|
$line .= "$destinationRegister := $destinationRegister $lastOperator $partialOperationRegister;";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$line = "$destinationRegister := $firstArgument;\n";
|
||
|
|
$line .= "$destinationRegister := $destinationRegister $lastOperator $lastArgument;";
|
||
|
|
}
|
||
|
|
#print "$line\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($line);
|
||
|
|
}
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Expand assignment to multiple lines
|
||
|
|
#
|
||
|
|
sub expandAssignment {
|
||
|
|
my ($destinationRegister, $assignment) = @_;
|
||
|
|
# format assignment for treatment
|
||
|
|
$assignment = formatAssignment($assignment);
|
||
|
|
# default result
|
||
|
|
my $line = "$destinationRegister := $assignment;";
|
||
|
|
#print "\n$line\n";
|
||
|
|
# don't modify simple assignments and function calls
|
||
|
|
my $source = translateArgument($assignment, $wordHexCharNb);
|
||
|
|
my @arguments = ();
|
||
|
|
my @operators = ('');
|
||
|
|
if ( ($source eq '') and ($assignment !~ m/\Acall\s/) ){
|
||
|
|
# analyse assignment
|
||
|
|
#print "\n $destinationRegister := $assignment\n";
|
||
|
|
my $done = 0;
|
||
|
|
do {
|
||
|
|
my ($firstArgument, $operator, $restOfAssignment) = extractFirsrtArgument($assignment);
|
||
|
|
#print " $firstArgument $operator $restOfAssignment\n";
|
||
|
|
if ($operator eq '') {
|
||
|
|
push(@arguments, $firstArgument);
|
||
|
|
$done = 1;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
push(@arguments, $firstArgument);
|
||
|
|
push(@operators, $operator);
|
||
|
|
$assignment = $restOfAssignment;
|
||
|
|
}
|
||
|
|
} until $done == 1;
|
||
|
|
#print " -> " . join(', ', @arguments) . "\n";
|
||
|
|
# expand to 2 lines
|
||
|
|
my $newLine = expandTwo($destinationRegister, \@arguments, \@operators);
|
||
|
|
# modify code line
|
||
|
|
if ($newLine ne '') {
|
||
|
|
$line = $newLine;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($line);
|
||
|
|
}
|
||
|
|
|
||
|
|
################################################################################
|
||
|
|
# Program start
|
||
|
|
#
|
||
|
|
|
||
|
|
#-------------------------------------------------------------------------------
|
||
|
|
# Display information
|
||
|
|
#
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "$separator\n";
|
||
|
|
print "Compiling $pascalFileSpec to $asmFileSpec\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Rewrite file for easier parsing
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
my $inputFileSpec = $pascalFileSpec;
|
||
|
|
my $outputFileSpec = $temp1FileSpec;
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: placing line ends\n";
|
||
|
|
}
|
||
|
|
# read input file
|
||
|
|
my $singleLine = '';
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# remove leading and trailing spaces
|
||
|
|
$line =~ s/\A\s+//;
|
||
|
|
$line =~ s/\s+\Z//;
|
||
|
|
# remove single line comments
|
||
|
|
$line =~ s/\{.*?\}//g;
|
||
|
|
# write to single line string
|
||
|
|
if ($line ne '') {
|
||
|
|
$singleLine .= "$line ";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(inputFile);
|
||
|
|
# remove extra spaces
|
||
|
|
$singleLine =~ s/\s+/ /g;
|
||
|
|
$singleLine =~ s/\s\Z//;
|
||
|
|
# split constructs into multiple lines
|
||
|
|
$singleLine =~ s/\s*;\s*/;\n/g;
|
||
|
|
$singleLine =~ s/\sconst\s/\nconst\n/g;
|
||
|
|
$singleLine =~ s/\svar\s/\nvar\n/g;
|
||
|
|
$singleLine =~ s/\sprocedure\s+/\nprocedure /g;
|
||
|
|
$singleLine =~ s/\sfunction\s+/\nfunction /g;
|
||
|
|
$singleLine =~ s/\sbegin\s/\nbegin\n/g;
|
||
|
|
$singleLine =~ s/\send\s*;\s/\nend;\n/g;
|
||
|
|
$singleLine =~ s/\selse\s/\nelse\n/g;
|
||
|
|
$singleLine =~ s/\srepeat\s/\nrepeat\n/g;
|
||
|
|
$singleLine =~ s/\sif\s/\nif /g;
|
||
|
|
$singleLine =~ s/\suntil\s/\nuntil /g;
|
||
|
|
$singleLine =~ s/\sfor\s/\nfor /g;
|
||
|
|
$singleLine =~ s/\swhile\s/\nwhile /g;
|
||
|
|
$singleLine =~ s/\sthen\s/ then\n/g;
|
||
|
|
$singleLine =~ s/\sdo\s/ do\n/g;
|
||
|
|
# take away new lines within parenthesis
|
||
|
|
my $parameters;
|
||
|
|
do {
|
||
|
|
$singleLine =~ s/\(([^\)]*?)\n([^\)]*?)\)/($1 $2)/m;
|
||
|
|
$parameters = $2;
|
||
|
|
#if ($parameters ne '') { print "--> $1 $parameters\n"; }
|
||
|
|
} while ($parameters ne '');
|
||
|
|
# add begin/end to single-line blocks
|
||
|
|
my $singleLineBlock;
|
||
|
|
do {
|
||
|
|
$singleLine =~ s/\nif (.*?) then\n(?!begin)(.*?)\;/\nif $1 then\nbegin\n$2;\nend;/;
|
||
|
|
$singleLineBlock = $2;
|
||
|
|
#print "if $1 then begin $2; end;\n";
|
||
|
|
} while ($singleLineBlock ne '');
|
||
|
|
do {
|
||
|
|
$singleLine =~ s/\nfor (.*?) do\n(?!begin)(.*?)\;/\nfor $1 do\nbegin\n$2;\nend;/;
|
||
|
|
$singleLineBlock = $2;
|
||
|
|
} while ($singleLineBlock ne '');
|
||
|
|
|
||
|
|
# remove comments, part 1
|
||
|
|
$singleLine =~ s/\s*\{\s*/\n{/g;
|
||
|
|
$singleLine =~ s/\s*\}\s*/}\n/g;
|
||
|
|
# write to output file
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
print(outputFile "$singleLine\n");
|
||
|
|
close(outputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Finish removing comments
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: removing comments\n";
|
||
|
|
}
|
||
|
|
# read input file
|
||
|
|
my $commentOut = 0;
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
# remove comments, part 2
|
||
|
|
if ($line =~ m/\{/) { $commentOut = 1; }
|
||
|
|
if ( ($commentOut == 0) and ($line ne '') ) {
|
||
|
|
print(outputFile "$line\n");
|
||
|
|
}
|
||
|
|
if ($line =~ m/\}/) { $commentOut = 0; }
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Get constants and variables, indent code
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: finding constants and variables\n";
|
||
|
|
}
|
||
|
|
my $currentLevel = 0;
|
||
|
|
my $currentRoutine;
|
||
|
|
my $startOfProgramDeclatation = '';
|
||
|
|
my $isStartOfProgramDeclatation = 1;
|
||
|
|
my $isConstantsDeclatation = 0;
|
||
|
|
my $isVariablesDeclatation = 0;
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# find program name
|
||
|
|
if ($line =~ m/\A\s*program\s+(.*)\s*;/i) {
|
||
|
|
$mainProgram = $1;
|
||
|
|
#print "Program name is |$mainProgram|\n";
|
||
|
|
$currentRoutine = $mainProgram;
|
||
|
|
@routines = ($currentRoutine);
|
||
|
|
}
|
||
|
|
# find current function name
|
||
|
|
if ($line =~ m/\A(procedure|function)(\s|\Z)/i) {
|
||
|
|
$currentRoutine = $line;
|
||
|
|
$currentRoutine =~ s/\Aprocedure//i;
|
||
|
|
$currentRoutine =~ s/\Afunction//i;
|
||
|
|
$currentRoutine =~ s/\A\s+//;
|
||
|
|
$currentRoutine =~ s/;.*//;
|
||
|
|
$currentRoutine =~ s/\s*:.*//;
|
||
|
|
$currentRoutine =~ s/\(.*//;
|
||
|
|
push(@routines, $currentRoutine);
|
||
|
|
print(outputFile "\n");
|
||
|
|
#print "$currentRoutine\n";
|
||
|
|
$isStartOfProgramDeclatation = 0;
|
||
|
|
$isVariablesDeclatation = 0;
|
||
|
|
$isConstantsDeclatation = 0;
|
||
|
|
}
|
||
|
|
# find begin/end level
|
||
|
|
if ($line eq 'begin') {
|
||
|
|
$currentLevel = $currentLevel + 1;
|
||
|
|
#print "-> $currentLevel\n";
|
||
|
|
if ( ($currentLevel == 1) and ($currentRoutine eq $mainProgram) ) {
|
||
|
|
#print "$currentRoutine\n";
|
||
|
|
$isStartOfProgramDeclatation = 0;
|
||
|
|
print(outputFile "\n$startOfProgramDeclatation");
|
||
|
|
}
|
||
|
|
$isVariablesDeclatation = 0;
|
||
|
|
$isConstantsDeclatation = 0;
|
||
|
|
}
|
||
|
|
if ($line eq 'end;') {
|
||
|
|
$currentLevel = $currentLevel - 1;
|
||
|
|
#print "-> $currentLevel\n";
|
||
|
|
if ($currentLevel == 0) {
|
||
|
|
$currentRoutine = $mainProgram;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# find constants
|
||
|
|
if ($isConstantsDeclatation) {
|
||
|
|
if ($line ne 'var') {
|
||
|
|
#print "-> $line\n";
|
||
|
|
$constants{$currentRoutine} .= $line;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($line eq 'const') {
|
||
|
|
$isConstantsDeclatation = 1;
|
||
|
|
$isVariablesDeclatation = 0;
|
||
|
|
}
|
||
|
|
# find variables
|
||
|
|
if ($isVariablesDeclatation) {
|
||
|
|
#print "-> $line\n";
|
||
|
|
$variables{$currentRoutine} .= $line;
|
||
|
|
}
|
||
|
|
if ($line eq 'var') {
|
||
|
|
$isVariablesDeclatation = 1;
|
||
|
|
$isConstantsDeclatation = 0;
|
||
|
|
}
|
||
|
|
# determine indent level
|
||
|
|
my $indentLevel = $currentLevel;
|
||
|
|
if ($line eq 'begin') { $indentLevel = $indentLevel - 1; }
|
||
|
|
if ($isConstantsDeclatation) { $indentLevel = $indentLevel + 2; }
|
||
|
|
if ($isVariablesDeclatation) { $indentLevel = $indentLevel + 2; }
|
||
|
|
if ($line eq 'const') { $indentLevel = $indentLevel - 1; }
|
||
|
|
if ($line eq 'var') { $indentLevel = $indentLevel - 1; }
|
||
|
|
if ($line eq 'end.') { $indentLevel = $indentLevel - 1; }
|
||
|
|
# write to output file
|
||
|
|
my $indentedLine = ($indent x $indentLevel) . $line;
|
||
|
|
$indentedLine = sprintf('%2d: ', $indentLevel) . $indentedLine;
|
||
|
|
if ($isStartOfProgramDeclatation == 0) {
|
||
|
|
print(outputFile "$indentedLine\n");
|
||
|
|
} else {
|
||
|
|
$startOfProgramDeclatation .= "$indentedLine\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------------------
|
||
|
|
# Process constant declarations
|
||
|
|
#
|
||
|
|
%constants = buildConstants($mainProgram, %constants);
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------------------
|
||
|
|
# Assign registers to variables
|
||
|
|
#
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print $indent x 2 . "Writing registers assignments in \"$registersFileSpec\"\n";
|
||
|
|
}
|
||
|
|
%variables = assignRegisters($mainProgram, $firstRegister, %variables);
|
||
|
|
open(registersFile, ">$registersFileSpec") or die "Unable to open file, $!";
|
||
|
|
foreach my $subroutine (keys(%variables)) {
|
||
|
|
print(registersFile "$subroutine\n");
|
||
|
|
my $registers_ref = $variables{$subroutine};
|
||
|
|
my %registers = reverse(%$registers_ref);
|
||
|
|
foreach my $register (sort(keys(%registers))) {
|
||
|
|
print(registersFile "${indent}$register:$registers{$register}\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(registersFile);
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Process constants and variables and functions
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: replacing constants and variables\n";
|
||
|
|
}
|
||
|
|
# build main program variables hash
|
||
|
|
my $variables_ref = $variables{$mainProgram};
|
||
|
|
%mainProgramVariables = %$variables_ref;
|
||
|
|
# loop on program code
|
||
|
|
my $currentRoutine;
|
||
|
|
my %localVariables;
|
||
|
|
my $printLine = 1;
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
# write constants at beginning of file
|
||
|
|
foreach my $routine (keys(%constants)) {
|
||
|
|
my $replacement_ref = $constants{$routine};
|
||
|
|
foreach my $constant (sort(keys(%$replacement_ref))) {
|
||
|
|
print(outputFile "const $constant = $$replacement_ref{$constant};\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# strip line nb and leading spaces
|
||
|
|
my $strippedLine = $line;
|
||
|
|
$strippedLine =~ s/\A\s*\d*\:*\s*//;
|
||
|
|
#print "$strippedLine\n";
|
||
|
|
# find current function name
|
||
|
|
if (
|
||
|
|
($strippedLine =~ m/\Aprocedure /i) or
|
||
|
|
($strippedLine =~ m/\Afunction /i) or
|
||
|
|
($strippedLine =~ m/\Aprogram /i)
|
||
|
|
) {
|
||
|
|
$currentRoutine = $strippedLine;
|
||
|
|
$currentRoutine =~ s/\A\S+\s+//;
|
||
|
|
$currentRoutine =~ s/\(.*//;
|
||
|
|
$currentRoutine =~ s/\;//;
|
||
|
|
#print "$currentRoutine\n";
|
||
|
|
# build current variables hash
|
||
|
|
my $variables_ref = $variables{$currentRoutine};
|
||
|
|
%localVariables = %$variables_ref;
|
||
|
|
}
|
||
|
|
# cut out constant and variable declarations of the program
|
||
|
|
if ($strippedLine =~ m/\Aconst\Z/) {
|
||
|
|
$printLine = 0;
|
||
|
|
}
|
||
|
|
if ($strippedLine =~ m/\Avar\Z/) {
|
||
|
|
$printLine = 0;
|
||
|
|
}
|
||
|
|
if ($strippedLine eq 'begin') {
|
||
|
|
$printLine = 1;
|
||
|
|
}
|
||
|
|
# replace variables
|
||
|
|
foreach my $variable (keys(%localVariables)) {
|
||
|
|
$line =~ s/$variable/$localVariables{$variable}/g;
|
||
|
|
}
|
||
|
|
foreach my $variable (keys(%mainProgramVariables)) {
|
||
|
|
$line =~ s/$variable/$mainProgramVariables{$variable}/g;
|
||
|
|
}
|
||
|
|
# write output
|
||
|
|
if ($printLine) {
|
||
|
|
print(outputFile "$line\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Label subroutines and loops
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: labelling subroutines and loops\n";
|
||
|
|
}
|
||
|
|
# loop on program code
|
||
|
|
my $previousWasElse = 0;
|
||
|
|
my $labelcount = 0;
|
||
|
|
my $blockKind;
|
||
|
|
my @labels;
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# get current level
|
||
|
|
my $currentLevel = $line;
|
||
|
|
$currentLevel =~ s/\A\s*(\d*)\:.*/$1/;
|
||
|
|
# strip level depth and leading spaces
|
||
|
|
$line =~ s/\A\s*\d*\:\s*//;
|
||
|
|
#print "$line\n";
|
||
|
|
# remove "begin" statements
|
||
|
|
$line =~ s/\Abegin\Z//;
|
||
|
|
# assign labels to block statements
|
||
|
|
if ($line =~ m/\Aif /) {
|
||
|
|
if (not $previousWasElse) {
|
||
|
|
$labelcount = $labelcount + 1;
|
||
|
|
$labels[$currentLevel] = sprintf('if%02d', $labelcount);
|
||
|
|
}
|
||
|
|
$line = $labels[$currentLevel] . ': ' . $line;
|
||
|
|
}
|
||
|
|
if ($line =~ m/\Afor /) {
|
||
|
|
$labelcount = $labelcount + 1;
|
||
|
|
$labels[$currentLevel] = sprintf('for%02d', $labelcount);
|
||
|
|
$line = $labels[$currentLevel] . ': ' . $line;
|
||
|
|
}
|
||
|
|
if ($line =~ m/\Awhile /) {
|
||
|
|
$labelcount = $labelcount + 1;
|
||
|
|
$labels[$currentLevel] = sprintf('while%02d', $labelcount);
|
||
|
|
$line = $labels[$currentLevel] . ': ' . $line;
|
||
|
|
}
|
||
|
|
# assign labels to end of block statements
|
||
|
|
if ($line =~ m/\Aend\s*[;\.]/) {
|
||
|
|
if ($currentLevel == 0) {
|
||
|
|
$line = 'return;';
|
||
|
|
} else {
|
||
|
|
$line = 'end ' . $labels[$currentLevel] . ';';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# specify procedure calls
|
||
|
|
for my $routine (@routines) {
|
||
|
|
$line =~ s/$routine\s*\:\=\s*/$functionReturnRegister := /g;
|
||
|
|
$line =~ s/$routine([ \(\;])/call $routine$1/g;
|
||
|
|
}
|
||
|
|
$line =~ s/\A(program|procedure|function) call /$1 /g;
|
||
|
|
# store "previous line was else"
|
||
|
|
$previousWasElse = 0;
|
||
|
|
if ($line =~ m/\Aelse\Z/) {
|
||
|
|
$previousWasElse = 1;
|
||
|
|
}
|
||
|
|
# write output
|
||
|
|
if ($line ne '') {
|
||
|
|
if ($line =~ m/(program|procedure|function) /) {
|
||
|
|
print(outputFile "\n");
|
||
|
|
}
|
||
|
|
my $indentedLine = ($indent x $currentLevel) . $line;
|
||
|
|
$indentedLine = sprintf('%2d: ', $currentLevel) . $indentedLine;
|
||
|
|
print(outputFile "$indentedLine\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Break compound operations
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: breaking compound operations\n";
|
||
|
|
}
|
||
|
|
# loop on program code
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# get current level
|
||
|
|
my $currentLevel = $line;
|
||
|
|
$currentLevel =~ s/\A\s*(\d*)\:.*/$1/;
|
||
|
|
# strip level depth and leading spaces
|
||
|
|
$line =~ s/\A\s*\d*\:\s*//;
|
||
|
|
#print "$line\n";
|
||
|
|
# check assignments
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*(.+)\s*\;/) {
|
||
|
|
my $destinationRegister = "s$1";
|
||
|
|
my $assignment = $2;
|
||
|
|
$line = expandAssignment($destinationRegister, $assignment);
|
||
|
|
}
|
||
|
|
# write output
|
||
|
|
if ($line ne '') {
|
||
|
|
my $indentedLine = ($indent x $currentLevel) . $line;
|
||
|
|
$indentedLine = sprintf('%2d: ', $currentLevel) . $indentedLine;
|
||
|
|
print(outputFile "$indentedLine\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Assembler file: constants, subroutines, memory access
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: writing assembler for constants, subroutines, mem and nop\n";
|
||
|
|
}
|
||
|
|
foreach my $routine (keys(%constants)) {
|
||
|
|
my $constants_ref = $constants{$routine};
|
||
|
|
foreach my $constant (sort(keys(%$constants_ref))) {
|
||
|
|
my $length = length($constant);
|
||
|
|
if ($length > $constantMaxLength) { $constantMaxLength = $length; }
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# assembler code header
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
print(outputFile "$separator1\n");
|
||
|
|
print(outputFile "$commentStart $mainProgram\n");
|
||
|
|
print(outputFile "$separator1\n");
|
||
|
|
print(outputFile "\n");
|
||
|
|
# loop on program code
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# strip level depth and leading spaces
|
||
|
|
$line =~ s/\A\s*\d*\:\s*//;
|
||
|
|
#print "$line\n";
|
||
|
|
# replace constants
|
||
|
|
if ($line =~ m/\Aconst (.*?)\s*\=\s*\$(.*?)\;/) {
|
||
|
|
my $constantName = fillString("$1,", ' ', $constantMaxLength+1);
|
||
|
|
my $constantValue = sprintf("%0${wordHexCharNb}X", hex($2));
|
||
|
|
$line = "$asmFirstIndent CONSTANT $constantName $constantValue";
|
||
|
|
}
|
||
|
|
# replace subroutines start
|
||
|
|
if ($line =~ m/\A(program|procedure|function) (.*?)\s*[\;\(]/) {
|
||
|
|
my $routineKind = $1;
|
||
|
|
my $routineName = $2;
|
||
|
|
print(outputFile "\n");
|
||
|
|
print(outputFile "$separator2\n");
|
||
|
|
print(outputFile "$commentStart $routineKind $routineName\n");
|
||
|
|
print(outputFile "$separator2\n");
|
||
|
|
print(outputFile ' ' x (length($asmFirstIndent) - length($routineName) - 2) . "$routineName: NOP\n");
|
||
|
|
$line = '';
|
||
|
|
}
|
||
|
|
# replace subroutines return
|
||
|
|
$line =~ s/\Areturn\;/${asmFirstIndent}RETURN/;
|
||
|
|
# replace subroutine calls with arguments
|
||
|
|
if ($line =~ m/call (.*?)\s*\((.*?)\s*\)\s*\;/) {
|
||
|
|
my $routineName = $1;
|
||
|
|
my $routineArguments = $2;
|
||
|
|
$routineArguments =~ s/var //g;
|
||
|
|
$routineArguments =~ s/\;/,/g;
|
||
|
|
$argumentText = 'argument';
|
||
|
|
if($routineArguments =~ m/\,/) {
|
||
|
|
$argumentText .= 's';
|
||
|
|
}
|
||
|
|
print(
|
||
|
|
outputFile
|
||
|
|
"$asmFirstIndent"
|
||
|
|
. fillString('CALL', ' ', $opcodeLength)
|
||
|
|
. "$routineName ; $argumentText: $routineArguments\n"
|
||
|
|
);
|
||
|
|
if ($line =~ m/\A(.*?)\s*\:\=\s* call/) {
|
||
|
|
$returnRegister = $1;
|
||
|
|
$line = "$returnRegister := s0;\n";
|
||
|
|
} else {
|
||
|
|
$line = '';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# replace subroutine calls without arguments
|
||
|
|
if ($line =~ m/\Acall (.*?)\;/) {
|
||
|
|
$line = $asmFirstIndent . fillString('CALL', ' ', $opcodeLength) . $1;
|
||
|
|
}
|
||
|
|
# memory write
|
||
|
|
if ($line =~ m/mem\[(.+?)\]\s*\:\=\s*(.+)\s*\;/) {
|
||
|
|
my $opcode = fillString('OUTPUT', ' ', $opcodeLength);
|
||
|
|
$line = "$memoryAccessRegister := $1;";
|
||
|
|
$line .= "\n${asmFirstIndent}${opcode}$2, ($memoryAccessRegister)";
|
||
|
|
}
|
||
|
|
# memory read
|
||
|
|
if ($line =~ m/\s*(.+)\s*\:\=\s*mem\[(.+?)\]\s*\;/) {
|
||
|
|
my $opcode = fillString('INPUT', ' ', $opcodeLength);
|
||
|
|
$line = "$memoryAccessRegister := $2;";
|
||
|
|
$line .= "\n${asmFirstIndent}${opcode}$memoryAccessRegister, ($memoryAccessRegister)" x 2;
|
||
|
|
$line .= "\n$1 := $memoryAccessRegister;";
|
||
|
|
}
|
||
|
|
# NOP
|
||
|
|
if ($line =~ m/\s*noOperation\s*\;/) {
|
||
|
|
$line = "${asmFirstIndent}NOP";
|
||
|
|
}
|
||
|
|
# write output
|
||
|
|
if ($line ne '') {
|
||
|
|
print(outputFile "$line\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ==============================================================================
|
||
|
|
# Assembler file: register transfers
|
||
|
|
#
|
||
|
|
$currentPass = $currentPass + 1;
|
||
|
|
($inputFileSpec, $outputFileSpec) = swapTempFileSpecs(
|
||
|
|
$inputFileSpec, $outputFileSpec, $temp1FileSpec, $temp2FileSpec
|
||
|
|
);
|
||
|
|
if ($verbose > 0) {
|
||
|
|
print "${indent}Pass $currentPass: writing assembler for load, add, and sub\n";
|
||
|
|
}
|
||
|
|
# loop on program code
|
||
|
|
open(inputFile, "<$inputFileSpec") or die "Unable to open file, $!";
|
||
|
|
open(outputFile, ">$outputFileSpec") or die "Unable to open file, $!";
|
||
|
|
while(my $line = <inputFile>) {
|
||
|
|
chomp($line);
|
||
|
|
#print "$line\n";
|
||
|
|
# LOAD
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*(.+)\s*\;/) {
|
||
|
|
my $destinationRegister = fillString("s$1,", ' ', $firstArgumentLength);
|
||
|
|
my $source = translateArgument($2, $wordHexCharNb);
|
||
|
|
my $opcode = fillString('LOAD', ' ', $opcodeLength);
|
||
|
|
if ($source ne '') {
|
||
|
|
$line = "${asmFirstIndent}${opcode}${destinationRegister}$source";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# ADD
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*s(\d+)\s*\+\s*(.+)\s*\;/) {
|
||
|
|
if ($1 eq $2) {
|
||
|
|
my $destinationRegister = fillString("s$1,", ' ', $firstArgumentLength);
|
||
|
|
my $source = translateArgument($3, $wordHexCharNb);
|
||
|
|
my $opcode = fillString('ADD', ' ', $opcodeLength);
|
||
|
|
if ($source ne '') {
|
||
|
|
$line = "${asmFirstIndent}${opcode}${destinationRegister}$source";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# SUB
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*s(\d+)\s*\-\s*(.+)\s*\;/) {
|
||
|
|
if ($1 eq $2) {
|
||
|
|
my $destinationRegister = fillString("s$1,", ' ', $firstArgumentLength);
|
||
|
|
my $source = translateArgument($3, $wordHexCharNb);
|
||
|
|
my $opcode = fillString('SUB', ' ', $opcodeLength);
|
||
|
|
if ($source ne '') {
|
||
|
|
$line = "${asmFirstIndent}${opcode}${destinationRegister}$source";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# AND
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*s(\d+)\s*and\s*(.+)\s*\;/i) {
|
||
|
|
if ($1 eq $2) {
|
||
|
|
my $destinationRegister = fillString("s$1,", ' ', $firstArgumentLength);
|
||
|
|
my $source = translateArgument($3, $wordHexCharNb);
|
||
|
|
my $opcode = fillString('AND', ' ', $opcodeLength);
|
||
|
|
if ($source ne '') {
|
||
|
|
$line = "${asmFirstIndent}${opcode}${destinationRegister}$source";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# OR
|
||
|
|
if ($line =~ m/s(\d+)\s*\:\=\s*s(\d+)\s*or\s*(.+)\s*\;/i) {
|
||
|
|
if ($1 eq $2) {
|
||
|
|
my $destinationRegister = fillString("s$1,", ' ', $firstArgumentLength);
|
||
|
|
my $source = translateArgument($3, $wordHexCharNb);
|
||
|
|
my $opcode = fillString('OR', ' ', $opcodeLength);
|
||
|
|
if ($source ne '') {
|
||
|
|
$line = "${asmFirstIndent}${opcode}${destinationRegister}$source";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# write output
|
||
|
|
if ($line ne '') {
|
||
|
|
print(outputFile "$line\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close(outputFile);
|
||
|
|
close(inputFile);
|
||
|
|
# keep intermediate file
|
||
|
|
if ($keepIntermediateFiles) {
|
||
|
|
my $textfile = "$baseFileSpec$currentPass.txt";
|
||
|
|
use File::Copy;
|
||
|
|
unlink($textfile);
|
||
|
|
copy($outputFileSpec, $textfile) or die "File cannot be copied.";
|
||
|
|
}
|
||
|
|
|
||
|
|
################################################################################
|
||
|
|
# Documentation (access it with: perldoc <scriptname>)
|
||
|
|
#
|
||
|
|
__END__
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
nanoPascal.pl - Transforms a Pascal program into assembler code
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
nanoPascal.pl [options]
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
This is a simple parser which translates Pascal expressions into their assembler
|
||
|
|
code equivalents for the nanoBlaze processor.
|
||
|
|
The process doesn't optimize the code.
|
||
|
|
The expressions which couldn't be translated into assembler are left as Pascal
|
||
|
|
for the user to translate manually.
|
||
|
|
|
||
|
|
=head1 OPTIONS
|
||
|
|
|
||
|
|
=over 8
|
||
|
|
|
||
|
|
=item B<-h>
|
||
|
|
|
||
|
|
Display a help message.
|
||
|
|
|
||
|
|
=item B<-v>
|
||
|
|
|
||
|
|
Be verbose.
|
||
|
|
|
||
|
|
=item B<-k>
|
||
|
|
|
||
|
|
Makes a copy of the intermediate files between the passes.
|
||
|
|
|
||
|
|
=item B<-c>
|
||
|
|
|
||
|
|
Cleans the temporary work files at the end of the process.
|
||
|
|
|
||
|
|
Specify a username in the bridge's whitelist.
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=head1 Limitations
|
||
|
|
|
||
|
|
There is currently no Pascal syntax error detection.
|
||
|
|
|
||
|
|
The script doesn't distinguish between constants having the same name within
|
||
|
|
different procedures or functions.
|
||
|
|
This can be corrected in future versions.
|
||
|
|
|
||
|
|
Procedure and function calls basically don't support passing parameters.
|
||
|
|
This would require a stack mechanism.
|
||
|
|
The only possible way to pass parameters is to declare global variables
|
||
|
|
and use these as parameters for the procedure and function calls.
|
||
|
|
|
||
|
|
The Pascal C<if ... then> construct is either followed by a C<begin ... end>
|
||
|
|
block or a single expression.
|
||
|
|
The script only handles single-line expressions.
|
||
|
|
Other more complex expressions (like a nested c<if .. then> need a
|
||
|
|
C<begin ... end> structure.
|
||
|
|
|
||
|
|
=head1 AUTHOR
|
||
|
|
|
||
|
|
Francois Corthay, HEVs
|
||
|
|
|
||
|
|
=head1 VERSION
|
||
|
|
|
||
|
|
1.1, 2014
|
||
|
|
|
||
|
|
=cut
|