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

      {–}
      { Add a New Entry to Symbol Table }
      procedure AddEntry(N: Symbol; T: char);
      begin
      if InTable(N) then Abort('Duplicate Identifier ' + N);
      if NEntry = MaxEntry then Abort('Symbol Table Full');
      Inc(NEntry);
      ST[NEntry] := N;
      SType[NEntry] := T;
      end;
      {–}

      {–}
      { Allocate Storage for a Variable }
      procedure Alloc(N: Symbol);
      begin
      if InTable(N) then Abort('Duplicate Variable Name ' + N);
      AddEntry(N, 'v');
      .
      .
      .
      {–}

      {–}
      { Initialize }
      procedure Init;
      var i: integer;
      begin
      for i := 1 to MaxEntry do begin
      ST[i] := '';
      SType[i] := ' ';
      end;
      GetChar;
      Scan;
      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;
      {–}

      {–}
      { Recognize and Translate a Relational «Less Than or Equal» }
      procedure LessOrEqual;
      begin
      Match('=');
      Expression;
      PopCompare;
      SetLessOrEqual;
      end;
      {–}
      { Recognize and Translate a Relational «Not Equals» }
      procedure NotEqual;
      begin
      Match('>');
      Expression;
      PopCompare;
      SetNEqual;
      end;
      {–}
      { Recognize and Translate a Relational «Less Than» }
      procedure Less;
      begin
      Match('<');
      case Look of
      '=': LessOrEqual;
      '>': NotEqual;
      else begin
      Expression;
      PopCompare;
      SetLess;
      end;
      end;
      end;
      {–}
      { Recognize and Translate a Relational «Greater Than» }
      procedure Greater;
      begin
      Match('>');
      if Look = '=' then begin
      Match('=');
      Expression;
      PopCompare;
      SetGreaterOrEqual;
      end
      else begin
      Expression;
      PopCompare;
      SetGreater;
      end;
      end;
      {–}

      {–}
      { Read Variable to Primary Register }
      procedure ReadVar;
      begin
      EmitLn('BSR READ');
      Store(Value);
      end;
      {–}
      { Write Variable from Primary Register }
      procedure WriteVar;
      begin
      EmitLn('BSR WRITE');
      end;
      {–}

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

      {–}
      { Definition of Keywords and Token Types }
      const NKW = 11;
      NKW1 = 12;
      const KWlist: array[1..NKW] of Symbol =
      ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
      'READ', 'WRITE', 'VAR', 'BEGIN', 'END',
      'PROGRAM');
      const KWcode: string[NKW1] = 'xileweRWvbep';
      {–}

      {–}
      { Process a Read Statement }
      procedure DoRead;
      begin
      Match('(');
      GetName;
      ReadVar;
      while Look = ',' do begin
      Match(',');
      GetName;
      ReadVar;
      end;
      Match(')');
      end;
      {–}
      { Process a Write Statement }
      procedure DoWrite;
      begin
      Match('(');
      Expression;
      WriteVar;
      while Look = ',' do begin
      Match(',');
      Expression;
      WriteVar;
      end;
      Match(')');
      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;
      {–}

      {–}
      program Tiny10;
      {–}
      { 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 = 11;
      NKW1 = 12;
      const KWlist: array[1..NKW] of Symbol =
      ('IF', 'ELSE', 'ENDIF', 'WHILE', 'ENDWHILE',
      'READ', 'WRITE', 'VAR', 'BEGIN', 'END',
      'PROGRAM');
      const KWcode: string[NKW1] = 'xileweRWvbep';
      {–}
      { 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;
      {–}
      { 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];
      end;
      {–}
      { Skip Over Leading White Space }
      procedure SkipWhite;
      begin
      while IsWhite(Look) do
      GetChar;
      end;
      {–}
      { Skip Over an End-of-Line }
      procedure NewLine;
      begin
      while Look = CR do begin
      GetChar;
      if Look = LF then GetChar;
      SkipWhite;
      end;
      end;
      {–}
      { Match a Specific Input Character }
      procedure Match(x: char);
      begin
      NewLine;
      if Look = x then GetChar
      else Expected('''' + x + '''');
      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;
      {–}
      { 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, MaxEntry);
      end;
      {–}
      { Look for Symbol in Table }
      function InTable(n: Symbol): Boolean;
      begin
      InTable := Lookup(@ST, n, MaxEntry) <> 0;
      end;
      {–}
      { Add a New Entry to Symbol Table }
      procedure AddEntry(N: Symbol; T: char);
      begin
      if InTable(N) then Abort('Duplicate Identifier ' + N);
      if NEntry = MaxEntry then Abort('Symbol Table Full');
      Inc(NEntry);
      ST[NEntry] := N;
      SType[NEntry] := T;
      end;
      {–}
      { Get an Identifier }
      procedure GetName;
      begin
      NewLine;
      if not IsAlpha(Look) then Expected('Name');
      Value := '';
      while IsAlNum(Look) do begin
      Value := Value + UpCase(Look);
      GetChar;
      end;
      SkipWhite;
      end;
      {–}
      { Get a Number }
      function GetNum: integer;
      var Val: integer;
      begin
      NewLine;
      if not IsDigit(Look) then Expected('Integer');
      Val := 0;
      while IsDigit(Look) do begin
      Val := 10 * Val + Ord(Look) – Ord('0');
      GetChar;
      end;
      GetNum := Val;
      SkipWhite;
      end;
      {–}
      { Get an Identifier and Scan it for Keywords }
      procedure Scan;
      begin
      GetName;
      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 + '''');
      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: integer);
      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
      if not InTable(Name) then Undefined(Name);
      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 ReadVar;
      begin
      EmitLn('BSR READ');
      Store(Value[1]);
      end;
      { Write Variable from Primary Register }
      procedure WriteVar;
      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;
      {–}
      { Parse and Translate a Math Factor }
      procedure BoolExpression; Forward;
      procedure Factor;
      begin
      if Look = '(' then begin
      Match('(');
      BoolExpression;
      Match(')');
      end
      else if IsAlpha(Look) then begin
      GetName;
      LoadVar(Value);
      end
      else
      LoadConst(GetNum);
      end;
      {–}
      { Parse and Translate a Negative Factor }
      procedure NegFactor;
      begin
      Match('-');
      if IsDigit(Look) then
      LoadConst(-GetNum)
      else begin
      Factor;
      Negate;
      end;
      end;
      {–}
      { Parse and Translate a Leading Factor }
      procedure FirstFactor;
      begin
      case Look of
      '+': begin
      Match('+');
      Factor;
      end;
      '-': NegFactor;
      else Factor;
      end;
      end;
      {–}
      { Recognize and Translate a Multiply }
      procedure Multiply;
      begin
      Match('*');
      Factor;
      PopMul;
      end;
      {–}
      { Recognize and Translate a Divide }
      procedure Divide;
      begin
      Match('/');
      Factor;
      PopDiv;
      end;
      {–}
      { Common Code Used by Term and FirstTerm }
      procedure Term1;
      begin
      while IsMulop(Look) do begin
      Push;
      case Look of
      '*': Multiply;
      '/': Divide;
      end;
      end;
      end;
      {–}
      { Parse and Translate a Math Term }
      procedure Term;
      begin
      Factor;
      Term1;
      end;
      {–}
      { Parse and Translate a Leading Term }
      procedure FirstTerm;
      begin
      FirstFactor;
      Term1;
      end;
      {–}
      { Recognize and Translate an Add }
      procedure Add;
      begin
      Match('+');
      Term;
      PopAdd;
      end;
      {–}
      { Recognize and Translate a Subtract }
      procedure Subtract;
      begin
      Match('-');
      Term;
      PopSub;
      end;
      {–}
      { Parse and Translate an Expression }
      procedure Expression;
      begin
      FirstTerm;
      while IsAddop(Look) do begin
      Push;