TINY11ELF Code

program TINY11ELF;
{$Apptype Console}
uses
  SysUtils;

{ Type declarations }
type
  Symbol = string[8];
  SymTab = array[1 .. 1000] of Symbol;
  TabPtr = ^SymTab;

{ Constant declarations }
const
  TAB = ^I;
  CR  = ^M;
  LF  = ^J;
  MaxEntry = 100;

  { Definition of keywords and token types }
  NKW =   9;
  NKW1 = 10;
  KWlist : array[1 .. NKW] of Symbol =
                ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
                 'READ', 'WRITE', 'VAR', 'END');

  KWcode : string[NKW1] = 'xileweRWve';

{ Variable declarations }
var
  Look : char;             { Lookahead character }
  Token : char;            { Encoded token       }
  Value : string[16];      { Unencoded token     }

  ST : array[1 .. MaxEntry] of Symbol;
  SType : array[1 .. MaxEntry] of char;
  LCount : integer = 0;
  NEntry : integer = 0;
  SourceFile, AsmFile : textfile;  //GCC INTEGRATION

{ Read new character from input stream }
procedure GetChar; //GCC INTEGRATION
begin
  Read(SourceFile, Look);
end;

{ Report an error }
procedure Error(s : string);
begin
  WriteLn;
  WriteLn(^G, 'Error: ', s, '.');
  ReadLn;
  ReadLn;
end;

{ Report error and halt }
procedure Abort(s : string); //GCC INTEGRATION
begin
  Error(s);
  CloseFile(SourceFile);
  Closefile(AsmFile);
  Halt;
end;

{ Report what was expected }
procedure Expected(s : string);
begin
   Abort(s + ' Expected');
end;

{ Report an undefined identifier }
procedure Undefined(n : string);
begin
  Abort('Undefined Identifier ' + n);
end;

{ Report a duplicate identifier }
procedure Duplicate(n : string);
begin
  Abort('Duplicate Identifier ' + n);
end;

{ Check to make sure the current token is an identifier }
procedure CheckIdent;
begin
  if Token <> 'x' then
    Expected('Identifier');
end;

{ Recognize an alpha character }
function IsAlpha(c : char) : boolean;
begin
  IsAlpha := UpCase(c) in ['A' .. 'Z'];
end;

{ Recognize a decimal digit }
function IsDigit(c : char) : boolean;
begin
  IsDigit := c in ['0' .. '9'];
end;

{ Recognize an alphanumeric character }
function IsAlNum(c : char): boolean;
begin
  IsAlNum := IsAlpha(c) or IsDigit(c);
end;

{ Recognize an addop }
function IsAddop(c : char) : boolean;
begin
  IsAddop := c in ['+', '-'];
end;

{ Recognize a mulop }
function IsMulop(c : char): boolean;
begin
  IsMulop := c in ['*', '/'];
end;

{ Recognize a Boolean orop }
function IsOrop(c : char): boolean;
begin
  IsOrop := c in ['|', '~'];
end;

{ Recognize a relop }
function IsRelop(c : char): boolean;
begin
  IsRelop := c in ['=', '#', '<', '>'];
end;

{ Recognize white space }
function IsWhite(c : char) : boolean;
begin
  IsWhite := c in [' ', TAB, CR, LF];
end;

{ Skip over leading white space }
procedure SkipWhite;
begin
  while IsWhite(Look) do
    GetChar;
end;

{ Table lookup }
function Lookup(T : TabPtr; s : string; n : integer) : integer;
var
  i : integer;
  found : Boolean;
begin
  found := false;
  i := n;
  while (i > 0) and not found do
    if s = T^[i] then
      found := true
    else
      dec(i);
  Lookup := i;
end;

{ Locate a symbol in table
  Returns the index of the entry.  Zero if not present. }
function Locate(N : Symbol) : integer;
begin
  Locate := Lookup(@ST, n, NEntry);
end;

{ Look for symbol in table }
function InTable(n : Symbol) : Boolean;
begin
  InTable := Lookup(@ST, n, NEntry) <> 0;
end;

