program Tiny11;

{ Constant Declarations }
const TAB = ^I;
      CR  = ^M;
      LF  = ^J;

      LCount: integer = 0;
      NEntry: integer = 0;

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

{ Variable Declarations }
var Look : char;             { Lookahead Character }
    Token: char;             { Encoded Token       }
    Value: string[16];       { Unencoded Token     }

const MaxEntry = 100;

var ST   : array[1..MaxEntry] of Symbol;
    SType: array[1..MaxEntry] of char;

{ Definition of Keywords and Token Types }
const NKW =   9;
      NKW1 = 10;

const KWlist: array[1..NKW] of Symbol =
              ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
               'READ', 'WRITE', 'VAR', 'END');

const KWcode: string[NKW1] = 'xileweRWve';

{ Read New Character From Input Stream }
procedure GetChar;
begin
   Read(Look);
end;

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

{ Report Error and Halt }
procedure Abort(s: string);
begin
   Error(s);
   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 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 with Tab }
procedure Emit(s: string);
begin
   Write(TAB, s);
end;

{ Output a String with Tab and CRLF }
procedure EmitLn(s: string);
begin
   Emit(s);
   WriteLn;
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
   WriteLn(L, ':');
end;

{ Clear the Primary Register }
procedure Clear;
begin
   EmitLn('CLR D0');
end;

{ Negate the Primary Register }
procedure Negate;
begin
   EmitLn('NEG D0');
end;

{ Complement the Primary Register }
procedure NotIt;
begin
   EmitLn('NOT D0');
end;

{ Load a Constant Value to Primary Register }
procedure LoadConst(n: string);
begin
   Emit('MOVE #');
   WriteLn(n, ',D0');
end;

{ Load a Variable to Primary Register }
procedure LoadVar(Name: string);
begin
   if not InTable(Name) then Undefined(Name);
   EmitLn('MOVE ' + Name + '(PC),D0');
end;

{ Push Primary onto Stack }
procedure Push;
begin
   EmitLn('MOVE D0,-(SP)');
end;

{ Add Top of Stack to Primary }
procedure PopAdd;
begin
   EmitLn('ADD (SP)+,D0');
end;

{ Subtract Primary from Top of Stack }
procedure PopSub;
begin
   EmitLn('SUB (SP)+,D0');
   EmitLn('NEG D0');
end;

{ Multiply Top of Stack by Primary }
procedure PopMul;
begin
   EmitLn('MULS (SP)+,D0');
end;

{ Divide Top of Stack by Primary }
procedure PopDiv;
begin
   EmitLn('MOVE (SP)+,D7');
   EmitLn('EXT.L D7');
   EmitLn('DIVS D0,D7');
   EmitLn('MOVE D7,D0');
end;

{ AND Top of Stack with Primary }
procedure PopAnd;
begin
   EmitLn('AND (SP)+,D0');
end;

{ OR Top of Stack with Primary }
procedure PopOr;
begin
   EmitLn('OR (SP)+,D0');
end;

{ XOR Top of Stack with Primary }
procedure PopXor;
begin
   EmitLn('EOR (SP)+,D0');
end;

{ Compare Top of Stack with Primary }
procedure PopCompare;
begin
   EmitLn('CMP (SP)+,D0');
end;

{ Set D0 If Compare was = }
procedure SetEqual;
begin
   EmitLn('SEQ D0');
   EmitLn('EXT D0');
end;

{ Set D0 If Compare was != }
procedure SetNEqual;
begin
   EmitLn('SNE D0');
   EmitLn('EXT D0');
end;

{ Set D0 If Compare was > }
procedure SetGreater;
begin
   EmitLn('SLT D0');
   EmitLn('EXT D0');
end;

{ Set D0 If Compare was < }
procedure SetLess;
begin
   EmitLn('SGT D0');
   EmitLn('EXT D0');
end;

{ Set D0 If Compare was <= }
procedure SetLessOrEqual;
begin
   EmitLn('SGE D0');
   EmitLn('EXT D0');
end;

{ Set D0 If Compare was >= }
procedure SetGreaterOrEqual;
begin
   EmitLn('SLE D0');
   EmitLn('EXT D0');
end;

{ Store Primary to Variable }
procedure Store(Name: string);
begin
   EmitLn('LEA ' + Name + '(PC),A0');
   EmitLn('MOVE D0,(A0)')
end;

{ Branch Unconditional  }
procedure Branch(L: string);
begin
   EmitLn('BRA ' + L);
end;

{ Branch False }
procedure BranchFalse(L: string);
begin
   EmitLn('TST D0');
   EmitLn('BEQ ' + L);
end;

{ Read Variable to Primary Register }
procedure ReadIt(Name: string);
begin
   EmitLn('BSR READ');
   Store(Name);
end;

{ Write from Primary Register }
procedure WriteIt;
begin
   EmitLn('BSR WRITE');
end;

{ Write Header Info }
procedure Header;
begin
   WriteLn('WARMST', TAB, 'EQU $A01E');
end;

{ Write the Prolog }
procedure Prolog;
begin
   PostLabel('MAIN');
end;

{ Write the Epilog }
procedure Epilog;
begin
   EmitLn('DC WARMST');
   EmitLn('END MAIN');
end;

{ Allocate Storage for a Static Variable }
procedure Allocate(Name, Val: string);
begin
   WriteLn(Name, ':', TAB, 'DC ', Val);
end;

{ Parse and Translate a Math 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;
begin
   GetChar;
   Next;
end;

{ Main Program }
begin
   Init;
   MatchString('PROGRAM');
   Header;
   TopDecls;
   MatchString('BEGIN');
   Prolog;
   Block;
   MatchString('END');
   Epilog;
end.