
{  Кросс-система Бейсик - Паскаль.  }
{$M 64384,0,655360}
Program Bas2Pas;
Uses Crt;
Type
     OperPtr=^Oper;
     ProgElPtr=^ProgEl;
     ProgEl=record {Элемент списка операторов программы}
            Op:OperPtr;  {Указатель на оператор}
            Line:Word;   {Номер строки в которой он находится}
            Next:ProgElPtr; {Указатель на следующий элемент}
                            {cписка}
            end;
     Oper=object   {Базовый объект описания операторов}
            C:byte; {Отступ от края страницы}
            Constructor Init(CC:Byte);
            Destructor Done;Virtual;
            Procedure WriteF(Var F:TEXT);virtual;
          end;
     OperListPtr=^OperList;
     OperList=object(Oper) {Объект - контейнер операторов}
              List:ProgElPtr;
              Line:Word;
              Constructor Init(CC:Byte);
              Destructor Done;Virtual;
              Procedure AddOper(Op:OperPtr);
              Procedure AssignLine(Num:Word);
              Procedure WriteF(Var F:Text);virtual;
              end;
     OperStringPtr=^OperString;
     OperString=object(Oper) {Оператор - строка}
                Op:String;
                Constructor Init(S:String;CC:byte);
                Procedure WriteF(Var F:Text);virtual;
              end;

     StrElPtr=^StrEl;
     StrEl=Record  {Элемент списка строк и информации о них}
           Str:String[10];
           Typ:byte;
           Info:Word;
           Next:StrElPtr;
           End;

     FifoLabel=object  {Объект - очередь, используется в }
                       {очереди строк}
               L,PtrBeg,PtrEnd,Size:integer;
               F:Array[1..100] of Word;
               Constructor Init;
               Procedure AddLabel(N:Word);
               Function GetLabel:Word;
               Function Empty:boolean;
               Procedure Lock;
               Procedure UnLock;
               End;

Const TInteger=1; {Типы переменных}
      TReal=2;
      TString=3;
      TArray=4;
      {Разделители в операторах}
      Delimier:Set of Char=[',',';','=','<','>','(',')','$','"'];
      {Разделители в выражениях}
      MathDelim:Set of Char=['+','*','/','-','(',')','^'];
      NumOfFunc=4;
      {Массив функций не требующих переделки}
      FuncArray:Array[1..NumOfFunc] of String[10]=(
                  'ABS','SIN','COS','ARCTAN'
                );
      {Массив типов выражений возращаемых функциями}
      FunctTypeArray:Array[1..NumOfFunc] of integer=(
                  0,2,2,2
                );
      ResArraySize=1;
      {Массив резервный выражений}
      ResArray:Array[1..ResArraySize] of string[10]=(
                  'ELSE'
               );
      {Максимальный размер стека операторов}
      StackSize=50;

Var Labels:FifoLabel;  {Очередь меток}
    Fin,Fout:TEXT;     {Взодной и выходной файлы}
    Name:String;
    InputString:String;{Текущая вводимая строка}
    InputStrPtr:Byte;{Текущий номер обрабатываемой строки}
    LastInputPtr:Byte;
    OldInputNum,OldInputFlag,InputStrNum:Integer;
    ProcList,  {Список номеров процедур}
    LabelList, {Список номеров меток}
    VarList,   {Список переменных используемых в программе}
    VarList1,VarList2:StrElPtr; {Рабочие переменные}
    VarType:Byte; {Тип выражения обрабатываемого в данный момент}
    OperStack:Array[0..StackSize] Of OperListPtr; {Стек операторов}
    OperStackPtr:Word;
    Procedures:OperList; {Список отранслированных процедур}


{Реализаця объекта ОЧЕРЕДЬ}
Constructor FifoLabel.init;
Begin
  L:=0;
  PtrBeg:=1;
  PtrEnd:=1;
  Size:=0;
End;
Procedure FifoLabel.Lock;
Begin
  Inc(L);
End;
Procedure FifoLabel.UnLock;
Begin
  If L<>0 then Dec(L);
End;
Procedure FifoLabel.AddLabel;
Begin
  If Size<100 then
    begin
    F[PtrBeg]:=N;
    inc(PtrBeg);
    inc(Size);
    If PtrBeg>100 then PtrBeg:=1;
    End
  Else
    begin
    WriteLn('Внутренняя ошибка: не хватает объема очереди меток');
    Halt;
    end;
End;
Function FifoLabel.GetLabel:word;
Begin
  If L<>0 then
    begin
    GetLabel:=0;
    Exit;
    end;
  If Size<>0 then
    begin
    Dec(Size);
    If L=0 then GetLabel:=F[PtrEnd]
    Else GetLabel:=0;
    inc(PtrEnd);
    If PtrEnd>100 then PtrEnd:=100;
    end
  else
    begin
    WriteLn('Внутренняя ошибка: чтение из пустой очереди меток');
    halt;
    end;