{ Check to see if an identifier is in the symbol table
  Report an error if it's not. }
procedure CheckTable(N : Symbol);
begin
  if not InTable(N) then
    Undefined(N);
end;

{ Check the symbol table for a duplicate identifier
 Report an error if identifier is already in table. }
procedure CheckDup(N : Symbol);
begin
  if InTable(N) then
    Duplicate(N);
end;

{ Add a new entry to symbol table }
procedure AddEntry(N : Symbol; T : char);
begin
  CheckDup(N);
  if NEntry = MaxEntry then
    Abort('Symbol Table Full');
  Inc(NEntry);
  ST[NEntry] := N;
  SType[NEntry] := T;
end;

{ Get an identifier }
procedure GetName;
begin
  SkipWhite;
  if Not IsAlpha(Look) then
    Expected('Identifier');
  Token := 'x';
  Value := '';
  repeat
    Value := Value + UpCase(Look);
    GetChar;
  until not IsAlNum(Look);
end;

{ Get a number }
procedure GetNum;
begin
  SkipWhite;
  if not IsDigit(Look) then
    Expected('Number');
  Token := '#';
  Value := '';
  repeat
    Value := Value + Look;
    GetChar;
  until not IsDigit(Look);
end;

{ Get an operator }
procedure GetOp;
begin
  SkipWhite;
  Token := Look;
  Value := Look;
  GetChar;
end;

{ Get the next input token }
procedure Next;
begin
  SkipWhite;
  if IsAlpha(Look) then
    GetName
  else if IsDigit(Look) then
    GetNum
  else
    GetOp;
end;

{ Scan the current identifier for keywords }
procedure Scan;
begin
  if Token = 'x' then
    Token := KWcode[Lookup(Addr(KWlist), Value, NKW) + 1];
end;

{ Match a specific input string }
procedure MatchString(x : string);
begin
  if Value <> x then
    Expected('''' + x + '''');
  Next;
end;

{ Output a string to file}
procedure Emit(s : string);  //GCC INTEGRATION
begin
  Write(AsmFile, s);
end;

{ Output a string with tab and CRLF }
procedure EmitLn(s : string); //GCC INTEGRATION
begin
  Emit(s);
  WriteLn(AsmFile);
end;

{ Generate a unique label }
function NewLabel : string;
var
  S : string;
begin
  Str(LCount, S);
  NewLabel := 'L' + S;
  Inc(LCount);
end;

{ Post a label to output }
procedure PostLabel(L : string);
begin
  EmitLn(L + ':');
end;

{ Clear the primary register }
procedure Clear;
begin
   EmitLn('eor r0, r0, r0');
end;

{ Negate the primary register }
procedure Negate;
begin
  EmitLn('rsb r0, r0, #0');
end;

{ Complement the primary register }
procedure NotIt;
begin
  EmitLn('mvn r0, r0');  
end;

{ Load a constant value to primary register }
procedure LoadConst(n : string);
begin
  EmitLn('ldr r0, =' + n); //Note no hash
end;

{ Load a variable to primary register }
procedure LoadVar(Name : string);
begin
  if not InTable(Name) then
     Undefined(Name);
  EmitLn('ldr r0, ' + Name);
end;

{ Push primary onto stack }
procedure Push;
begin
  EmitLn('push {r0}');
end;

{ Add top of stack to primary }
procedure PopAdd;
begin
  EmitLn('pop {r12}');
  EmitLn('add r0, r0, r12');
end;

{ Subtract primary from top of stack }
procedure PopSub;
begin
  EmitLn('pop {r12}');
  EmitLn('sub r0, r12, r0');
end;

{ Multiply top of stack by primary }
procedure PopMul;
var
  L1 : string;
begin
  L1 := NewLabel;
  EmitLn('pop {r12}');
  EmitLn('mul r0, r12, r0');
end;

{ Divide top of stack by primary }
procedure PopDiv;
begin
  EmitLn('mov r1, r0');
  EmitLn('pop {r0}');
  EmitLn('bl	__divsi3');
end;

{ AND top of stack with primary }
procedure PopAnd;
begin
  EmitLn('pop {r12}');
  EmitLn('and r0, r0, r12');
end;

{ OR top of stack with primary }
procedure PopOr;
begin
  EmitLn('pop {r12}');
  EmitLn('orr r0, r0, r12');
end;

{ XOR top of stack with primary }
procedure PopXor;
begin
  EmitLn('pop {r12}');
  EmitLn('eor r0, r0, r12');
end;

{ Compare top of stack with primary }
procedure PopCompare;
begin
  EmitLn('pop {r12}');
  EmitLn('cmp r12, r0');
end;

{ Set r0 if compare was = }
procedure SetEqual;
begin
  EmitLn('ldreq r0, T');
  EmitLn('ldrne r0, F');
end;

{ Set r0 if compare was != }
procedure SetNEqual;
begin
  EmitLn('ldreq r0, F');
  EmitLn('ldrne r0, T');
end;

{ Set r0 if compare was > }
procedure SetGreater;
begin
  EmitLn('ldrgt r0, T');
  EmitLn('ldrle r0, F');
end;

{ Set r0 if compare was < }
procedure SetLess;
begin
  EmitLn('ldrlt r0, T');
  EmitLn('ldrge r0, F');
end;

{ Set r0 if compare was <= }
procedure SetLessOrEqual;
begin
  EmitLn('ldrle r0, T');
  EmitLn('ldrgt r0, F');
end;

{ Set r0 if compare was >= }
procedure SetGreaterOrEqual;
begin
  EmitLn('ldrge r0, T');
  EmitLn('ldrlt r0, F');
end;

{ Store primary to variable }
procedure Store(Name : string);
begin
  EmitLn('adr r12, ' + Name);
  EmitLn('str r0, [r12]');
end;

{ Branch unconditional }
procedure Branch(L : string);
begin
  EmitLn('b ' + L);
end;

{ Branch False }
procedure BranchFalse(L : string);  //ARM
begin
  EmitLn('ldr r1, =-1');
  EmitLn('tst r0, r1'); //Updates CPSR flags on R0 AND -1
  EmitLn('beq ' + L);
end;

{ Read variable to primary register }
procedure ReadIt(Name : string); //GCC INTEGRATION
var
  IdentLabel : string;
begin
  Identlabel := NewLabel;
  PostLabel(IdentLabel);
  EmitLn ('.asciz "Enter ' + Name + '"');
  EmitLn ('.align 2');
  EmitLn ('ldr r0, =' + IdentLabel);
  EmitLn ('bl puts');
  EmitLn ('ldr r0, =scan_format');
  EmitLn('ldr r1, =' + Name);
  EmitLn ('bl scanf');
end;

{ Write from primary register }
procedure WriteIt; //GCC INTEGRATION
begin
  EmitLn('mov r1, r0');
  EmitLn('ldr r0, =print_format');
  EmitLn('bl printf');
end;

{ Write the prolog }
procedure Prolog;  //GCC INTEGRATION
begin
  EmitLn('.global	main');
  EmitLn('main:');
  EmitLn('push  {ip, lr}');
end;

{ Write the epilog }
procedure Epilog;  //GCC INTEGRATION
begin  
  EmitLn('pop {ip, pc}');
  CloseFile(SourceFile);
  Closefile(AsmFile);
end;

{ Allocate storage for a static variable }
procedure Allocate(Name, Val : string); //GCC INTEGRATION
begin
  EmitLn(Name + ':');
  EmitLn('.word ' + Val);
end;

{ Declare constants }
procedure Header;
begin
  EmitLn('scan_format:');
  EmitLn('.asciz "%d"');
  EmitLn('print_format:');
  EmitLn('.asciz "%d\n"');
  EmitLn('.align 2');
  EmitLn('T:');
  EmitLn('.word -1');
  EmitLn('F:');
  EmitLn('.word 0');
end;

{ Parse and translate a maths factor }
procedure BoolExpression; forward;
procedure Factor;
begin
  if Token = '(' then
    begin
      Next;
      BoolExpression;
      MatchString(')');
    end
  else
    begin
      if Token = 'x' then
        LoadVar(Value)
      else if Token = '#' then
        LoadConst(Value)
      else
        Expected('Math Factor');
      Next;
    end;
end;

{ Recognize and translate a multiply }
procedure Multiply;
begin
  Next;
  Factor;
  PopMul;
end;

{ Recognize and translate a divide }
procedure Divide;
begin
  Next;
  Factor;
  PopDiv;
end;

{ Parse and translate a math term }
procedure Term;
begin
  Factor;
  while IsMulop(Token) do
    begin
      Push;
      case Token of
        '*' : Multiply;
        '/' : Divide;
      end;
  end;
end;

{ Recognize and translate an add }
procedure Add;
begin
  Next;
  Term;
  PopAdd;
end;

{ Recognize and translate a subtract }
procedure Subtract;
begin
  Next;
  Term;
  PopSub;
end;

{ Parse and translate an expression }
procedure Expression;
begin
  if IsAddop(Token) then
    Clear
  else
    Term;
  while IsAddop(Token) do
    begin
      Push;
      case Token of
        '+' : Add;
        '-' : Subtract;
      end;
  end;
end;

{ Get another expression and compare }
procedure CompareExpression;
begin
  Expression;
  PopCompare;
end;

{ Get the next expression and compare }
procedure NextExpression;
begin
  Next;
  CompareExpression;
end;

{ Recognize and translate a relational "Equals" }
procedure Equal;
begin
  NextExpression;
  SetEqual;
end;

{ Recognize and translate a relational "Less Than or Equal" }
procedure LessOrEqual;
begin
  NextExpression;
  SetLessOrEqual;
end;

{ Recognize and translate a relational "Not Equals" }
procedure NotEqual;
begin
  NextExpression;
  SetNEqual;
end;

{ Recognize and translate a relational "Less Than" }
procedure Less;
begin
  Next;
  case Token of
    '=' : LessOrEqual;
    '>' : NotEqual;
  else
    begin
      CompareExpression;
      SetLess;
    end;
  end;
end;

{ Recognize and translate a relational "Greater Than" }
procedure Greater;
begin
  Next;
  if Token = '=' then
    begin
      NextExpression;
      SetGreaterOrEqual;
    end
  else
    begin
      CompareExpression;
      SetGreater;
    end;
end;

{ Parse and translate a relation }
procedure Relation;
begin
  Expression;
  if IsRelop(Token) then
    begin
      Push;
      case Token of
        '=' : Equal;
        '<' : Less;
        '>' : Greater;
      end;
    end;
end;

{ Parse and translate a Boolean factor with leading NOT }
procedure NotFactor;
begin
  if Token = '!' then
    begin
      Next;
      Relation;
      NotIt;
    end
  else
    Relation;
end;

{ Parse and translate a Boolean term }
procedure BoolTerm;
begin
  NotFactor;
  while Token = '&' do
    begin
      Push;
      Next;
      NotFactor;
      PopAnd;
    end;
end;

{ Recognize and translate a Boolean OR }
procedure BoolOr;
begin
  Next;
  BoolTerm;
  PopOr;
end;

{ Recognize and translate an exclusive Or }
procedure BoolXor;
begin
  Next;
  BoolTerm;
  PopXor;
end;

{ Parse and translate a Boolean expression }
procedure BoolExpression;
begin
  BoolTerm;
  while IsOrOp(Token) do
    begin
      Push;
      case Token of
        '|' : BoolOr;
        '~' : BoolXor;
      end;
    end;
end;

{ Parse and translate an assignment statement }
procedure Assignment;
var
  Name : string;
begin
  CheckTable(Value);
  Name := Value;
  Next;
  MatchString('=');
  BoolExpression;
  Store(Name);
end;

{ Recognize and translate an IF construct }
procedure Block; forward;
procedure DoIf;
var
  L1, L2 : string;
begin
  Next;
  BoolExpression;
  L1 := NewLabel;
  L2 := L1;
  BranchFalse(L1);
  Block;
  if Token = 'l' then
    begin
      Next;
      L2 := NewLabel;
      Branch(L2);
      PostLabel(L1);
      Block;
    end;
  PostLabel(L2);
  MatchString('ENDIF');
end;

{ Parse and translate a WHILE statement }
procedure DoWhile;
var
  L1, L2 : string;
begin
  Next;
  L1 := NewLabel;
  L2 := NewLabel;
  PostLabel(L1);
  BoolExpression;
  BranchFalse(L2);
  Block;
  MatchString('ENDWHILE');
  Branch(L1);
  PostLabel(L2);
end;

{ Read a single variable }
procedure ReadVar;
begin
  CheckIdent;
  CheckTable(Value);
  ReadIt(Value);
  Next;
end;

{ Process a read statement }
procedure DoRead;
begin
  Next;
  MatchString('(');
  ReadVar;
  while Token = ',' do
    begin
      Next;
      ReadVar;
    end;
  MatchString(')');
end;

{ Process a write statement }
procedure DoWrite;
begin
  Next;
  MatchString('(');
  Expression;
  WriteIt;
  while Token = ',' do
    begin
      Next;
      Expression;
      WriteIt;
    end;
  MatchString(')');
end;

{ Parse and translate a block of statements }
procedure Block;
begin
  Scan;
  while not (Token in ['e', 'l']) do
    begin
      case Token of
        'i' : DoIf;
        'w' : DoWhile;
        'R' : DoRead;
        'W' : DoWrite;
      else
        Assignment;
      end;
      Scan;
  end;
end;

{ Allocate storage for a variable }
procedure Alloc;
begin
  Next;
  if Token <> 'x' then
    Expected('Variable Name');
  CheckDup(Value);
  AddEntry(Value, 'v');
  Allocate(Value, '0');
  Next;
end;

{ Parse and translate global declarations }
procedure TopDecls;
begin
  Scan;
  while Token = 'v' do
    Alloc;
  while Token = ',' do
    Alloc;

end;

{ Initialize }
procedure Init;  //GCC INTEGRATION

begin
  AssignFile(SourceFile, 'src.txt');
  Reset(SourceFile);
  AssignFile(AsmFile, 'temp.s');
  Rewrite(AsmFile);
  GetChar;
  Next;
end;

{ Main program }
begin
  Init;
  MatchString('PROGRAM');
  Header;
  TopDecls;
  MatchString('BEGIN');
  Prolog;
  Block;
  MatchString('END');
  Epilog;
end.
Programming - a skill for life!

by PPS in association with Jack Crenshaw