Const
  ErCode   : Byte = 1; {1 - unexpected end of file...}
                       {2 - точка не там где надо}
                       {3 - неизвестный символ}
                       {4 - слишком длинная строка}
                       {5 - неверный символ в строке}
                       {6 - неверное число}
                       {7 - Duplicate Name}
                       {8 - Unknown Identifier}
                       {9 - End Expected}
                       {10- Begin Expected}
  ErString : String ='';
  Level: Word=0;
{-----------------------------------}
Procedure EndCom1;
Var
  C:Char; 
Begin
  Repeat
    IF F.EndOfFile Then Exit;
    C:=Chr(F.ReadNextByte);
  Until (C='}');
End;
Procedure EndCom2;
Var
  C:Char; 
Begin
  Repeat
    Repeat
      IF F.EndOfFile Then Exit;
      C:=Chr(F.ReadNextByte);
    Until (C='*');
    IF F.EndOfFile Then Exit;
    C:=Chr(F.ReadNextByte);
 Until (C=')');
End;
{=================================================}
Procedure MakeLists;
Var
  AAA    : Boolean;
  CCC    : BlockP;
  B : Byte;
  Found : Byte;
  C : Char;
  R : Real;
  Res : Integer;
  RI : LongInt;
  QQQ: LongInt;
  S : String;
Label Home,Home1;
Begin
   CCC:=Main;
   S :='';
Home: 
  If (S=':') Or (S='OF') Then AAA:=True Else AAA:=False;
  Repeat
    IF F.EndOfFile Then Exit;
    B:=F.ReadNextByte;
    C:=Chr(B);
  Until (C<>' ') And (Not (B in [9,10,13]));