End;
Function FifoLabel.Empty:boolean;
Begin
  Empty:=Size=0;
End;

{Реализация объекта оператор}
Constructor Oper.Init(CC:byte);
Begin
  C:=CC;
End;
Destructor Oper.Done;
Begin End;
Procedure Oper.WriteF(Var F:Text);
Begin End;
Constructor OperString.Init(S:String;CC:Byte);
Begin
  Op:=S;
  C:=Cc;
End;
Procedure OperString.WriteF(Var F:TEXT);
Var i:byte;
Begin
  For i:=1 to C do
    Write(F,' ');
  WriteLn(F,Op);
End;

{Реализация объекта СПИСОК ОПЕРАТОРОВ}
Constructor OperList.Init(CC:Byte);
Begin
  C:=CC;
  New(List);
  List^.Op:=nil;
  List^.Line:=0;
  List^.Next:=nil;
  Line:=0;
End;
Destructor OperList.Done; {Освобождение занимаемой памяти}
Var L:ProgElPtr;
Begin
  While List<>nil Do
    Begin
    If List^.Op<>nil then
      List^.Op^.Done;
    L:=List^.Next;
    Dispose(List);
    List:=L;
    End;
End;
Procedure OperList.AddOper(Op:OperPtr); {Добавление в список}
Var L:ProgElPtr;                        {нового оператора}
Begin
  L:=List;
  While L^.Next<>nil do
    L:=L^.Next;
  New(L^.Next);
  L:=L^.Next;
  L^.Next:=nil;
  L^.Op:=Op;
  If Labels.Empty then L^.Line:=0
  else
    L^.Line:=Labels.GetLabel;
  Line:=0;
End;
Procedure OperList.AssignLine(Num:Word);{Заполение поля Line}
Begin
  Line:=Num;
End;

Function HaveInLabels(N:Word):boolean;Forward;

Procedure OperList.WriteF(Var F:TEXT); {Запись в файл}
Var l:ProgElPtr;             {оттранслированных операторов}
Begin
  L:=List^.Next;
  While L<>nil do
    begin
    If (L^.Line<>0) and HaveInLabels(L^.Line) then
      WriteLn(F,'L',L^.Line,':');
    L^.Op^.WriteF(F);
    L:=L^.Next;
    end;
End;

Function GetSpace:byte; {Функция получения текущего отступа}
Begin
  GetSpace:=OperStack[OperStackPtr]^.C+2;
End;

Function GetCurrent:OperListPtr; {Функция получения текущего}
Begin                            {оператора}
  GetCurrent:=OperStack[OperStackPtr];
end;

Procedure AddOper(O:OperPtr);{Добавление в текущий}
Begin                        {СПИСОК_ОПЕРАТОРОВ нового оператора}
  If OperStackPtr=0 then
    begin
    {Стек пустой, т.е. отсутствует ткущий СПИСОК_ОПЕРАТОРОВ}
    WriteLn('Внутренняя ошибка #1');
    Halt;
    End;
  OperStack[OperStackPtr]^.AddOper(O);
End;

Procedure SetCurrent(O:OperListPtr);{Добавления в стек нового}
Begin                               {СПИСКА_ОПЕРАТОРОВ}
  If OperStackPtr=StackSize then
    begin
    {Стек полный}
    WriteLn('Внутренняя ошибка #2');
    Halt;
    end;
  Inc(OperStackPtr);
  OperStack[OperStackPtr]:=O;
End;

Procedure UndoCurrent; {Удаление из стека СПИСКА_ОПЕРАТОРОВ}
Begin
  If OperStackPtr=0 then
    begin
    {Стек пустой}
    WriteLn('Внутренняя ошибка #3');
    Halt;
    end;
  Dec(OperStackPtr);
End;

Procedure AddCurrent;
Begin
  If OperStackPtr=1 then
    begin
    {В стеке менее 2-х элементов}
    WriteLn('Внутренняя ошибка #5');
    Halt;
    end;
  OperStack[OperStackPtr-1]^.AddOper(OperStack[OperStackptr]);
End;

Function GetAscii(S:String):Word; {Получения по строке числа}
Var i,W:Word;
Begin
  W:=0;
  For i:=1 to Ord(S[0]) do
    W:=W*10+Ord(S[i])-48;
  GetAscii:=W;
End;

Function HaveInLabels(N:Word):boolean; {Проверка на присутствие}
Var L:StrElPtr;                        {метки в списке}
Begin
  L:=LabelList^.Next;
  While (L<>nil) and (GetAscii(L^.Str)<>N) do
    L:=L^.Next;
  HaveInLabels:=L<>nil;
