7. Текст программы конвертора .

uses Strings,Crt{If in Windows - uses WinCrt;Else - uses Crt};

type

TChar=set of Char;

const

stop:TChar=[' ',';',':',',','.','(',')','[',']','='];

after_end:TChar=['.',';'];

operators='BEGIN;END;VAR;CONST;FOR;READ;READLN;FUNCTION';

var

text1:array [1..40] of string;

text2:array [1..40] of string;

ns,ks,

koper1,koper2,ker,

NStr1,KStr1,NPos1,

KStr2,

Kind,tp,

isConst,posi,

NBeg,err,i,CommBeg,

wn:integer;

words:array [1..100] of string;

s1,s2,s3,str1,FName1,FName2:string;

F1:text;

procedure CommEnd;forward;

procedure finteger;forward;

procedure freal;forward;

function fae1:boolean;forward;

{====================================Ariphmetic======}

function isDigit:boolean;

begin

if str1[ns] in ['0'..'9'] then

begin

isDigit:=True;

inc(ns);

end

else isDigit:=false;

end;

function isCeloe:Boolean;

begin

isCeloe:=false;

while isDigit do isCeloe:=True;

end;

function isAlpha:boolean;

begin

if str1[ns] in ['A'..'Z','a'..'z'] then

begin

isAlpha:=True;

inc(ns);

end

else isAlpha:=false;

end;

function isPer:boolean;

var t1:boolean;

begin

isPer:=false;

t1:=false;

while isAlpha do t1:=true;

if t1=false then err:=8 else isPer:=true;

if err<>0 then exit;

if str1[Ns]='[' then

begin

isPer:=false;

while fae1 do

begin

isPer:=true;

inc(Ns);

end;

if not isPer then err:=8;

if str1[Ns]<>']' then err:=8;

if err<>0 then exit;

inc(Ns);

end;

end;

function isOper:boolean;

begin

if not isCeloe then

if not isPer then isOper:=false else isOper:=true

else isOper:=true;

end;

function fae1:boolean;

begin

fae1:=false;

if isOper then fae1:=true;

if ((str1[Ns]='*')or(str1[Ns]='/')or(str1[Ns]='+')or(str1[Ns]='-'))

then inc(Ns) else exit;

while ((isOper)and(Ns<Ks)) do

if ((str1[Ns]='*')or(str1[Ns]='/')or(str1[Ns]='+')or(str1[Ns]='-'))

then inc(Ns);

end;

{====================================Logic===========}

{------------------------------GetText---------------}

