kiss.pas

{------------------------------------------------------------------------------}
program KISS;


{------------------------------------------------------------------------------}
{ Constant Declarations }

const TAB = ^I;
      CR  = ^M;
      LF  = ^J;


{------------------------------------------------------------------------------}
{ 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 }
    LCount : integer;    { Label Counter }


{------------------------------------------------------------------------------}
{ Definition of Keywords and Token Types }

const KWlist : array[1..4] of Symbol = ('IF', 'ELSE', 'ENDIF', 'END');
const KWcode : string[5] =  'xilee';


{------------------------------------------------------------------------------}
{ 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;


{------------------------------------------------------------------------------}
{ 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 White Space }

function IsWhite(c : char) : boolean;
begin
   IsWhite := c in [' ', TAB];
end;


{------------------------------------------------------------------------------}
{ Skip Over Leading White Space }

procedure SkipWhite;
begin
   while IsWhite(Look) do
      GetChar;
end;


{------------------------------------------------------------------------------}
{ Match a Specific Input Character }

procedure Match(x : char);
begin
   if Look <> x then Expected('''' + x + '''');
   GetChar;
   SkipWhite;
end;


{------------------------------------------------------------------------------}
{ Skip a CRLF }

procedure Fin;
begin
   if Look = CR then GetChar;
   if Look = LF then GetChar;
   SkipWhite;
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;


{------------------------------------------------------------------------------}
{ Get an Identifier }

procedure GetName;
begin
   while Look = LF do
      Fin;
   if not IsAlpha(Look) then Expected('Name');
   Value := '';
   while IsAlNum(Look) do begin
      Value := Value + UpCase(Look);
      GetChar;
   end;
   SkipWhite;
end;


{------------------------------------------------------------------------------}
{ Get a Number }

procedure GetNum;
begin
   if not IsDigit(Look) then Expected('Integer');
   Value := '';
   while IsDigit(Look) do begin
      Value := Value + Look;
      GetChar;
   end;
   Token := '#';
   SkipWhite;
end;


{------------------------------------------------------------------------------}
{ Get an Identifier and Scan it for Keywords }

procedure Scan;
begin
   GetName;
   Token := KWcode[Lookup(Addr(KWlist), Value, 4) + 1];
end;


{------------------------------------------------------------------------------}
{ Match a Specific Input String }

procedure MatchString(x : string);
begin
   if Value <> x then Expected('''' + x + '''');
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;


{------------------------------------------------------------------------------}
{ 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;


{------------------------------------------------------------------------------}
{ Parse and Translate an Identifier }

procedure Ident;
begin
   GetName;
   if Look = '(' then begin
      Match('(');
      Match(')');
      EmitLn('BSR ' + Value);
      end
   else
      EmitLn('MOVE ' + Value + '(PC),D0');
end;


{------------------------------------------------------------------------------}
{ Parse and Translate a Math Factor }

procedure Expression; Forward;

   procedure Factor;
   begin
      if Look = '(' then begin
         Match('(');
         Expression;
         Match(')');
         end
      else if IsAlpha(Look) then
         Ident
      else begin
         GetNum;
         EmitLn('MOVE #' + Value + ',D0');
      end;
   end;


{------------------------------------------------------------------------------}
{ Parse and Translate the First Math Factor }

procedure SignedFactor;
var s : boolean;
begin
   s := Look = '-';
   if IsAddop(Look) then begin
      GetChar;
      SkipWhite;
   end;
   Factor;
   if s then
      EmitLn('NEG D0');
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate a Multiply }

procedure Multiply;
begin
   Match('*');
   Factor;
   EmitLn('MULS (SP)+,D0');
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate a Divide }

procedure Divide;
begin
   Match('/');
   Factor;
   EmitLn('MOVE (SP)+,D1');
   EmitLn('EXS.L D0');
   EmitLn('DIVS D1,D0');
end;


{------------------------------------------------------------------------------}
{ Completion of Term Processing (called by Term and FirstTerm) }

procedure Term1;
begin
   while IsMulop(Look) do begin
      EmitLn('MOVE D0,-(SP)');
      case Look of
        '*' : Multiply;
        '/' : Divide;
      end;
   end;
end;


{------------------------------------------------------------------------------}
{ Parse and Translate a Math Term }

procedure Term;
begin
   Factor;
   Term1;
end;


{------------------------------------------------------------------------------}
{ Parse and Translate a Math Term with Possible Leading Sign }

procedure FirstTerm;
begin
   SignedFactor;
   Term1;
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate an Add }

procedure Add;
begin
   Match('+');
   Term;
   EmitLn('ADD (SP)+,D0');
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate a Subtract }

procedure Subtract;
begin
   Match('-');
   Term;
   EmitLn('SUB (SP)+,D0');
   EmitLn('NEG D0');
end;


{------------------------------------------------------------------------------}
{ Parse and Translate an Expression }

procedure Expression;
begin
   FirstTerm;
   while IsAddop(Look) do begin
      EmitLn('MOVE D0,-(SP)');
      case Look of
        '+' : Add;
        '-' : Subtract;
      end;
   end;
end;


{------------------------------------------------------------------------------}
{ Parse and Translate a Boolean Condition }
{ This version is a dummy }

procedure Condition;
begin
   EmitLn('Condition');
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate an IF construct }

procedure Block; Forward;

   procedure DoIf;
   var L1, L2 : string;
   begin
      Condition;
      L1 := NewLabel;
      L2 := L1;
      EmitLn('BEQ ' + L1);
      Block;
      if Token = 'l' then begin
         L2 := NewLabel;
         EmitLn('BRA ' + L2);
         PostLabel(L1);
         Block;
      end;
      PostLabel(L2);
      MatchString('ENDIF');
   end;


{------------------------------------------------------------------------------}
{ Parse and Translate an Assignment Statement }

procedure Assignment;
var Name : string;
begin
   Name := Value;
   Match('=');
   Expression;
   EmitLn('LEA ' + Name + '(PC),A0');
   EmitLn('MOVE D0,(A0)');
end;


{------------------------------------------------------------------------------}
{ Recognize and Translate a Statement Block }

procedure Block;
begin
   Scan;
   while not (Token in ['e', 'l']) do begin
      case Token of
        'i' : DoIf;
      else Assignment;
      end;
      Scan;
   end;
end;


{------------------------------------------------------------------------------}
{ Parse and Translate a Program }

procedure DoProgram;
begin
   Block;
   MatchString('END');
   EmitLn('END');
end;


{------------------------------------------------------------------------------}
{ Initialize }

procedure Init;
begin
   LCount := 0;
   GetChar;
end;


{------------------------------------------------------------------------------}
{ Main Program }

begin
   Init;
   DoProgram;
end.
{------------------------------------------------------------------------------}