end;

Function IsNumber(S:String):Boolean; {Функция проверки строки}
Var S1:String;                       {номер ли вней записан ?}
    i:byte;
Begin
  i:=1;
  While (i<=Ord(S[0])) and (Ord(S[i])>=48) and (Ord(S[i])<=58) do
    inc(i);
  If i>Ord(S[0]) then IsNumber:=True
  Else IsNumber:=False;
End;

Function GetIdent:String;Forward;

Function ReadChar:Char;  {Функция считывания символа из файла}
Var S:String;
    I:Word;
    Ptr:StrElPtr;
    Opl1:OperListPtr;
    Op1:OperStringPtr;
Begin
  IF InputStrPtr=Ord(InputString[0]) then
    begin
      Inc(InputStrNum);
      If Not Eof(Fin) then ReadLn(Fin,InputString)
      else InputString:='';
      InputStrPtr:=0;
      If InputString<>'' then
        begin
        S:=GetIdent;
        If IsNumber(S) then
          begin
          Labels.AddLabel(GetAscii(S));
          Ptr:=ProcList^.Next;
          While (Ptr<>nil) and (Ptr^.Str<>S) do Ptr:=Ptr^.Next;
          If Ptr<>nil then
            begin
            New(opl1,Init(0));
            New(Op1,Init('Procedure P'+S+';'+#13+#10+'Begin',
                 GetSpace-2));
            Opl1^.addOper(Op1);
            for i:=OperStackPtr+1 downto 3 do
              OperStack[i]:=OperStack[i-1];
            Inc(OperStackPtr);
            Operstack[2]:=Opl1;
            end;
          End
        Else
          begin
          WriteLn('Строка ',InputStrNum,'  :  Без номера');
          Halt;
          end;
        End;
      ReadChar:=' ';
    end
  Else
    begin
    inc(InputStrPtr);
    ReadChar:=InputString[InputStrPtr];
    End;
End;

Function GetIdent:String; {Функция считывания идентификатора}
Var S:String;
    C:Char;
    I:WORD;
Begin
 if Eof(Fin) And (InputString='') then
   begin
   GetIdent:=' ';
   Exit;
   end;
 If OldInputFlag=1 then
   begin
   OldInputFlag:=0;
   GetIdent:=' ';
   end
 Else
   Begin
   I:=InputStrNum;
   C:=ReadChar;
   While (C=' ') and (I=InputStrNum) do
     C:=ReadChar;
   If (C In Delimier) Or (C=' ') then S:=C else S:='';
   While (C<>' ') and (Not (C In Delimier)) do
     begin
     S:=S+C;
     C:=ReadChar;
     end;
   If (C In Delimier) and (S<>C) then
     Dec(InputStrPtr);
   GetIdent:=S;
   IF (I<>InputStrNum) and (S<>' ') then OldInputFlag:=1;
   End;
End;

Function StrUpper(S:String):String; {Функция преобразования}
Var i:byte;                         {строки в верхний регистр}
Begin
 For i:=1 to Ord(S[0]) do
   If S[i] in ['a'..'z'] then S[i]:=Chr(Ord(S[i])-32);
 StrUpper:=S;
End;

Function IsIdent(S:String):boolean;{Функция проверки на}
Var S1:String;                     {идентификатор}
    i:byte;
Begin
 S1:=StrUpper(S);
 i:=2;
 If S1[1] in ['A'..'Z'] then
   begin
   While (i<=Ord(S1[0])) and (S1[i] In ['0'..'9','A'..'Z']) do
     inc(i);
   IsIdent:=i>Ord(S1[0]);
   end
 else
   IsIdent:=False;
end;

Function IsArrayIdent(S:String):boolean; {Функция проверки S}
Var S1:String;                           {на переменную массив}
    i:byte;
Begin
 S1:=StrUpper(S);
 i:=2;
 If S1[1] in ['A'..'Z'] then
   begin
   While (S1[i]<'(') and (S1[i] In ['0'..'9','A'..'Z']) do
     inc(i);
   IsArrayIdent:=S1[i]='(';
   end
 else
   IsArrayIdent:=False;
end;

Procedure Shift(Var S:String;C:byte);{Процедура сдвига строки S}
Var i,j:byte;                        {на C влево}
Begin
  j:=1;
  For i:=C+1 to Ord(S[0]) do
    begin
    S[j]:=S[i];
    inc(j);
    end;
  S[0]:=Chr(j-1);
End;