function GetText:boolean;{0-o'k ; 1-error}

begin

Assign (F1,FName1);

{$I-}

Reset (F1);

{$I+}

if IOResult<>0 then

begin

GetText:=true;

exit;

end;

GetText:=false;

KStr1:=1;

while not eof(F1) do

begin

readln (F1,Text1[KStr1]);

inc (KStr1);

end;

close (F1);

end;

{------------------------------PutText---------------}

procedure PutText;

begin

writeln ('Enter new file name :');

readln (FName2);

Assign (F1,FName2);

{$I-}

Rewrite (F1);

{$I+}

writeln('new text (saved to file ',FName2,'):');

writeln('было операторов:',KOper1,' |стало:',KOper2,' |ошибок:',ker);

for i:=1 to KStr2 do

begin

writeln (F1,Text2[i]);

writeln (Text2[i]);

end;

Close (F1);

end;

{------------------------------len-------------------}

function len:boolean;

begin

if NPos1<length(s1) then len:=true else len:=false;

end;

{------------------------------len1-------------------}

function len1:boolean;

begin

if NPos1<=length(s1) then len1:=true else len1:=false;

end;

{------------------------------GetWord---------------}

function GetWord:string;

var tmpstr:string;

begin

tmpstr:='';

if not len1 then exit;

while ((s1[NPos1] in stop)and len) do inc(NPos1);

while not ((s1[NPos1] in stop)or(not len1)) do

begin

tmpstr:=tmpstr+s1[NPos1];

inc(NPos1);

end;

GetWord:=tmpstr;

end;

{------------------------------Jump------------------}

procedure Jump;

begin

while ((s1[NPos1]=' ')and len1) do inc(NPos1);

end;

{------------------------------isComment-------------}

function isComment:boolean;

begin

isComment:=false;

Jump;

if not len then exit;

Kind:=0;

if copy(s1,NPos1,1)='{' then

begin

Kind:=1;

s1[NPos1]:='/';

inc(NPos1);

Insert('*',s1,NPos1);

end;

if copy(s1,NPos1,2)='(*' then

begin

Kind:=2;

s1[NPos1]:='/';

s1[NPos1+1]:='*';

end;

if Kind=0 then exit;

CommBeg:=1;

isComment:=true;

CommEnd;

if CommBeg=0 then if len then isComment:=false;

end;

{------------------------------CommEnd---------------}

procedure CommEnd;

begin

case Kind of

1:while not((copy(s1,NPos1,1)='}')or(not len1)) do inc(NPos1);

2:while not((copy(s1,NPos1,2)='*)')or(not len1)) do inc(NPos1);

end;

if not len1 then exit;

CommBeg:=0;

if copy(s1,NPos1,1)='}' then

begin

s1[NPos1]:='*';

inc(NPos1);

Insert('/',s1,NPos1);

end else

begin

s1[NPos1]:='*';

s1[NPos1+1]:='/';

end;

inc(NPos1,2);

end;

{------------------------------fbeg------------------}

procedure fbeg;

begin

inc(KOper1);

Jump;

if len then err:=1;

if err<>0 then exit;

s1:='{';

isConst:=0;

inc(KOper2);

end;

{------------------------------fend------------------}

procedure fend;

begin

inc(KOper1);

Jump;

if (s1[NPos1] in after_end) then inc(NPos1);

if len then err:=1;

if err<>0 then exit;

s1:='}';

inc(KOper2);

end;

{------------------------------fconst----------------}

procedure fconst;

begin

inc(KOper1);

isConst:=1;

inc(KOper2);

end;

{------------------------------ffor------------------}

procedure ffor;

var fortype:byte;

begin

inc(KOper1);

for i:=1 to 4 do words[i]:=GetWord;

if words[3]='TO' then fortype:=1 else

if words[3]='DOWNTO' then fortype:=2 else err:=2;

if err<>0 then exit;

if fortype=1 then if words[2]>words[4] then err:=2;

if fortype=2 then if words[2]<words[4] then err:=2;

if err<>0 then exit;

s1:='for ('+words[1]+'='+words[2]+';'+words[1];

if fortype=1 then s1:=s1+'<' else s1:=s1+'>';

s1:=s1+words[4]+';'+words[1];

if fortype=1 then s1:=s1+'++);' else s1:=s1+'--);';

inc(KOper2);

end;

{------------------------------fread-----------------}

procedure fread;

var tmpstr:string;

begin

inc(KOper1);

wn:=1;

while ((s1[NPos1]<>')')and len) do

begin

words[wn]:=GetWord;

inc(wn);

end;

dec(wn);

s1:='scanf ("';

tmpstr:='';

for i:=1 to wn do tmpstr:=tmpstr+'%f ';

delete (tmpstr,length(tmpstr),1);

s1:=s1+tmpstr+'"';

tmpstr:='';

for i:=1 to wn do tmpstr:=tmpstr+','+words[i];

s1:=s1+tmpstr+');';

inc(KOper2);

end;

{------------------------------freadln---------------}

procedure freadln;

begin

fread;

s1:=s1+#10+#13+'printf("\n");';

inc(KOper2);

end;

{------------------------------ffunction-------------}

procedure ffunction;

var skobka,i1,i2:integer;

begin

inc(KOper1);

isConst:=0;

NPos1:=1;

for wn:=1 to 2 do words[wn]:=GetWord;

if words[1]<>'FUNCTION' then err:=6;

skobka:=pos(')',s1);

if skobka=0 then err:=6;

Jump;

if s1[NPos1]='(' then inc(NPos1) else err:=6;

if err<>0 then exit;

s3:=copy(s1,NPos1,skobka-NPos1);

inc(wn);

if pos('):REAL',s1)=skobka then words[wn]:='float' else

if pos('):INTEGER',s1)=skobka then words[wn]:='int' else err:=6;

if err<>0 then exit;

NPos1:=1;

i1:=1;

s1:=s3;

while NPos1<length(s1) do

begin

s3:=getword;

if s3='INTEGER' then

begin

posi:=NPos1-7;

i2:=NPos1+1;

NPos1:=i1;

i1:=i2;

finteger;

inc(wn);

words[wn]:=s2;

NPos1:=i1;

end;

if s3='REAL' then

begin

posi:=NPos1-4;

i2:=NPos1+1;

NPos1:=i1;

i1:=i2;

freal;

inc(wn);

words[wn]:=s2;

NPos1:=i1+1;

end;

end;

s1:=words[3]+' '+words[2]+'('+words[4];

for i:=5 to wn do s1:=s1+';'+words[i];

s1:=s1+');';

inc(KOper2);

end;

{------------------------------fkW-------------------}

function fkW:boolean;

begin

NBeg:=NPos1;

fkW:=false;

wn:=1;

words[wn]:=GetWord;

case pos(words[wn],operators) of

1:if length(words[wn])=5 then

begin

fbeg;

fkW:=true;

end

else NPos1:=NBeg;

7:if length(words[wn])=3 then

begin

fend;

fkW:=true;

end

else NPos1:=NBeg;

11:if length(words[wn])=3 then

begin

s1:='';

fkW:=true;

isConst:=0;

end

else NPos1:=NBeg;

15:if length(words[wn])=5 then

begin

fconst;

fkW:=true;

end

else NPos1:=NBeg;

21:if length(words[wn])=3 then

begin

ffor;

fkW:=true;

end

else NPos1:=NBeg;

25:if length(words[wn])=4 then

begin

fread;

fkW:=true;

end

else NPos1:=NBeg;

30:if length(words[wn])=6 then

begin

freadln;

fkW:=true;

end

else NPos1:=NBeg;

37:if length(words[wn])=8 then

begin

ffunction;

fkW:=true;

end

else NPos1:=NBeg;

else NPos1:=NBeg;

end;

end;

{------------------------------freal-----------------}

procedure freal;

begin

s2:=copy(s1,NPos1,Posi-NPos1-1);

s2:='float '+s2;

end;

{------------------------------finteger--------------}

procedure finteger;

begin

s2:=copy(s1,NPos1,Posi-NPos1-1);

s2:='int '+s2;

end;

{------------------------------farray----------------}

procedure farray;

begin

NPos1:=1;

for wn:=1 to 6 do words[wn]:=getword;

if words[6]='INTEGER' then words[6]:=' int' else

if words[6]='REAL' then words[6]:=' float' else err:=5;

if words[5]<>'OF' then err:=5;

if words[2]<>'ARRAY' then err:=5;

if err<>0 then exit;

s1:=words[6]+' '+words[1]+'['+words[4]+']';

s2:=s1;

end;

{------------------------------fassign---------------}

procedure fassign;

begin

s2:=copy(s1,1,length(s1)-1);

NPos1:=posi+1;

ns:=1;

ks:=1;

posi:=pos(';',s1);

if ((posi=0)or(posi<NPos1)) then err:=8;

if err<>0 then exit;

str1:=copy(s1,NPos1,posi-NPos1);

ks:=length(str1);

if not fae1 then err:=8;

if ns<ks then err:=8;

if err<>0 then exit;

s2:=copy(s1,1,length(s1)-1);

end;

{------------------------------fconstop--------------}

procedure fconstop;

begin

if isConst=0 then err:=4;

if err<>0 then exit;

if tp=1 then freal else finteger;

if tp=1 then NPos1:=posi+4 else NPos1:=posi+7;

s1:=s2+copy(s1,NPos1,length(s1)-NPos1);

s2:=s1;

end;

{------------------------------asign-----------------}

function asign:boolean;

begin

inc(KOper1);

asign:=false;

tp:=0;

posi:=0;

posi:=pos('ARRAY',s1);

if posi=0 then posi:=pos('REAL',s1) else tp:=3;

if posi=0 then posi:=pos('INTEGER',s1) else if tp=0 then tp:=1;

if posi=0 then posi:=pos('=',s1) else if tp=0 then tp:=2;

if posi=0 then err:=3 else if tp=0 then tp:=4;

if not (s1[posi-1]=':') then err:=3;

if err<>0 then exit;

asign:=true;

case tp of

1:if s1[posi+4] in [' ',';'] then freal else if s1[posi+4]='=' then

fconstop else err:=3;

2:if s1[posi+7] in [' ',';'] then finteger else if s1[posi+7]='=' then

fconstop else err:=3;

3:if s1[posi+5] in [' ','['] then farray else err:=3;

4:fassign;

end;

if err<>0 then exit;

s1:=s2+';';

inc(KOper2);

end;

{------------------------------Translate-------------}

procedure Translate;

begin

NStr1:=1;

KStr2:=1;

err:=0;CommBeg:=0;isConst:=0;

KOper1:=0;KOper2:=0;ker:=0;

while NStr1<KStr1 do

begin

NPos1:=1;

s1:=text1[NStr1];

for i := 1 to Length(s1) do s1[i] := UpCase(s1[i]);

if CommBeg=1 then CommEnd;

if CommBeg=0 then

begin

if not isComment then if not fkW then if not asign then err:=3;

end;

if err<>0 then case err of

1:s1:='/* error too many operators! '+s1+' */';

2:s1:='/* error in for! '+s1+' */';

3:s1:='/* error unknown! '+s1+' */';

4:s1:='/* error in const! '+s1+' */';

5:s1:='/* error in array! '+s1+' */';

6:s1:='/* error in function! '+s1+' */';

8:s1:='/* error in assigment! '+s1+' */';

end;

if err<>0 then inc(ker);

err:=0;

if s1<>'' then

begin

text2[KStr2]:=s1;

inc(KStr2);

end;

inc(NStr1);

end;

end;

{------------------------------main------------------}

begin

ClrScr;

writeln ('Enter file name :');

readln (FName1);

if not GetText then

begin

Translate;

PutText;

end

else writeln ('File ',FName1,' wasn''t found');

writeln;

writeln ('Press ENTER to continue');

ReadKey;

end.

Государственный комитет Российской Федерации по высшему образованию

Московский Государственный Институт Электроники и Математики

кафедра ИТАС