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 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.
      {–}

Разное