Function IsFunction(S:String):boolean;{Проверка строки S}
Var i:byte;                           {на функцию}
Begin
  i:=1;
  While (i<=NumOfFunc) and (S<>FuncArray[i]) do
    inc(i);
  If i>NumOfFunc then
    IsFunction:=False
  else
    IsFunction:=True;
End;

Function GetFunctType(S:String):integer;{Получение типа функции}
Var i:byte;
Begin
  i:=1;
  While (i<=NumOfFunc) and (S<>FuncArray[i]) do inc(i);
  GetFunctType:=FunctTypeArray[i];
End;

Procedure SetVarInfo(S:String;I:Word);{Добавление информации I}
Var P:StrElPtr;                       {к переменной S}
Begin
  P:=VarList^.Next;
  While (P<>nil) and (S<>P^.Str) do
    P:=P^.Next;
  If P<>nil then
    P^.Info:=I;
End;

Procedure AddVariable(S:String;T:Byte;Inf:word);
Var P:StrElPtr;                 {Процедура добавления}
Begin
  P:=VarList^.Next;
  While (P<>nil) and (S<>P^.Str) do
    P:=P^.Next;
  If P<>nil then
    begin
    If (P^.Typ<T) and (T=2) then P^.Typ:=2;
    If (P^.Typ<T) and (P^.Typ>=2) then
      begin
      WriteLn(
      'В исходном тексте неправильно используется переменная:',S);
      Halt;
      end;
    end
  Else
    begin
    New(p);
    P^.Str:=S;
    P^.Typ:=T;
    P^.Info:=inf;
    P^.Next:=VarList^.Next;
    VarList^.Next:=P;
    end;
End;

Function GetVarType(S:String):byte; {Получение типа переменной}
Var P:StrElPtr;
Begin
  P:=VarList^.Next;
  While (P<>nil) and (S<>P^.Str) do
    P:=P^.Next;
  If P<>nil then GetVarType:=P^.Typ
  Else
    begin
    WriteLn('Внутренняя ошибка #4: попытка получить тип неопределенной переменной');
    Halt;
    end;
End;

Procedure AddLabel(S:String); {Добавление новой метки}
Var P:StrElPtr;
Begin
  New(P);
  P^.Str:=S;
  P^.Next:=LabelList^.Next;
  LabelList^.Next:=P;
End;

Procedure AddProc(S:String); {Добавление новой процедуры}
Var P:StrElPtr;
Begin
  New(P);
  P^.Str:=S;
  P^.Next:=ProcList^.Next;
  ProcList^.Next:=P;
End;

Procedure PassStr(S:String); {Проверка на следующий}
Var S1:String;               {идентификатор}
Begin
  S1:=GetIdent;
  If S1<>S then
    begin
    WriteLn('Строка ',InputStrNum,'  : отсутствует ',S);
    Halt;
    end;
End;


{Функции трансляции выражений}

Function Level0(Var S:String):String;Forward;

Function Level2(Var S:String):String;
Var S1,s2:String;
    i:byte;
