Джек Креншоу - Давайте создадим компилятор!

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;