6. Приложения
Файл lexan.pas
формирующий список лексем из входного файла
{--------------------------------------------------------------}
program Lex;
uses crt,sa_unit,gen;
{--------------------------------------------------------------}
{ Constant Declarations }
{--------------------------------------------------------------}
{ Type Declarations }
{--------------------------------------------------------------}
{ Read New Character From Input Stream }
var varst: array[1..50] of TLexema;
pVar:integer;
procedure addvar(vr:TLexema);
begin
varst[pVar]:=vr;
pVar:=pVar+1;
end;
function isvar(vr:TLexema):boolean;
var i:integer;
begin
for i:=1 to pVar do
begin
if (varst[i].Value=vr.Value) then
begin
isvar:=true; exit;
end;
end;
end;
function isar(vr:TLexema):boolean;
var i:integer;
begin
for i:=1 to pVar do begin if (varst[i].Value=vr.Value)and
(varst[i].Type<>vr.Type) then begin
isar:=true; exit;
end;
end;
isar:=false;
end;
function isconst(t:Symbol):boolean;
var i:integer;
fl:boolean;
begin
fl:=true;
i:=1;
while (t[i]<='9') and(t[i]>='0')or(t[i]=' ')
do begin
if (i=8)or(t[i]<' ') then begin
isconst:=true;
exit;
end;
i:=i+1;
end;
isconst:=false;
end;
procedure priv(t:integer);
var p:integer;
begin
p:=t;
while (sLexem[p].Value<>'. ') do begin
if sLexem[p].Type=Varable then begin
if (isar(sLexem[p]))then sLexem[p].Type:=bool;
end;
p:=p+1;
end;
end;
procedure prov(t:integer);
var p:integer;
begin
p:=t;
while (sLexem[p].Value<>'. ') do begin
if (sLexem[p].Type=Varable) or
(sLexem[p].Type=bool) then begin
if not ((isvar(sLexem[p])) or
(isar(sLexem[p]))) then err(1,'varable ');
end;
p:=p+1;
end;
end;
function getType(sim:Symbol):typeoflexema;
var sim1:Symbol;
begin
sim1:=sim;
if sim='PROGRAM ' then begin getType:=prg; exit;end;
if sim='BEGIN ' then begin getType:=bgop; exit;end;
if sim='THEN ' then begin getType:=thenop; exit;end;
if sim='VAR ' then begin getType:=varop;exit;end;
if sim='AND ' then begin getType:=andinst; exit;end;
if sim='OR ' then begin getType:=orinst;exit;end;
if sim='END ' then begin getType:=endop;exit;end;
if sim='IF ' then begin getType:=ifop; exit;end;
if sim='ELSE ' then begin getType:=elsop;exit;end;
if sim='FOR ' then begin getType:=forop;exit;end;
if sim='TO ' then begin getType:=toop; exit;end;
if sim='DO ' then begin getType:=doop; exit;end;
if sim='READ ' then begin getType:=readop;exit;end;
if sim='WRITE ' then begin getType:=writop;exit;end;
if sim='READLN ' then begin getType:=readlnop;exit;end;
if sim='WRITELN ' then begin getType:=writlnop;exit;end;
if sim='BOOLEAN ' then begin getType:=boolop; exit;end;
if sim='FALSE ' then begin getType:=falsop; exit;end;
if sim='TRUE ' then begin getType:=truop; exit;end;
if sim='INTEGER ' then begin getType:=intop;exit;end;
if sim='= ' then begin getType:=teq; exit;end;
if sim='. ' then begin getType:=tk; exit;end;
if sim='; ' then begin getType:=tzop; exit;end;
if sim=': ' then begin getType:=ttop; exit;end;
if sim=':= ' then begin getType:=letop;exit;end;
if sim='< ' then begin getType:=tlt;exit;end;
if sim='> ' then begin getType:=tgt;exit;end;
if sim='<> ' then begin getType:=tne;exit;end;
if sim='<= ' then begin getType:=tle;exit;end;
if sim='>= ' then begin getType:=tge;exit;end;
if sim='.. ' then begin getType:=twop; exit;end;
if sim='( ' then begin getType:=sko; exit;end;
if sim=') ' then begin getType:=skz; exit;end;
if sim='[ ' then begin getType:=skko; exit;end;
if sim='] ' then begin getType:=skkz; exit;end;
if sim='+ ' then begin getType:=addinst;exit;end;
if sim='- ' then begin getType:=subinst;exit;end;
if sim='* ' then begin getType:=mulinst;exit;end;
if sim='/ ' then begin getType:=divinst; exit;end
else if isconst(sim) then begin getTip:=konst;end
else getType:=Varable;
end;
{**********************************}
procedure getlex(i:integer);
var lex:Symbol;
begin
lex:=ST[i];
SLexem[i].Value:=lex;
SLexem[i].Type:=getType(lex);
writeln(SLexem[i].Value);
{readkey;
{writeln(SLexem[i].TypeOfLex);}
end;
{**********************************}
procedure LexAnalis;
var lex,lex1:char;
sim:Symbol;
i,k:integer;
FR,Buf:boolean;
begin
assign(Input,'input.pas');
{$I-}
reset(input);
{$I+}
i:=1;
k:=1;
FR:=False;
Buf:=False;
sim:=' ';
while NOT EOF(Input) do
begin
if not(FR) then read(Input,lex) else FR:=False;
case lex of
'A'..'Z': begin
sim[k]:=lex ;
k:=k+1;Buf:=True; end;
'0'..'9': begin
sim[k]:=lex ;
k:=k+1;Buf:=True; end;
'a'..'z': begin sim[k]:=upcase(lex); k:=k+1;Buf:=True; end;
')','(','[',']','+','-','/','*',',',';':
begin
if (Buf) then begin ST[i]:=sim;
getlex(i);i:=i+1;k:=1;
end;
sim:=' ';
sim[1]:=lex;
ST[i]:=sim;getlex(i);i:=i+1;
sim:=' ';k:=1;
Buf:=False;
sim:=' ';
end;
' ':begin if (Buf) then begin ST[i]:=sim;
getlex(i);i:=i+1;k:=1;
end;
while not(eof(Input))and (lex=' ') do read(input,lex);
FR:=True;Buf:=False;
sim:=' ';end;
#13:begin if (Buf) then begin ST[i]:=sim;
getlex(i);i:=i+1;k:=1;
end;
while not(eof(Input))and (lex=#13) do read(input,lex);
FR:=True;Buf:=False;
sim:=' ';end;
'.':begin ST[i]:=sim;getlex(i); k:=1; i:=i+1;
if not(eof(Input)) then BEGIN Read(Input,lex);
end
else begin
ST[i]:='. ';getlex(i);i:=i+1;
exit;
writeln('stop process');
end;
if lex='.' then begin sim:='.. ';ST[i]:=sim;getlex(i);i:=i+1;
Buf:=False;end else
begin FR:=True;ST[i]:='. ';
getlex(i); k:=1; i:=i+1;end;
end;
':':begin
if (Buf) then begin ST[i]:=sim;
getlex(i);i:=i+1;k:=1;
end;
Read(Input,lex);
if lex='=' then begin sim:=':= ';ST[i]:=sim;getlex(i);i:=i+1;
Buf:=False;end
else begin FR:=True;ST[i]:=': ';
getlex(i); k:=1; i:=i+1;
end;
sim:=' ';
end;
'<':
begin ST[i]:=sim;getlex(i); k:=1; i:=i+1;
Read(Input,lex1);
if (lex1='=') or
(lex1='>') then begin sim[1]:=lex;
sim[2]:=lex1;
ST[i]:=sim;getlex(i);i:=i+1;
sim:=' ';
Buf:=False;
end
else begin sim[1]:=lex;
ST[i]:=sim;
getlex(i);i:=i+1;
lex:=lex1;
FR:=True;
Buf:=False;
end;
end;
'>': begin ST[i]:=sim;getlex(i); k:=1; i:=i+1;
Read(Input,lex1);
if lex1='=' then begin sim[1]:=lex;
sim[2]:=lex1;
ST[i]:=sim;getlex(i);i:=i+1;
sim:=' ';
Buf:=False;
end
else begin sim[1]:=lex;
ST[i]:=sim;
getlex(i);i:=i+1;
lex:=lex1;
FR:=True;
Buf:=False;
end;
end;
'=': begin sim[1]:=lex;
ST[i]:=sim;getlex(i);i:=i+1;
Buf:=False;end;
end;
end;
end;
{/*************************************}
procedure sa;
var node1,rn,ln,node,node2:pTree;
begin
tlex:=1;
if SLexem[tlex].Value='PROGRAM 'then begin
new (ptTree);
theTree:=ptTree;
ptTree^.info.Value:='PROGRAM ';
ptTree^.info.Tip:=bgop;
new (node);
ptTree^.LLink:=node;
node^.info:=SLexem[tlex+1];
node^.LLink:=NIL;
node^.RLink:=NIL;
tlex:=tlex+3;
end
else err(1,'PROGRAM ');
if SLexem[tlex-1].Value<>'; '
then err(1,'; ');
{*****Описание переменых*****}
if SLexem[tlex].Value='VAR 'then begin
new (node);
ptTree^.RLink:=node;
node^.info.Value:='VAR ';
tlex:=tlex+1;
ptTree:=node;
ptTree^.RLink:=NIL;
while SLexem[tlex].Value<>'BEGIN ' do begin
new(node1);
if SLexem[tlex].Tip=Varable then begin node1^.info:=SLexem[tlex];
node1^.LLink:=NIL;
node^.LLink:=node1;
if (SLexem[tlex+1].Value=': ')and
(SLexem[tlex+2].Value='INTEGER ') then begin addvar(sLexem[tlex]);
new(node2);
node1^.RLink:=node2; node2^.info.Value:='INTEGER '; node2^.RLink:=NIL;
node2^.LLink:=NIL;
end
else if (SLexem[tlex+1].Value=': ')and
SLexem[tlex+2].Value='BOOLEAN ') then begin
sLexem[tlex].Type:=bool;
addvar(sLexem[tlex]);
new(node2);
node1^.RLink:=node2; node2^.info.Value:=’BOOLEAN’;
node2^.RLink:=NIL;
node2^.LLink:=NIL;
end
tlex:=tlex+9;
if (SLexem[tlex-1].Value<>'; ') then err(1,'; ');
end;
end;
node:=node1;
end;
tlex:=tlex+1;
priv((tlex));
prov((tlex));
sablock(ptTree);
end;
end;
procedure puttree(t:ptree);
procedure putt(t:ptree);
begin
if t=nil then begin write('.'); exit end;
write(t^.info.Value);
putt(t^.llink);
putt(t^.rlink);
end; {putt}
begin
writeln;
writeln('Дерево:');
putt(t);
writeln;
end; {puttree}
begin
clrscr;
Lab:=0;
pVar:=1;
k:=0;
LexAnalis;
sa;
if (SLexem[tlex-1].Value<>'. ') then begin
err(1,' . ');
end;
assign(outf,'output.asm');
rewrite(outf);
puttree(theTree);
genhead(theTree);
genblock(eTree);
genend;
close(outf);
{tlex:=1;
sapol;}
end.
Файл sa_unit.pas , формирующий дерево
синтаксического разбора из списка лексем
UNIT SA_UNIT; interface uses crt;
const MaxEntry = 100; максимальное число лексем типу лексем
type typeoflexema=(bgop,endop,ifop,elsop,forop,toop,readop,writop, readlnop,writlnop,boolop,falsop,truop,intop,tzop,ttop,sko,skz,skko,skkz, addinst,subinst,letop,twop,konst,prg,varop,doop,tk,teq,thenop, mulinst,divinst,Varable,orinst,andinst,bool,tgt,tlt,tne,tge,tle);
Symbol = array[1..8]of char;
type
тип лексема
TLexema = record
Value: Symbol; значение лексемы
Type:typeoflexema; тип лексемы end;
pTree = ^TTree; указатель на дерево синтаксического разбора описание типа дерево
TTree = record info:TLexema;информационная часть LLink:pTree; указатели на поддеревья RLink:pTree;
end;
var ST : array[1..MaxEntry] of Symbol; список лексем
SLexem: array[1..MaxEntry] of TLexema;список лексем для представления арифметических выражений в виде обратной польской записи
Stek: array[1..50] of TLexema; стек лексем
OutStr: array[1..100] of TLexema; выходной массив
k:integer;
pStek:integer; указатель на вершину стека
pOut,N:integer; указатель на конец выходной строки
Input: file of char; входной файл tlex:integer; указатель на текущую лексему ptTree:pTree; указатель на текущее поддерево theTree:pTree; указатель на текущее поддерево eTree:pTree; указатель на текущее поддерево
Процедуры синтаксического разбора
procedure saoperator(tTree:pTree); для оператора
procedure safor(tTree:pTree); для оператора FOR
procedure sabegop(tTree:pTree); для составного оператора procedure sablock(tTree:pTree); для программы
procedure err(i:integer;s:Symbol); процедура генерации ошибки procedure pop(var pt:TLexema); извлечение из стека
procedure push(p:TLexema); помещение в стек
procedure sapol; представление арифметических выражений в виде обратной польской записи
implementation
procedure safor(tTree:pTree);
var node1,rr,tr,lr,node:pTree;
begin
if SLexem[tlex].Value<>'FOR 'then err(1,'For ');
if SLexem[tlex+1].Type<>Varable then err(1,'For ble ');
if SLexem[tlex+2].Value<>':= ' then err(1,':= ');
if (SLexem[tlex+3].Type<>Varable)and
(SLexem[tlex+3].Type<>const) then err(1,'const ');
if SLexem[tlex+4].Value<>'TO ' then err(1,'TO ');
if (SLexem[tlex+5].Type<>Varable)and
(SLexem[tlex+5].Type<>const) then err(1,'const ');
if SLexem[tlex+6].Value<>'DO 'then err(1,'DO ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];
node^.RLink:=NIL;
new (node1);
node^.RLink:=node1;node1^.info:=SLexem[tlex+1];
new(rr);new(lr);
lr^.LLink:=NIL;lr^.RLink:=NIL;rr^.LLink:=NIL;rr^.RLink:=NIL;
lr^.info:=SLexem[tlex+3];rr^.info:=SLexem[tlex+5];
node1^.LLink:=lr;node1^.RLink:=rr;tlex:=tlex+7;
saoperator(node);
end;
**********************************
procedure saread(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
if SLexem[tlex+1].Value<>'( ' then err(1,' ( ');
if SLexem[tlex+2].Tip<>Varable then err(1,'Variable');
if SLexem[tlex+3].Value<>') ' then err(1,' ) ');
if SLexem[tlex+4].Value<>'; 'then err(1,'; ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];
new (tr);node^.LLink:=tr;node^.RLink:=NIL;
tr^.LLink:=NIL;tr^.RLink:=NIL;tr^.info:=SLexem[tlex+2];
tlex:=tlex+5;
end;
**********************************
procedure sareadln(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
if SLexem[tlex+1].Value<>'( ' then err(1,' ( ');
if SLexem[tlex+2].Tip<>Varable then err(1,'Variable');
if SLexem[tlex+3].Value<>') ' then err(1,' ) ');
if SLexem[tlex+4].Value<>'; 'then err(1,'; ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];
new (tr);node^.LLink:=tr;node^.RLink:=NIL;
tr^.LLink:=NIL;tr^.RLink:=NIL;tr^.info:=SLexem[tlex+2];
tlex:=tlex+5;
end;
**********************************
procedure sawrite(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
if SLexem[tlex+1].Value<>'( ' then err(1,' ( ');
if SLexem[tlex+2].Type<>Varable then err(1,'Variable');
if SLexem[tlex+3].Value<>') ' then err(1,' ) ');
if SLexem[tlex+4].Value<>'; 'then err(1,'; ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];
new (tr);node^.LLink:=tr;node^.RLink:=NIL;
tr^.LLink:=NIL;tr^.RLink:=NIL;tr^.info:=SLexem[tlex+2];
tlex:=tlex+5;
end;
**********************************
procedure sawriteln(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
if SLexem[tlex+1].Value<>'( ' then err(1,' ( ');
if SLexem[tlex+2].Type<>Varable then err(1,'Variable');
if SLexem[tlex+3].Value<>') ' then err(1,' ) ');
if SLexem[tlex+4].Value<>'; 'then err(1,'; ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];
new (tr);node^.LLink:=tr;node^.RLink:=NIL;
tr^.LLink:=NIL;tr^.RLink:=NIL;tr^.info:=SLexem[tlex+2];
tlex:=tlex+5;
end;
**********************************
procedure saif(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
if SLexem[tlex].Value<>'IF 'then err(1,'If ');
if (SLexem[tlex+1].Type<>Varable) and
(SLexem[tlex+1].Type<>konst) then err(1,'Variable');
if (SLexem[tlex+3].Type<>Varable) and
(SLexem[tlex+3].Type<>konst) then err(1,'Variable');
if SLexem[tlex+4].Value<>'THEN 'then err(1,'Then ');
new(node);
tTree^.LLink:=node;
node^.info:=SLexem[tlex];new (tr);node^.LLink:=tr;
tr^.LLink:=NIL;tr^.RLink:=NIL;tr^.info:=SLexem[tlex+2];
new(rr);new(lr);
lr^.LLink:=NIL;lr^.RLink:=NIL;rr^.LLink:=NIL;rr^.RLink:=NIL;
lr^.info:=SLexem[tlex+1];rr^.info:=SLexem[tlex+3];
tr^.LLink:=lr;tr^.RLink:=rr;
new(nthen);
node^.RLink:=nthen;
nthen^.info:=SLexem[tlex+4];
nthen^.LLink:=NIL;nthen^.RLink:=NIL;
tlex:=tlex+5;
saoperator(nthen);
if SLexem[tlex].Value='ELSE 'then begin
new(nop);
nthen^.RLink:=nop;
nop^.info:=SLexem[tlex];
nop^.LLink:=NIL;
nop^.RLink:=NIL;
tlex:=tlex+1;
saoperator(nop);
end;
end;
**********************************
procedure sablock(tTree:pTree);
var node:pTree;
begin
while (SLexem[tlex].Value)<>'END 'do begin
new(node);
tTree^.RLink:=node;
node^.info.Value:='BEGIN ';
node^.RLink:=NIL;
node^.LLink:=NIL;
if k=0 then eTree:=tTree^.RLink;
k:=k+1;
saoperator(node);
tTree:=tTree^.RLink;
end;
tlex:=tlex+2;
end;
**********************************
procedure satree(tTree: pTree);
var node,n1,n2:pTree;
begin
N:=N-1;
if N>=1 then begin
if (OutStr[N].Type=addinst)or
(OutStr[N].Type=subinst)or
(OutStr[N].Type=divinst)or
(OutStr[N].Type=mulinst)or
(OutStr[N].Type=orinst)or
(OutStr[N].Type=andinst) then begin
tTree^.info:=OutStr[N];
new(n1);new(n2);
tTree^.LLink:=n1;
tTree^.RLink:=n2;
satree(n1);
satree(n2);exit;
end;
if (OutStr[N]. Type=Varable)or
(OutStr[N]. Type=konst)then
begin
new (node);
tTree^.info:=OutStr[N];
tTree^.LLink:=NIL;
tTree^.RLink:=NIL;
exit;
end;
end;
end;
**********************************
procedure saassign(tTree:pTree);
var node,n1,n2,n3:pTree;
begin
if (SLexem[tlex]. Type<>Varable) and
(SLexem[tlex]. Type<>bool) then err(1,'Variable')
else begin
if (SLexem[tlex]. Type=Varable) then begin
if SLexem[tlex+1].Value<>':= ' then err(1,' := ');
new (n1);new(n2);
n1^.info:=SLexem[tlex+1];
n2^.info:=SLexem[tlex];
n1^.LLink:=n2;
n2^.LLink:=NIL;
n2^.RLink:=NIL;
tTree^.LLink:=n1;
tlex:=tlex+2;
sapol;
N:=pOut; new(node); n1^.RLink:=node; satree(node); tlex:=tlex+1; end;
if (SLexem[tlex]. Type=bool) then begin
if SLexem[tlex+4].Value<>':= ' then err(1,' := ');
if SLexem[tlex+1].Value<>'[ ' then err(1,' [ ');
if SLexem[tlex+3].Value<>'] ' then err(1,' ] ');
new (n1);new(n2);new(n3);
n1^.info:=SLexem[tlex+4];
n2^.info:=SLexem[tlex];
n3^.info:=SLexem[tlex+2];
if (SLexem[tlex+2]. Type<>Varable) and
(SLexem[tlex+2]. Type<>konst) then err(1,'index ');
n1^.LLink:=n2;
n2^.LLink:=n3;
n2^.RLink:=NIL;
n3^.LLink:=NIL;
n3^.RLink:=NIL;
tTree^.LLink:=n1;
tlex:=tlex+5;
sapol;
N:=pOut; new(node); n1^.RLink:=node; satree(node); tlex:=tlex+1; end;
end;
end; ********************************** procedure sabegop(tTree:pTree); label 1;
var node:pTree;
begin
while (SLexem[tlex].Value)<>'END 'do begin
new(node);
tTree^.RLink:=node;
node^.info.Value:='BEGIN ';
node^.RLink:=NIL;
node^.LLink:=NIL;
tTree:=tTree^.RLink;
if (SLexem[tlex].Value)='BEGIN ' then begin tlex:=tlex+1;
new(node);
tTree^.LLink:=node; node^.info.Value:='BEGIN '; node^.RLink:=NIL; node^.LLink:=NIL; sabegop(node); exit;
end;
if (SLexem[tlex].Value)='FOR ' then begin safor(tTree);
goto 1;
end;
if (SLexem[tlex].Value)='IF ' then begin saif(tTree);goto 1;end;
if (SLexem[tlex].Value)='READ ' then begin
saread(tTree);goto 1;
end;
if (SLexem[tlex].Value)='READLN ' then begin
sareadln(tTree);goto 1;
end;
if (SLexem[tlex].Value)='WRITE ' then begin
sawrite(tTree);goto 1;
end;
if (SLexem[tlex].Value)='WRITELN ' then begin
sawriteln(tTree);goto 1;
end;
if (SLexem[tlex]. Type)=Varable then begin
saassign(tTree);
end;
1:
end;
if (SLexem[tlex+1].Value='; ') then begin
tlex:=tlex+2;
exit;
end;
end;
**********************************
procedure saoperator(tTree:pTree);
var node:pTree;
begin
if (SLexem[tlex].Value)='BEGIN ' then begin
new(node);
tTree^.LLink:=node; node^.info.Value:='BEGIN '; node^.RLink:=NIL; node^.LLink:=NIL; tlex:=tlex+1; sablock(node); exit;
end;
if (SLexem[tlex].Value)='FOR ' then begin safor(tTree);exit;end;
if (SLexem[tlex].Value)='IF ' then begin saif(tTree);exit;end;
if (SLexem[tlex].Value)='READ ' then begin saread(tTree);exit;end;
if (SLexem[tlex].Value)='READLN ' then begin sareadln(tTree);exit;end;
if (SLexem[tlex].Value)='WRITE ' then begin sawrite(tTree);exit;end;
if (SLexem[tlex].Value)='WRITELN ' then begin sawriteln(tTree);exit;end;
if (SLexem[tlex].Tip=Varable) or
(SLexem[tlex].Tip=bool) then begin saassign(tTree);exit;end;
if (SLexem[tlex].Value='; ') then begin exit;end;
end;
**********************************
procedure err(i:integer;s:Symbol);
begin
case i of
1: writeln('Отсутствует ',s);
end;
halt(1);
end;
**********************************
procedure pop(var pt:TLexema);
begin
pt:=Stek[pStek-1];
pStek:=pStek-1;
end;
procedure push(p:TLexema);
begin
Stek[pStek]:=p; pStek:=pStek+1; end;
procedure outs(p:TLexema); begin OutStr[pOut]:=p; pOut:=pOut+1; end;
procedure sapol; var tec:TLexema; begin pStek:=1; pOut:=1;
while sLexem[tlex].Value<>'; ' do begin
if (sLexem[tlex].Type=Varable)or
(sLexem[tlex].Type=konst) then outs(sLexem[tlex]);
if sLexem[tlex].Type=sko then push(sLexem[tlex]);
if sLexem[tlex].Type=skz then begin
pop(tec);
while tec. Type<>sko do begin
outs(tec);
pop(tec);
end;
end;
if ((sLexem[tlex].Type=addinst)or
(sLexem[tlex].Type=subinst))then begin
if pStek<>1 then begin pop(tec);
while (pStek<>1)and (tec.Type<>sko) or
(tec.Type=addinst) or (tec.Type=subinst) do begin
outs(tec);
if pStek<>1 then pop(tec);
end;
push(tec);
push(sLexem[tlex]); end
else
push(sLexem[tlex]);
end;
if ((sLexem[tlex].Type=mulinst)or
(sLexem[tlex].Type=divinst)or
(sLexem[tlex].Type=orinst)or
(sLexem[tlex].Type=andinst))then begin
if pStek<>1 then begin pop(tec);
while ((pStek>1)and ((tec.Type=mulinst) or
(tec.Type=divinst)or
(tec.Type=orinst)or
(tec.Type=andinst))) do
begin
outs(tec);
if pStek<>1 then pop(tec);
end;
push(tec);
push(sLexem[tlex]);
end else push(sLexem[tlex]);
end;
tlex:=tlex+1;
end;
while pStek<>1 do begin
pop(tec);
outs(tec);
end;
end;
end.
Файл gen_unit.pas , формирующий выходной файл
из дерева синтаксического разбора
{Генератор кода:
Входные данные: Дерево синтаксического разбора;
Выходные данные: Сгенерированный код на Ассемблере
в выходной файл output.asm}
UNIT gen;
interface
uses sa_unit;
procedure genend;{генерация кончание выходного файла}
{генерация кода для оператора}
procedure genoperator(tTree:pTree);
{генерация кода для оператора FOR}
procedure genfor(tTree:pTree);
{генерация заголовка для выходного файла}
procedure genhead(tTree:pTree);
{генерация кода для оператора IF}
procedure genif(tTree:pTree);{генерация кода для программы}
procedure genblock(tTree:pTree);{генерация кода для оператора READ}
procedure genread(tTree:pTree);{генерация кода для оператора READLN}
procedure genreadln(tTree:pTree);{генерация кода для оператора WRITE}
procedure genwrite(tTree:pTree);{генерация кода для оператора WRITELN}
procedure genwriteln(tTree:pTree);{генерация кода для арифметического выражения}
procedure genassign(tTree:pTree);
var outf:text; {выходной файл}
Lab:integer; {переменная метки}
implementation
{**********************************}
procedure genfor(tTree:pTree);
var node1,rr,tr,lr,node:pTree;
m:integer;
begin
m:=Lab;
writeln(outf,' move Cx,',tTree^.RLink^.RLink^.info.Value);
writeln(outf,' sub Cx,',tTree^.RLink^.LLink^.info.Value);
writeln(outf,' inc Cx');
writeln(outf,' move ',tTree^.RLink^.info.Value,','
,tTree^.RLink^.LLink^.info.Value);
writeln(outf,'lp',Lab,':');
writeln(outf,' ink ',tTree^.RLink^.info.Value);
writeln(outf,' push Cx');
Lab:=Lab+1;
genoperator(tTree^.LLink);
writeln(outf,' pop Cx');
writeln(outf,' loop lp',m);
end;
{**********************************}
procedure genread(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
writeln(outf,' call read');
writeln(outf,' move ',tTree^.LLink^.info.Value,',Ax');
end;
{**********************************}
procedure genreadln(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
writeln(outf,' call readln');
writeln(outf,' move ',tTree^.LLink^.info.Value,',Ax');
end;
{**********************************}
procedure genwrite(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
writeln(outf,' move Ax,',tTree^.LLink^.info.Value);
writeln(outf,' call write');
end;
{**********************************}
procedure genwriteln(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
begin
writeln(outf,' move Ax,',tTree^.LLink^.info.Value);
writeln(outf,' call writeln');
end;
{**********************************}
procedure genif(tTree:pTree);
var node1,rr,tr,lr,node,nthen,nop:pTree;
m:integer;
begin
Lab:=Lab+2;
m:=Lab;
writeln(outf,' move Ax,',tTree^.LLink^.LLink^.info.Value);
writeln(outf,' cmp AX,',tTree^.LLink^.RLink^.info.Value);
if tTree^.LLink^.info.Value='> 'then writeln(outf,'jl lp',Lab);
if tTree^.LLink^.info.Value='< 'then writeln(outf,'jg lp',Lab);
if tTree^.LLink^.info.Value='= 'then writeln(outf,'jne lp',Lab);
if tTree^.LLink^.info.Value='>= 'then writeln(outf,'jl lp',Lab);
if tTree^.LLink^.info.Value='<= 'then writeln(outf,'jg lp',Lab);
if tTree^.LLink^.info.Value='<> 'then writeln(outf,'je lp',Lab);
genoperator(tTree^.RLink^.LLink);
writeln(outf,' j lp',m+1);
writeln(outf,'lp',m,':');
if tTree^.RLink^.RLink<>NIL then begin
genoperator(tTree^.RLink^.RLink^.LLink);
end;
writeln(outf,'lp',m+1,':');
end;
{**********************************}
procedure genvar(tTree:pTree);
begin
if tTree=nil then exit;
genvar(tTree^.LLink);
if tTree^.RLink^.info.Value='INTEGER 'then begin
writeln(outf,tTree^.info.Value,' dw 0');
end;
if tTree^.RLink^.info.Value='BOOLEAN 'then begin
writeln(outf,tTree^.info.Value,' dw 0');
end;
end;
{**********************************}
procedure genend;
begin
writeln(outf,' mov Ax,04CH');
writeln(outf,' int 21h');
writeln(outf,'end Start');
end;
{**********************************}
procedure genhead(tTree:pTree);
begin
writeln(outf,'.MODEL SMALL');
writeln(outf,'.STACK 128');
writeln(outf,'.DATA');
genvar(tTree^.RLink);
writeln(outf,'Start:');
writeln(outf,' move Ax,@DATA');
writeln(outf,' move Ds,Ax');
end;
{**********************************}
procedure genblock(tTree:pTree);
var node:pTree;
begin
while (tTree<>nil)do begin
genoperator(tTree^.LLink);
tTree:=tTree^.RLink;
end;
end;
{**********************************}
procedure genoperator(tTree:pTree);
var node:pTree;
begin
if tTree=nil then exit;
if (tTree^.info.Value='BEGIN')or
(tTree^.info.Value='BEGIN ') then begin
genblock(tTree^.RLink);
exit;
end;
if tTree^.info.Value='FOR ' then begin
genfor(tTree);
exit;
end;
if tTree^.info.Value='IF ' then begin genif(tTree);exit;end;
if tTree^.info.Value='READ ' then begin genread(tTree);exit;end;
if tTree^.info.Value='READLN ' then begin genreadln(tTree);exit;end;
if tTree^.info.Value='WRITE ' then begin genwrite(tTree);exit;end;
if tTree^.info.Value='WRITELN ' then begin genwriteln(tTree);exit;end;
genassign(tTree);
end;
{генерация кода для арифметического выражения}
procedure gentree(tTree:pTree);
var node,n1,n2:pTree;
begin
{если переменная или константа, то помещаем значение в стек}
if (tTree^.info.Tip=Varable)or (tTree^.info.Tip=konst) then begin
writeln(outf,' move Ax,',tTree^.info.Value);
writeln(outf,' push Ax');
end
else begin
{если операция, то вызываем генератор для левого и правого поддерева }
gentree(tTree^.LLink);
gentree(tTree^.RLink);
{извлекаем значения из стека для левого и правого поддерева }
writeln(outf,' pop Ax');
writeln(outf,' pop Bx');
{в зависимости от операции выполняем арифметическую операцию}
if tTree^.info.Value='+ 'then writeln(outf,' add Ax,Bx');
if tTree^.info.Value='- 'then writeln(outf,' sub Ax,Bx');
if tTree^.info.Value='* 'then writeln(outf,' mul Ax,Bx');
if tTree^.info.Value='/ 'then writeln(outf,' div Ax,Bx');
if tTree^.info.Value='OR 'then writeln(outf,' or Ax,Bx');
if tTree^.info.Value='AND 'then writeln(outf,' and Ax,Bx');
{помещаем полученное значение в стек}
writeln(outf,' push Ax');
end;
end;
procedure genassign(tTree:pTree);
var node,n1,n2:pTree;
begin
if (tTree^.info.Value=':= ')then begin
gentree(tTree^.RLink);
if (tTree^.LLink^.info.Tip=bool)then begin
writeln(outf,' pop Ax');
writeln(outf,' move ',tTree^.LLink^.info.Value,',Ax');
end;
if (tTree^.LLink^.info.Tip=Varable)then begin
writeln(outf,' pop Ax');
writeln(outf,' move ',tTree^.LLink^.info.Value,',Ax');
end;
end;
end;
end.