Home1:
  If (C=' ') Or (C in [#13,#10,#9]) Then GoTo Home
                                   Else B:=Ord(C);
{---Сперва удаляем комментарии!!! обязательно в такой последовательности---}
  If C='(' Then Begin
    IF F.EndOfFile Then Exit;
    B:=F.ReadNExtByte;
    C:=Chr(B);
    If C='*' Then Begin EndCom2;GoTo Home;End;
    AddLingvo(4,1,1);
    If (C=' ') Or (B in [9,10,13]) Then GoTo Home;
  End;
  If C='{' Then Begin 
    EndCom1;
    GoTo Home;
  End;
{----------------------------------------------------------------------}  
  If C in SSet Then Begin 
    If (C='.')  And (S='END') Then Begin AddLingvo(4,3,3); ErCode:=0; Exit; End;
    If C='.' Then Begin ErCode:=2;ErString:=S;Exit; End;
    For B:=1 To NSS Do Begin If SSym[B]=C Then AddLingvo(4,B,B);End;
    S:=C;
    GoTo Home; 
  End;
{----------------}
  If C in ISet Then Begin 
     S:='';
     While (Not F.EndOfFile) And ((C in ISet) Or (C in ['0'..'9'])) Do Begin
       S:=S+UpCase(C);
       C:=Chr(F.ReadNextByte);
     End;
     Found:=0;
     For B:=1 To NKW Do If KeyWords[B].S=S Then Begin AddLingvo(2,B,B); Found:=B;End;
     Case Found Of
       22,23: Begin {func+proc}       
              If CCC^.NextLevel=Nil Then Begin
                New(CCC^.NextLevel);
                CCC^.NextLevel^.Prev:=CCC;
                CCC:=CCC^.NextLevel;
                CCC^.BlN:=LingvoNum;
                WriteLn('ok:',CCC^.BlN);
                CCC^.BeginN:=0;
                CCC^.EndN:=0;
                CCC^.NextLevel:=Nil;
                CCC^.Next:=Nil;
                CCC^.ProcName:='';
                CCC^.LevelNum:=CCC^.Prev^.LevelNum+1;
                WriteLn(CCC^.LevelNum);
                CCC^.IdentL:=Nil;
              End
              Else Begin
                CCC:=CCC^.NextLevel;
                While CCC^.Next<>Nil Do CCC:=CCC^.Next;
                New(CCC^.Next);
                CCC^.Next^.Prev:=CCC^.Prev;
                CCC^.Next^.LevelNum:=CCC^.LevelNum;
                CCC:=CCC^.Next;
                CCC^.BlN:=LingvoNum;
                CCC^.BeginN:=0;
                CCC^.EndN:=0;
                CCC^.NextLevel:=Nil;
                CCC^.Next:=Nil;
                CCC^.ProcName:='';
                CCC^.IdentL:=Nil;
              End;
              End; 
{---------------------------------}
       1  : If CCC^.BeginN=0 Then 
            Begin 
              If CCC^.EndN=0 Then Begin CCC^.BeginN:=LingvoNum;CCC^.EndN:=1; End
              Else Begin ErCode:=9;ErString:=S;Exit;End;
            End Else Inc(CCC^.EndN);
       2  : Begin {end}
              If CCC^.EndN<>0 Then Dec(CCC^.EndN) Else Begin ErCode:=10;ErString:=S;Exit;End;
              If (CCC^.BeginN<>0) And (CCC^.EndN=0) Then Begin
                CCC^.EndN:=LingvoNum;
                CCC:=CCC^.Prev;
              End;
            End;
{record}31: If CCC^.BeginN=0 Then Inc (CCC^.EndN) Else Begin ErCode:=9;ErString:=S;End;
{case}  13: If CCC^.BeginN<>0 Then Inc (CCC^.EndN) Else Begin ErCode:=10;ErString:=S;End 
     End;
     If Found=0 Then Begin
       If CCC^.ProcName='' Then Begin
         CCC^.ProcName:=S;
         Cu:=CCC^.Prev;
         While Cu<>Nil Do Begin 
           If 0<>FindNumber(S,Cu^.IdentL) Then Begin ErCode:=7;ErString:=S;Exit;End;
           Cu:=Cu^.Prev;
         End;
         QQQ:=GetNumber(S,CCC^.Prev^.IdentL);
         AddLingvo(1,-CCC^.Prev^.LevelNum,GetNumber(S,CCC^.Prev^.IdentL));
       End
       Else Begin
         If (CCC^.BeginN=0) And (Not AAA) Then 
           If FindNumber(S,CCC^.IdentL)=0 Then AddLingvo(1,CCC^.LevelNum,GetNumber(S,CCC^.IdentL))
             Else Begin ErCode:=7; ErString:=S; Exit;End
         Else Begin
           Cu:=CCC;
           While (FindNumber(S,Cu^.IdentL)=0) And (Cu^.Prev<>Nil) Do Cu:=Cu^.Prev;
           If FindNumber(S,Cu^.IdentL)<>0 Then Begin
             AddLingvo(1,Cu^.LevelNum,GetNumber(S,Cu^.IdentL));
           End
           Else Begin ErCode:=8; ErString:=S; Exit;End;
         End;
       End;
     End;
     GoTo Home1; 
  End;
  If C in CSet Then Begin 
{    If C='#' Then Begin
      GoTo Home1;
    End;
    If C='$' Then Begin
      GoTo Home1;
    End;}
    If C in ['0'..'9'] Then Begin
      S:='';      
      Repeat
        S:=S+C;
        IF F.EndOfFile Then Exit;
        C:=Chr(F.ReadNextByte);
      Until (Not (C in ['.','0'..'9','e','E','+','-'])) Or (Length(S)>20) Or
        ((C in ['+','-']) and (upcase(s[length(s)])<>'E'));
      Val(S,R,Res);
      If (Res<>0) Or (Length(S)>20) Then Begin
        ErCode:=6;
        ErString:=S;
        Exit;
      End;
      Val(S,RI,Res);
      If Res=0 Then AddLingvo(3,1,GetNumber(S,CsB))
               Else AddLingvo(3,2,GetNumber(S,CsB));
      GoTo Home1;
    End;
    If C=#$27 Then Begin
      S:='';
      Repeat
        IF F.EndOfFile Then Exit;
        C:=Chr(F.ReadNextByte);
        S:=S+C;
      Until (C=#$27) Or (C in [#13,#10]) Or (Length(S)>200);
      Delete(S,Length(S),1);
      ErString:=S;
      If Length(S)>200 Then Begin ErCode:=4;Exit;End;
      If C<>#$27 Then Begin ErCode:=5; Exit;End;  
      If Length(S)<2 Then AddLingvo(3,3,GetNumber(S,CsB))
                     Else AddLingvo(3,4,GetNumber(S,CsB));
      GoTo Home; 
    End;
  End;
  ErCode:=3;ErString:=S+C;
End;
{-------------------------------}
Procedure PrintIdent(C:ListP;I:Integer);
 Var  D:ListP;
Begin
  D:=C;
  While D<>Nil Do Begin WriteLn(' ':3*I,'Идентификатор:',D^.S);D:=D^.Next;End;
End;
{-------------------------------}
Procedure PrintLevel(Cu1:BlockP);
Var
  Cu2:Blockp;
Begin
  Cu2:=Cu1;
  While Cu2<>Nil Do Begin
    WriteLn(' ':3*Cu2^.LevelNum,Cu2^.ProcName,' уровень:',Cu2^.LevelNum,' начало:',Cu2^.BlN,
           ' конец описания:',Cu2^.BeginN,' конец блока:',Cu2^.EndN);
    PrintIdent(Cu2^.IdentL,Cu2^.LevelNum);
    If Cu2^.NextLevel<>Nil Then PrintLevel(Cu2^.NextLevel);
    Cu2:=Cu2^.Next;
  End;
End;
{-------------------------------}
Procedure PrintLingvo;
Var
  C   : LingvoP;
  OOO : LongInt;
  Cu1 : BlockP;
Begin
  C:=Lin;
  While C<>Nil Do Begin
   WriteLn('[ ',C^.LType,',',C^.LCode,',',C^.LPnt,' ]');
{   If C^.LType=1 Then WriteLn('[',A[C^.LType]:20,',',A1[C^.LCode]:20,',      имя: ',ListFind(C^.LPnt,IsB),'  ]');
   If C^.LType=3 Then WriteLn('[',A[C^.LType]:20,',',A3[C^.LCode]:20,', значение: ',ListFind(C^.LPnt,CsB),']');
   If C^.LType=2 Then WriteLn('[',A[C^.LType]:20,',',C^.LCode:20,',    слово: ',KeyWords[C^.LPnt].S,']');
   If C^.LType=4 Then WriteLn('[',A[C^.LType]:20,',',C^.LCode:20,',   символ "',Ssym[C^.LPnt],'" ]');}
   C:=C^.Next;
  End;
  WriteLn('---------------------------------');
  C:=Lin;
  OOO:=0;
  While C<>Nil Do Begin
    Write(OOO);
    Inc(OOO);
{   WriteLn('[ ',C^.LType,',',C^.LCode,',',C^.LPnt,' ]');}
   If C^.LType=1 Then WriteLn('[',A[C^.LType]:20,',',C^.LCode,',      имя: ',C^.LPnt{ListFind(C^.LPnt,IsB)},'  ]');
   If C^.LType=3 Then WriteLn('[',A[C^.LType]:20,',',A3[C^.LCode]:20,', значение: ',ListFind(C^.LPnt,CsB),']');
   If C^.LType=2 Then WriteLn('[',A[C^.LType]:20,',',C^.LCode:20,',    слово: ',KeyWords[C^.LPnt].S,']');
   If C^.LType=4 Then WriteLn('[',A[C^.LType]:20,',',C^.LCode:20,',   символ "',Ssym[C^.LPnt],'" ]');
   C:=C^.Next;
  End;
  WriteLn('---------------------------------');
  PrintLevel(Main);
End;