Begin
  If S[1]='(' then
    begin
    Shift(S,1);
    S1:='('+Level0(S)+')';
    Shift(S,1)
    end
  Else
    begin
    i:=1;
    S1:='';
    While (i<=Ord(S[0])) And (Not (S[i] In MathDelim)) do
      begin
      S1:=S1+S[i];
      inc(i);
      end;
    Shift(S,Ord(S1[0]));
    If IsIdent(S1) and (S[1]='(') then {Проверка ма переменные}
      begin                 {массивы и функции типа TAN(),....}
      If S1='TAN' then
        begin
        S2:=Level0(S);
        S1:='Sin'+S2+'/Cos'+S2;
        VarType:=2;
        end
      Else
        If S1='SQR' then
          begin
          S1:='SQRT'+Level2(S);
          VarType:=2;
          end
        Else
          If IsFunction(S1) then
            begin
            If GetFunctType(S1)=2 then VarType:=2;
            S1:=S1+Level2(S);
            end
          Else
            Begin
            VarType:=TArray;
            AddVariable(S1,TArray,10); {Добавить если нет в списке}
            Shift(S,1);                { переменных}
            S1:=S1+'['+Level0(S)+']'; {Значит это переменная массив}
            Shift(S,1);
            End;
      end
    Else
      begin
      i:=1;
      While (i<=Ord(S1[0])) and (S1[i]<>'.') do
        begin
        If S1[i]='"' then S1[i]:='''';
        inc(i);
        end;
      If i<=Ord(S1[0]) then VarType:=2;
      end;
    end;
  Level2:=S1;
End;

Function Level1(Var S:String):String;
Var S1,S2:String;
    C:Char;
Begin
  S1:=Level2(S);
  If (S[1]='*') Or (S[1]='/') then
    begin
    C:=S[1];
    If S[1]='/' then VarType:=2;
    Shift(S,1);
    S1:=S1+C+Level2(S);
    end
  Else
    If S[1]='^' then {Преобразовать ^ в EXP(LN())}
      begin
      Shift(S,1);
      S2:=Level2(S);
      S1:='EXP('+S2+'*LN(ABS('+S1+')))';
      VarType:=2;
      end;
  Level1:=S1;
End;

Function Level0(Var S:String):String;
Var S1,S2,S3:String;
    C:Char;
Begin
  S1:=Level1(S);
  If (S[1]='+') Or (S[1]='-') then
    begin
    C:=S[1];
    Shift(S,1);
    S1:=S1+C+Level1(S);
    end;
  S2:=S;
  S3:=S;
  If Ord(S2[0])<>0 then S2[0]:=Chr(2);
  If Ord(S3[0])<>0 then S3[0]:=Chr(3);
  If (S2='OR') Or (S3='AND') Or (S3='XOR') Or (S3='NOT') then
    begin
    If S2='OR' then
      begin
      Shift(S,2);
      S1:=S1+'OR'+Level1(S);
      end
    Else
      begin
      Shift(S,3);
      S1:=S1+S3+Level1(S);
      end;
    end;
  Level0:=S1;
End;

Function GetTranslValue(S:String):String;
Begin
  VarType:=1;
  GetTranslValue:=Level0(S);
End;

Function IsReserved(S:String):boolean;{Проверка на}
Var i:integer;           {зарезервированную строку}
Begin
  i:=1;
  While (i<=ResArraySize) and (S<>ResArray[i]) do inc(i);
  IsReserved:=i<=ResArraySize;
End;

Procedure TranslOper(S:String);Forward;

Procedure OpPrint; {Процедура трансляции оператора PRINT}
Var Tr,S,S1,S2:string;
    Ln:boolean;
    i:integer;
    Op:OperStringPtr;
Begin
  S1:='';
  Tr:='';
  While S1<>' ' do
    begin
    S:='';
    While Not IsReserved(S1) and (S1<>' ') And (S1<>',')
          And (S1<>';') do
      begin
      S:=S+S1;
      S1:=GetIdent;
      IF S1='$' then S1:='';
      end;
    If IsReserved(S1) then S1:=' ';
    Ln:=True;
    If S[1]='"' then
      begin
      Tr:=Tr+'''';
      Shift(S,1);
      i:=1;
      While (S[i]<>'"') do
        begin
        Tr:=Tr+S[i];
        Inc(i);
        end;
      Tr:=Tr+'''';
      Shift(S,1);
      continue;
      end;
    If (S<>' ') then
      begin
      Tr:=Tr+GetTranslValue(S);
      end;
    If S1=',' then
      begin
      Tr:=Tr+',''              '',';
      Ln:=False;
      S1:=GetIdent;
      continue;
      end;
    If S1=';' then
      begin
      Ln:=False;
      S1:=GetIdent;
      continue;
      end;
    end;
  if Tr='' then Tr:='WrinteLn;'
  Else
    If Ln then Tr:='WriteLn('+Tr+');'
          else Tr:='Write('+Tr+');';
  New(Op,Init(Tr,GetSpace));
  AddOper(Op);
End;

Procedure OpFor; {Процедура трансляции оператора FOR ... NEXT}
Var S4,S3,S,S1,S2,Tr:String;
    OpL:OperListPtr;
    Ops:OperStringPtr;
Begin
  S:=GetIdent;
  If Not IsIdent(S) then
    begin
    WriteLn('Строка ',InputStrNum,' :  ',S,' не переменная !');
    Halt;
    end;
  PassStr('=');
  S1:=GetIdent;
  S2:='';
  Repeat
    S2:=S2+S1;
    S1:=GetIdent;
    If S1=' ' then
      begin
      WriteLn('Строка ',InputStrNum,'  :  отсутствует "TO"');
      Halt;
      end;
  Until S1='TO';
  S1:=GetTranslValue(S2);
  AddVariable(S,VarType,0);
  S2:=GetIdent;
  S3:='';
  Repeat
    S3:=S3+S2;
    S2:=GetIdent;
  Until (S2='STEP') Or (S2=' ');
  S4:=S2;
  S2:=GetTranslValue(S3);
  AddVariable(S,VarType,0);
  If (S4='STEP') Or (GetVarType(S)=2) then
    begin {While}
    New(OpL,Init(GetSpace-2));
    SetCurrent(OpL);
    Tr:=S+':='+S1+';';
    New(OpS,Init(Tr,GetSpace));
    AddOper(OpS);
    Tr:='While '+S+'<='+S2+' do';
    New(Ops,Init(Tr,GetSpace));
    Labels.lock;
    AddOper(OpS);
    Labels.Unlock;
    If S4='STEP' then
      begin
      S1:=GetIdent;
      S2:='';
      Repeat
        S2:=S2+S1;
        S1:=GetIdent;
      Until S1=' ';
      S1:=GetTranslValue(S2);
      end
    Else S1:='1';
    end
  Else   {For}
    begin
    New(Opl,Init(GetSpace-2));
    SetCurrent(Opl);
    Tr:='For '+S+':='+S1+' To '+S2+' Do';
    New(Ops,Init(Tr,GetSpace));
    AddOper(Ops);
    end;
  New(Opl,Init(GetSpace));
  SetCurrent(Opl);
  New(Ops,Init('Begin',GetSpace));
  Labels.Lock;
  AddOper(Ops);
  Labels.UnLock;
  S2:=GetIdent;
  While S2<>'NEXT' do
    begin
    TranslOper(S2);
    S2:=GetIdent;
    end;
  Labels.Lock;
  If GetVarType(S)=1 then
    Begin
    New(Ops,Init('End;',GetSpace));
    AddOper(Ops);
    End
  Else
    begin
    New(Ops,Init(S+':='+S+'+'{?}+S1+';',GetSpace));
    AddOper(Ops);
    New(Ops,Init('End;',GetSpace));
    AddOper(Ops);
    end;
  AddCurrent;
  UndoCurrent;
  AddCurrent;
  UndoCurrent;
  Labels.Unlock;
  S1:=GetIdent;
  If S1<>S then
    begin
    WriteLn('Требуется NEXT ',S);
    Halt;
    end;
  S1:=GetIdent;
  If S1<>' ' then
    begin
    WriteLn('После NEXT ',S,' не должно стоять ',S1);
    halt;
    end;
  Labels.GetLabel;
End;

Procedure OpGoto; {Процедура трансляции оператора GOTO}
Var S,S1:String;
    Ops:OperStringPtr;
Begin
  S:=GetIdent;
  AddLabel(S);
  New(Ops,Init('GOTO L'+S+';',GetSpace));
  AddOper(Ops);
  S1:=GetIdent;
  If S1<>' ' then
    begin
    WriteLn('После GOTO ',S,' не должно стоять ',S1);
    halt;
    end;
End;

function HaveInStr(S,S1:String):boolean;{Проверка на}
Var i,j:integer;        {вхождение строки S1 в строку S}
    f:boolean;
Begin
  i:=1;  f:=false;
  While (i<=Ord(S[0])-Ord(S1[0])) and Not f do
    begin
    j:=1;
    While (j<=Ord(S1[0])) and (S1[j]=S[i+j-1]) do
      inc(j);
    if j>Ord(S1[0]) then f:=True;
    inc(i);
    end;
ENd;

Procedure OpIf;  {Процедура трансляции оператора IF}
Var S,S1:String;
    Ops,Ops1:OperStringPtr;
    Opl:OperListPtr;
    HaveElse:boolean;
    Siz:integer;
Begin
  S:=GetIdent;
  S1:='';
  Repeat
    S1:=S1+S;
    S:=GetIdent;
    If S=' ' then
      begin
      WriteLn('Строка ',InputStrNum,'  :  отсутствует "THEN"');
      Halt;
      end;
  Until S='THEN';
  S:=GetTranslValue(S1);
  S1:=GetIdent;
  HaveElse:=False;
  If IsNumber(S1) then
    begin
    New(Ops,Init('IF '+S+' THEN GOTO L'+S1,GetSpace));
    AddLabel(S1);
    end
  Else
    begin
    New(Ops,Init('IF '+S+' THEN',GetSpace));
    AddOper(Ops);
    New(Ops,Init('  Begin',GetSpace));
    Labels.lock;
    AddOper(Ops);
    New(Opl,Init(GetSpace));
    SetCurrent(Opl);
    HaveElse:=HaveInStr(InputString,'ELSE');
    TranslOper(S1);
    UndoCurrent;
    AddOper(Opl);
    Labels.Unlock;
    New(Ops,Init('  End',GetSpace));
    End;
  if not Haveelse then S1:=GetIdent;
  Opl:=nil;
  If (S1='ELSE') or HaveElse then
    begin
    HaveElse:=True;
    S1:=GetIdent;
    If IsNumber(S1) then
      begin
      New(Ops1,Init('ELSE GOTO L'+S1+' ',GetSpace));
      AddLabel(S1);
      end
    else
      Begin
      New(Ops1,Init('ELSE ',GetSpace));
      New(Opl,Init(GetSpace));
      SetCurrent(Opl);
      Labels.lock;
      TranslOper(S1);
      Labels.Unlock;
      UndoCurrent;
      End;
    end
  Else Ops^.Op:=Ops^.Op+';';
  If HaveElse then Labels.lock;
  AddOper(Ops);
  If HaveElse then AddOper(Ops1);
  If Opl<>nil then AddOper(Opl);
  If Haveelse then Labels.Unlock;
End;

Procedure OpLet(S:String); {Процедура трансляции}
Var S1,S2:String;          {оператора присвоения}
    Ops:OperStringPtr;
    Arr:boolean;
Begin
  S1:=GetIdent;
  Arr:=True;
  If S1='!' then
    begin
    AddVariable(S,Treal,0);
    S1:=GetIdent;
    End
  Else
    If S1='$' then
      Begin
      AddVariable(S,TString,0);
      S1:=GetIdent
      End
    Else
      If S1='(' then
        Begin
        AddVariable(S,TArray,0);
        S:=S+'[';
        Repeat
          S1:=GetIdent;
          If S1<>')' then S:=S+GetTranslValue(S1);
        Until S1=')';
        S:=S+']';
        S1:=GetIdent;
        Arr:=False;
        End
      Else AddVariable(S,TInteger,0);
  If S1='=' then
    begin
    S1:=GetIdent;
    S2:='';
    Repeat
      S2:=S2+S1;
      S1:=GetIdent;
      If S1='$' then S1:='';
    Until S1=' ';
    S1:=GetTranslValue(S2);
    If Arr then AddVariable(S,VarType,0);
    New(Ops,Init(S+':='+S1+';',GetSpace));
    AddOper(Ops);
    end
  else
    begin
    WriteLn('Строка ',InputStrNum,'  :  Отсутствует "="');
    Halt;
    end;
End;

Procedure OpDim; {Процедура трансляции оператора DIM}
Var S,S1:String;
    i:integer;
    P:StrElPtr;
Begin
  S:=GetIdent;
  If IsIdent(S) then
    begin
    PassStr('(');
    repeat
    S1:=GetIdent;
    If IsNumber(S1) then
      begin
      New(p);
      P^.Str:=S;
      P^.Typ:=4;
      P^.Info:=GetAscii(S1);
      P^.Next:=VarList^.Next;
      VarList^.Next:=P;
      end
    else
      If (S1<>',') and (S1<>')') then
      begin
      WriteLn('Строка ',InputStrNum,'  : требуется номер');
      halt;
      end;
   Until S1=')';
   S:=GetIdent;
   If S<>' ' then
     begin
     WriteLn('Строка ',InputStrNum,
             '  : После DIM недолжно стоять ',S);
     Halt;
     end;
    end
  Else
    begin
    WriteLn('Строка ',InputStrNum,
            '  : требуется идентификатор');
    halt;
    end;
  Labels.GetLabel;
End;

Procedure OpGosub; {Процедура трансляции оператора GOSUB}
Var S1:String;
    Op:OperStringPtr;
Begin
  S1:=GetIdent;
  If IsNumber(S1) then
    begin
    New(Op,Init('P'+S1+';',GetSpace));
    AddOper(Op);
    AddProc(S1);
    S1:=GetIdent;
    If Not IsReserved(S1) and (S1<>' ') then
      begin
      WriteLn('Строка ',InputStrNum,
              ' после GOSUB не должно стоять ',S1);
      halt;
      end;
    end
  Else
    begin
   WriteLn('Строка ',InputStrNum,
           '  : после GOSUB необходим номер, а не ',S1);
    halt;
    end;
end;
Procedure OpReturn; {Процедура трансляции оператора RETURM}
Var Op:OperStringPtr;
Begin
  New(Op,Init('end;',GetSpace));
  AddOper(Op);
  Procedures.AddOper(GetCurrent);
  UndoCurrent;
  If GetIdent<>' ' then
    begin
    WriteLn('Строка ',InputStrNum,
            ' после GOSUB ничего не должно стоять');
    halt;
    end
End;

Procedure OpInput; {Процедура трансляции оператора INPUT}
Var S,s1:String;
    Op:OperStringPtr;
Begin
  S:=GetIdent;
  S1:='';
  Repeat
    If S=';' then S:=',';
    If IsIdent(S) then
      AddVariable(S,TInteger,0);
    S1:=S1+S;
    S:=GetIdent;
  Until S=' ';
  New(Op,Init('Read('+S1+');',GetSpace));
  AddOper(Op);
End;

Procedure OpEnd; {Процедура трансляции оператора END}
Var S:String;
Begin
  S:=GetIdent;
  If S<>' ' then
    begin
      WriteLn('Строка ',InputStrNum,
      ' : после END в строке ничего не должно стоять');
      halt;
    end;
End;

Procedure TranslOper(S:String); {Процедура трансляции}
begin                           {оператора в S}
  if S='INPUT' then begin OpInput; Exit end;
  If S='FOR' then begin OpFor;Exit end;
  If S='PRINT' then begin OpPrint;exit end;
  If S='GOTO' then begin OpGoto;Exit end;
  If S='IF' then begin OpIf;Exit end;
  If S='DIM' then begin OpDim;Exit end;
  If S='GOSUB' then begin OpGosub; Exit; end;
  if S='RETURN' then begin OpReturn; Exit; end;
  if S='END' then begin OpEnd; Exit; end;
  If IsIdent(S) then
    begin
    OpLET(S);Exit
    end;
  WriteLn('Непонятный оператор:',S,' в сторке ',InputStrNum-1);
  Halt;
end;

Procedure Translate; {Процедура трансляции файла}
Var S:String;
Begin
  S:=GetIdent;
  Repeat
    S:=GetIdent;
    TranslOper(S);
  Until InputString='';
End;

Procedure Create(Var V:StrElPtr);{Создание нового списка}
Begin
  New(V);
  V^.Next:=nil;
  V^.Str:='';
  V^.Typ:=0;
  V^.Info:=0;
End;

Var Prg:OperList;
    S,S1:String;
Begin
  ClrScr;
{Инициализация переменных}
  Labels.Init;
  Prg.Init(0);
  Procedures.Init(0);
  OperStackPtr:=0;
  InputString:='';
  OldInputNum:=0;
  InputStrNum:=0;
  InputStrPtr:=0;
  Create(VarList);
  Create(LabelList);
  Create(ProcList);
  Write('Введите имя входного файла (.BAS):');
  Repeat
   If Name<>'' then
     Write('Файл не найден. Повторите ввод. Enter - выход  :');
   ReadLn(Name);
   If Name='' then Halt;
    Assign(Fin,Name);
    {$I-}
    Reset(Fin);
    {$I+}
  Until IOResult=0;
  Write('Введите имя выходного файла (.PAS):');
  ReadLn(Name);{Name:='t';}
  If Name='' then Halt;
  Assign(Fout,Name);
  Rewrite(Fout);

  SetCurrent(@Prg);
  Translate;
{Сохранение отранслированного файла}
  WriteLn(Fout,'Program PRG0000;');
  VarList1:=LabelList^.Next;
  If VarList1<>nil then WriteLn(Fout,'Label');
  While VarList1<>nil do
    begin
    Write(Fout,'   L',VarList1^.Str);
    If VarList1^.Next<>nil then
      WriteLn(Fout,',')
    Else
      WriteLn(Fout,';');
    VarList1:=VarList1^.Next;
    end;
  WriteLn(Fout,'Var');
  VarList1:=VarList^.Next;
  While VarList1<>nil do
    begin
    If VarList1^.Str<>'' then Write(Fout,'    ',VarList1^.Str,':');
    Case VarList1^.Typ Of
      1:WriteLn(Fout,'Integer;');
      2:WriteLn(Fout,'Real;');
      3:WriteLn(Fout,'String;');
      4: begin
         Str(VarList1^.Info,S);
         S:='1..'+S;
         VarList2:=VarList1^.Next;
         While VarList2<>nil do
           Begin
           If VarList2^.str=VarList1^.Str then
             begin
             Varlist2^.str:='';
             Varlist2^.TYP:=0;
             Str(VarList2^.info,s1);
             s:='1..'+s1+','+s;
             end;
           VarList2:=VarList2^.Next;
           end;
         WriteLn(Fout,'Array[',s,'] of real;');
         end;
    End;
    VarList1:=VarList1^.Next;
    end;
  VarList1:=ProcList^.Next;
  While VarList1<>nil do
    begin
    WriteLn(Fout,'Procedure P'+VarList1^.Str+';Forward;');
    VarList1:=VarList1^.Next;
    end;
  Procedures.WriteF(Fout);
  WriteLN(Fout,'Begin');
  Prg.WriteF(Fout);
  WriteLn(Fout,'End.');
{Освобождение занимаемой памяти}
  While VarList<>nil do
    begin
    VarList1:=VarList^.Next;
    Dispose(VarList);
    VarList:=VarList1;
    end;
  While LabelList<>nil do
    begin
    VarList1:=LabelList^.Next;
    Dispose(LabelList);
    LabelList:=VarList1;
    end;
  While ProcList<>nil do
    begin
    VarList1:=ProcList^.Next;
    Dispose(ProcList);
    ProcList:=VarList1;
    end;
  Procedures.Done;
  Prg.Done;
  Close(Fin);
  Close(Fout);
  WriteLn;
  WriteLn('Все впорядке.');
End.