ModernLib.Net

!

ModernLib.Net / / / ! - (. 14)
:
:

 

 


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



, . , , . .
, , c . .
, , . . . , , - , .


. . , - , . , , .
, . , .
KISS, , . -.
, .
-. , , , . , (continuation card), , . , .
, . BASIC. , , , . , , .
, - . :
a=b; c=d; e=e+1;
, . :
a=b c= d e=e+1
, ... ... : .
. , . CRT . - , .
KISS, . , , . , , . . TINY , , .
, , , . . KISS , -. , , . , . !
, , , C. , .


... , , , , . , , . FORTH. , , , . .
, , THEN IF, DO WHILE PROGRAM TINY. ... , . , .
, C Pascal.
. , , . , , . , , . , . C, .
, , Pascal. , . , . , , , . , ..
. C . C, C. . C .
, , , , . , .
. :
a=1+(2*b+c)b...
, 'b' , , ')' 'b' . , :
a=1+(2*b+c)*b...
, , , '=' 'b', .
, , 'b', , , . , .., , .
- . ... . COBOL. KISS/TINY. , . , . , -, .


. . . :
<block> ::= <statement> ( ';' <statement>)*
<statement> ::= <assignment> | <if> | <while> ... | null
( !)
, PROGRAM.
C Ada, , ( ). :
<block> ::= ( <statement> ';')*
, , , . , . - ... . , , . , ELSE. , ELSE . C/Ada . , : Modula-2 .
, (, !) . , .
:

  • :
    1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23