PROGRAM   ParseADA ;
{$IFDEF MSDOS}   USES   DOS ;   {$ENDIF}      {--- TP4,... }
{$IFDEF DPMI}    USES   DOS ;   {$ENDIF}
{$IFDEF WIN32}   {$APPTYPE CONSOLE}   USES   SysUtils ;   {$ENDIF}      {--- Delphi2,... }

{$IFDEF MSDOS}   {$DEFINE MSDOS_DPMI}   {$ENDIF}
{$IFDEF DPMI}    {$DEFINE MSDOS_DPMI}   {$ENDIF}

{
!------------------------------------------------------------------------------
! Small Toolbox
!------------------------------------------------------------------------------
}
{$IFDEF MSDOS_DPMI}
{
!---------------
! String routines
!---------------
! UpperCase
!---------------
}
{===== UpperCase }

FUNCTION   UpperCase   ( IL_String : String ) : String ;
VAR
   L_i : Integer ;
BEGIN
   FOR L_i := 1 TO Length(IL_String) DO BEGIN
      IL_String[L_i] := UpCase ( IL_String[L_i] );
   END;
   UpperCase := IL_String ;
END;
{$ENDIF}

{$IFDEF MSDOS_DPMI}
{
!---------------
! FileExists
!---------------
}
{===== FileExists }

FUNCTION   FileExists   ( I_Path : String ) : Boolean ;
VAR
   L_SearchRec : SearchRec ;
BEGIN
   FindFirst ( I_Path , AnyFile , L_SearchRec );
   FileExists := ( DosError = 0 );
END;
{$ENDIF}


{$IFDEF MSDOS}{$IFNDEF VER70}
{
!---------------
! PChar type
!---------------
}
TYPE
   PChar = ^Char ;
{$ENDIF}{$ENDIF}

{
!------------------------------------------------------------------------------
! This program toolbox
!------------------------------------------------------------------------------
}
{
!---------------
! Const: Parser Result prXXXXX
!
! NEXTxxx: Mini parser for ADA language
!---------------
}
CONST
   prToken             = 1 ;
   prSymbol            = 2 ;
   prSymbol2Ch         = 3 ;
   prQuotedText        = 4 ;
   prIllegalToken      = 5 ;

   prLineComment       = 6 ;
   prComment           = 7 ;
   prFilling           = 8 ;

   prEndQuoteMissing   = 9 ;
   prEndCommentMissing = 10 ;
   prEndOfBuffer       = 11 ;

   prQuotedChar        = 12 ;     {--- 2006/03/22 }

CONST
   C_ParserResultStr : ARRAY[1..12] OF String[17] = (
      'Token'             ,
      'Symbol'            ,
      'Symbol2Ch'         ,
      'QuotedText'        ,
      'IllegalToken'      ,
      'LineComment'       ,
      'Comment'           ,
      'Filling'           ,
      'EndQuoteMissing'   ,
      'EndCommentMissing' ,
      'EndOfBuffer'       ,
      'QuotedChar'
   );


{===== NEXTxxx }

FUNCTION   NEXTxxx   ( I_BuffPLast : PChar
                     ; Var IO_PBegin   : PChar
                     ; Var O_PAfterEnd : PChar
                     ) : Byte ;   {Parser Result const, prXXXXX}
LABEL
   LABEL_End11 ,                                              {   'Z'            }
   LABEL_End21 , LABEL_End22 , LABEL_End23 ,                  {   /=   <=   >=   }
   LABEL_End24 , LABEL_End25 ,                                {   :=   ..        }
   LABEL_End26 , LABEL_End27 ,                                {   <<   >>        }
   LABEL_End28 , LABEL_End29 ,                                {   =>   --...     }
   LABEL_Bloc3 ,
   LABEL_Loop29_BREAK ,
   LABEL_Loop35_BREAK ;
CONST
   C_OneCharSymbols   : String[15] = '+-*/>=<(),:.;''&' ;
   C_CharsEndingToken : String[15] = '+-*/>=<(),:.;''&' ;
BEGIN
   {----- Controls : nil, non sense values }
   IF (I_BuffPLast = nil) Or (IO_PBegin = nil) Or (Longint(I_BuffPLast) < Longint(IO_PBegin))
   THEN BEGIN
      NEXTxxx := prEndOfBuffer ;
      EXIT ;
   END;

   {===== 0. Search first char of the token }
   {----- Buffer   :  Other...  CRLF  Other...   TokenBeeingSearched               }
   {----- Pointers :                    IO_PBegin^                  ^O_PAfterEnd   }
   WHILE IO_PBegin^ in [' ',#9,#10,#13] DO BEGIN
      INC ( Longint(IO_PBegin) );
      IF Longint(I_BuffPLast) < Longint(IO_PBegin) THEN BEGIN  NEXTxxx:=prEndOfBuffer;  EXIT;  END;
   END;
   O_PAfterEnd := IO_PBegin ;

   {===== 1. Special three non alpha chars tokens, like   'Z'   }

   {----- 1.1. case:   'Z'   }
   IF IO_PBegin^ = ''''
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd),2);  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> ''''                        THEN BEGIN  DEC(Longint(O_PAfterEnd),2);  GOTO LABEL_End11;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prQuotedChar ;
      EXIT ;
   END;
   LABEL_End11:

   {===== 2. Special two non alpha chars tokens, like   /=   <=   >=   :=   ..   }

   {----- 2.1. case:   /=   }
   IF IO_PBegin^ = '/'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '='                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End21;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End21:

   {----- 2.2. case:   <=   }
   IF IO_PBegin^ = '<'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '='                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End22;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End22:

   {----- 2.3. case:   >=   }
   IF IO_PBegin^ = '>'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '='                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End23;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End23:

   {----- 2.4. case:   :=   }
   IF IO_PBegin^ = ':'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '='                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End24;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End24:

   {----- 2.5. case:   ..   }
   IF IO_PBegin^ = '.'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '.'                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End25;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End25:

   {----- 2.6. case:   <<   }
   IF IO_PBegin^ = '<'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '<'                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End26;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End26:

   {----- 2.7. case:   >>   }
   IF IO_PBegin^ = '>'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '>'                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End27;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End27:

   {----- 2.8. case:   =>   }
   IF IO_PBegin^ = '='
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '>'                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End28;  END;
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol2Ch ;
      EXIT ;
   END;
   LABEL_End28:

   {----- 2.9. case:   --... Line comment, just search end of line   }
   IF IO_PBegin^ = '-'
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_Bloc3;  END;
      IF O_PAfterEnd^ <> '-'                         THEN BEGIN  DEC(Longint(O_PAfterEnd));  GOTO LABEL_End29;  END;

      REPEAT {search end of line}
         INC ( Longint(O_PAfterEnd) );
         IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN GOTO LABEL_Loop29_BREAK ;
      UNTIL O_PAfterEnd^ in [#10,#13];
      LABEL_Loop29_BREAK:
      NEXTxxx := prLineComment ;
      EXIT ;
   END;
   LABEL_End29:

   {===== 3. Other cases }
 LABEL_Bloc3:
   {----- 3.1. case: }
   IF False
   THEN BEGIN
   END ELSE

   {----- 3.2. case:   one char symbol,  like + - * < ; etc   }
   IF Pos ( IO_PBegin^ , C_OneCharSymbols ) >= 1
   THEN BEGIN
      INC ( Longint(O_PAfterEnd) );
      NEXTxxx := prSymbol ;
      EXIT ;
   END ELSE

   {----- 3.3. case:   quote "   }
   IF IO_PBegin^ in ['"']
   THEN BEGIN
      {----- Buffer  :  Other...  CRLF  Other...   " Quotes beeing processed "               }
      {----- Pointers:                    IO_PBegin^                          ^O_PAfterEnd   }
      REPEAT   { search end quote, skipping double quotes}
         INC ( Longint(O_PAfterEnd) );
         IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  NEXTxxx:=prEndQuoteMissing;  EXIT;  END;
         IF O_PAfterEnd^ in [#10,#13]                   THEN BEGIN  NEXTxxx:=prEndQuoteMissing;  EXIT;  END;
         IF O_PAfterEnd^ = '"' THEN BEGIN
            INC ( Longint(O_PAfterEnd) );
            IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN BEGIN  NEXTxxx:=prQuotedText;  EXIT;  END;
            IF O_PAfterEnd^ <> '"'                         THEN BEGIN  NEXTxxx:=prQuotedText;  EXIT;  END;
         END;
      UNTIL False ;
   END ELSE

   {----- 3.5. case:   normal token }
   BEGIN
      {----- Buffer   :  Other...  CRLF  Other...   TokenBeeingSearched               }
      {----- Pointers :                    IO_PBegin^                  ^O_PAfterEnd   }
      REPEAT
         INC ( Longint(O_PAfterEnd) );
         IF Longint(I_BuffPLast) < Longint(O_PAfterEnd) THEN GOTO LABEL_Loop35_BREAK ;
         IF Pos ( O_PAfterEnd^ , C_CharsEndingToken ) >= 1 THEN GOTO LABEL_Loop35_BREAK ;
      UNTIL O_PAfterEnd^ in [' ',#9,#10,#13];
      LABEL_Loop35_BREAK:
      NEXTxxx := prToken ;
   END;
END;

{
!------------------------------------------------------------------------------
! This program toolbox  ( bis )
!------------------------------------------------------------------------------
}
{
!---------------
! ProcessBuffer_Same
! ProcessBuffer_Verbose
! ProcessBuffer_Parse
! ProcessBuffer_NoComment
! ProcessBuffer_Compact
! ProcessBuffer_PackLine
!---------------
}
{===== ProcessBuffer_Same }

PROCEDURE   ProcessBuffer_Same   ( I_BufFirst , I_BufLast : PChar );
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- LOOP 2.1 , OUTPUT : Filling }
      WHILE L_Ptr^ in [' ',#9,#10,#13] DO BEGIN
         Write (   L_Ptr^   );
         Inc ( Longint(L_Ptr) );
         IF Longint(I_BufLast) < Longint(L_Ptr) THEN EXIT ;
      END;{while}

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF L_prResult in [ prToken , prSymbol , prSymbol2Ch , prQuotedText , prIllegalToken
                       , prLineComment , prComment
                       , prQuotedChar ]
      THEN BEGIN
         {----- LOOP 2. , OUTPUT : Token, Symbol,... as found }
         WHILE Longint(L_Ptr) < Longint(L_PAfterEnd) DO BEGIN
            Write (   L_Ptr^   );
            Inc ( Longint(L_Ptr) );
         END;{while}
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
END;

{===== ProcessBuffer_Verbose }

PROCEDURE   ProcessBuffer_Verbose   ( I_BufFirst , I_BufLast : PChar );
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;
VAR
   L_TmpStr : String[20];
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF TRUE THEN BEGIN
         {----- LOOP 2. , OUTPUT : Token, Symbol,... as found }
         WHILE Longint(L_Ptr) < Longint(L_PAfterEnd) DO BEGIN
            Write (   L_Ptr^   );
            Inc ( Longint(L_Ptr) );
         END;{while}

         {----- OUTPUT : Token type }
         L_TmpStr := C_ParserResultStr[L_prResult];
         WHILE Length(L_TmpStr) < 11 DO L_TmpStr := ' '  +  L_TmpStr ;
         IF Length(L_TmpStr) > 11 THEN L_TmpStr := Copy ( L_TmpStr , 1 , 11 );
         Write (   '   -- '  ,  L_TmpStr   );

         WriteLn ;
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
END;

{===== ProcessBuffer_Parse }

PROCEDURE   ProcessBuffer_Parse   ( I_BufFirst , I_BufLast : PChar );
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF L_prResult in [ prToken , prSymbol , prSymbol2Ch , prQuotedText , prIllegalToken
                       , prLineComment , prComment
                       , prQuotedChar ]
      THEN BEGIN
         {----- LOOP 2. , OUTPUT : Token, Symbol,... as found }
         WHILE Longint(L_Ptr) < Longint(L_PAfterEnd) DO BEGIN
            Write (   L_Ptr^   );
            Inc ( Longint(L_Ptr) );
         END;{while}

         WriteLn ;
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
END;

{===== ProcessBuffer_NoComment }

PROCEDURE   ProcessBuffer_NoComment   ( I_BufFirst , I_BufLast : PChar );
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF L_prResult in [ prToken , prSymbol , prSymbol2Ch , prQuotedText , prIllegalToken
                       , prQuotedChar ]
      THEN BEGIN
         {----- LOOP 2. , OUTPUT : Token, Symbol,... as found }
         WHILE Longint(L_Ptr) < Longint(L_PAfterEnd) DO BEGIN
            Write (   L_Ptr^   );
            Inc ( Longint(L_Ptr) );
         END;{while}

         WriteLn ;
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
END;

{===== ProcessBuffer_Compact }

VAR
   G_TmpBuf_LineCompacted : String ;
   G_PREV_prResult : Byte ;

PROCEDURE   ProcessBuffer_Compact   ( I_BufFirst , I_BufLast : PChar );
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;

   L_String0  : String[1];
   L_TokenLen : Longint ;
   L_String1  : String ;
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      IF I_BufFirst <> nil
      THEN BEGIN   { Before Process }
         G_TmpBuf_LineCompacted := '' ;
         G_PREV_prResult        := prFilling ;
      END
      ELSE BEGIN   { After Process }
         IF G_TmpBuf_LineCompacted <> ''
         THEN WriteLn (   G_TmpBuf_LineCompacted   );
      END;
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF L_prResult in [ prToken , prSymbol , prSymbol2Ch , prQuotedText , prIllegalToken
                       , prQuotedChar ]
      THEN BEGIN
         {----- Put a space between 2 tokens ?  }
         IF (G_PREV_prResult = prToken) And (L_prResult = prToken)
         THEN L_String0 := ' '
         ELSE L_String0 := '' ;

         {----- CONTROL : Current token too long ?  }
         L_TokenLen := Longint(L_PAfterEnd) - Longint(L_Ptr);
         IF L_TokenLen > 126 THEN BEGIN
            {----- OUTPUT : Previous temp buffer }
            WriteLn (   G_TmpBuf_LineCompacted   );
            G_TmpBuf_LineCompacted := '' ;

            {----- OUTPUT : Current token }
           {$IFDEF WIN32}
            SetLength ( L_String1 , 126 );
           {$ELSE}
            Byte(L_String1[0]) := 126 ;
           {$ENDIF}
            Move ( L_Ptr^ , L_String1[1] , 126 );
            WriteLn (   L_String1   );

            {----- OUTPUT : Error message }
            WriteLn (   'ERROR: '  ,  'Token too long.'   );
            HALT ( 1 );
         END;

         {----- Copy current token ==> TmpString }
        {$IFDEF WIN32}
         SetLength ( L_String1 , L_TokenLen );
        {$ELSE}
         Byte(L_String1[0]) := L_TokenLen ;
        {$ENDIF}
         Move ( L_Ptr^ , L_String1[1] , L_TokenLen );

         {----- "Temp line buffer" would be full ?  }
         IF ( Length(G_TmpBuf_LineCompacted) + Length(L_String0) + Length(L_String1) ) > 79
         THEN BEGIN
            {----- OUTPUT : Previous temp buffer }
            WriteLn (   G_TmpBuf_LineCompacted   );
            G_TmpBuf_LineCompacted := '' ;
            L_String0              := '' ;   { Token sent to next line }
         END;

         {----- Temp line buffer : add "token" }
         G_TmpBuf_LineCompacted := G_TmpBuf_LineCompacted  +  L_String0  +  L_String1 ;

         G_PREV_prResult := L_prResult ;
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
END;

{===== ProcessBuffer_PackLine }

PROCEDURE   ProcessBuffer_PackLine   ( I_BufFirst , I_BufLast : PChar );
LABEL
   LABEL_Loop1_BREAK ,
   LABEL_Loop21_BREAK ;
VAR
   L_Ptr       : PChar ;
   L_PAfterEnd : PChar ;
   L_prResult  : Integer ;

   L_NewLineQ : Boolean ;

   L_String0  : String[1];
   L_TokenLen : Longint ;
   L_String1  : String ;
BEGIN
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      IF I_BufFirst <> nil
      THEN BEGIN   { Before Process }
         G_TmpBuf_LineCompacted := '' ;
         G_PREV_prResult        := prFilling ;
      END
      ELSE BEGIN   { After Process }
         IF G_TmpBuf_LineCompacted <> ''
         THEN WriteLn (   G_TmpBuf_LineCompacted   );
      END;
      EXIT ;
   END;

   L_PAfterEnd := I_BufFirst ;

   {----- LOOP 1 , Call parser }
   REPEAT

      L_Ptr := L_PAfterEnd ;

      {----- LOOP 2.1 , Skip filling }
      WHILE L_Ptr^ in [' ',#9] DO BEGIN
         Inc ( Longint(L_Ptr) );
         IF Longint(I_BufLast) < Longint(L_Ptr) THEN GOTO LABEL_Loop21_BREAK ;
      END;{while}
      LABEL_Loop21_BREAK:

      {----- Check NewLine }
      IF L_Ptr^ = #10
      THEN BEGIN
         Inc ( Longint(L_Ptr) );
         L_NewLineQ := TRUE ;
      END
      ELSE BEGIN
         IF L_Ptr^ = #13 THEN BEGIN
            Inc ( Longint(L_Ptr) );
            IF Longint(L_Ptr) <= Longint(I_BufLast) THEN BEGIN
               IF L_Ptr^ = #10
               THEN Inc ( Longint(L_Ptr) );
            END;
            L_NewLineQ := TRUE ;
         END
         ELSE L_NewLineQ := False ;
      END;
      IF L_NewLineQ = TRUE THEN BEGIN
         {----- OUTPUT : temp line buffer }
         IF G_TmpBuf_LineCompacted <> '' THEN BEGIN
            WriteLn (   G_TmpBuf_LineCompacted   );
            G_TmpBuf_LineCompacted := '' ;
            G_PREV_prResult        := prFilling ;
         END;
      END;
      IF Longint(I_BufLast) < Longint(L_Ptr) THEN GOTO LABEL_Loop1_BREAK ;

      {----- PARSER , Get "next token" }
      L_prResult := NEXTxxx ( I_BufLast , L_Ptr , L_PAfterEnd );

      IF L_prResult in [ prToken , prSymbol , prSymbol2Ch , prQuotedText , prIllegalToken
                       , prQuotedChar ]
      THEN BEGIN
         {----- Put a space between 2 tokens ?  }
         IF (G_PREV_prResult = prToken) And (L_prResult = prToken)
         THEN L_String0 := ' '
         ELSE L_String0 := '' ;

         {----- CONTROL : Current token too long ?  }
         L_TokenLen := Longint(L_PAfterEnd) - Longint(L_Ptr);
         IF L_TokenLen > 126 THEN BEGIN
            {----- OUTPUT : Previous temp buffer }
            WriteLn (   G_TmpBuf_LineCompacted   );
            G_TmpBuf_LineCompacted := '' ;

            {----- OUTPUT : Current token }
           {$IFDEF WIN32}
            SetLength ( L_String1 , 126 );
           {$ELSE}
            Byte(L_String1[0]) := 126 ;
           {$ENDIF}
            Move ( L_Ptr^ , L_String1[1] , 126 );
            WriteLn (   L_String1   );

            {----- OUTPUT : Error message }
            WriteLn (   'ERROR: '  ,  'Token too long.'   );
            HALT ( 1 );
         END;

         {----- Copy current token ==> TmpString }
        {$IFDEF WIN32}
         SetLength ( L_String1 , L_TokenLen );
        {$ELSE}
         Byte(L_String1[0]) := L_TokenLen ;
        {$ENDIF}
         Move ( L_Ptr^ , L_String1[1] , L_TokenLen );

         {----- "Temp line buffer" would be full ?  }
         IF ( Length(G_TmpBuf_LineCompacted) + Length(L_String0) + Length(L_String1) ) > 126
         THEN BEGIN
            {----- OUTPUT : Previous temp buffer }
            WriteLn (   G_TmpBuf_LineCompacted   );
            G_TmpBuf_LineCompacted := '' ;

            {----- OUTPUT : Current token }
            WriteLn (   L_String1   );

            {----- OUTPUT : Error message }
            WriteLn (   'ERROR: '  ,  'Line too long.'   );
            HALT ( 1 );
         END;

         {----- Temp line buffer : add "token" }
         G_TmpBuf_LineCompacted := G_TmpBuf_LineCompacted  +  L_String0  +  L_String1 ;

         G_PREV_prResult := L_prResult ;
      END;

   UNTIL Longint(L_Ptr) > Longint(I_BufLast);
   LABEL_Loop1_BREAK:
END;

{
!------------------------------------------------------------------------------
! This program routines
!------------------------------------------------------------------------------
}
{
!---------------
! ProcessBuffer
!---------------
}
TYPE
   TParseMode = ( pmSame , pmVerbose , pmParse , pmNoComment , pmCompact  , pmPackLine );
VAR
   G_ParseMode : TParseMode ;

{===== ProcessBuffer }

PROCEDURE   ProcessBuffer   ( I_BufFirst , I_BufLast : PChar );
BEGIN
   CASE G_ParseMode OF
      pmSame      : ProcessBuffer_Same      ( I_BufFirst , I_BufLast );
      pmVerbose   : ProcessBuffer_Verbose   ( I_BufFirst , I_BufLast );
      pmParse     : ProcessBuffer_Parse     ( I_BufFirst , I_BufLast );
      pmNoComment : ProcessBuffer_NoComment ( I_BufFirst , I_BufLast );
      pmCompact   : ProcessBuffer_Compact   ( I_BufFirst , I_BufLast );
      pmPackLine  : ProcessBuffer_PackLine  ( I_BufFirst , I_BufLast );
   END;{case}

   (*
   IF (I_BufLast = nil) Or (I_BufFirst = nil) THEN BEGIN
      IF I_BufFirst <> nil
      THEN WriteLn (   '***** Begin'   )       {--- Before Process }
      ELSE WriteLn (   '***** End'     );      {--- After Process }
      EXIT ;
   END;

   {----- Input ==> Output, char by char }
   L_Ptr := I_BufFirst ;
   WHILE L_Ptr <= PChar(I_BufLast) DO BEGIN
      Write (   L_Ptr^   );
      Inc ( Longint(L_Ptr) );
   END;
   *)
END;


{===============}


VAR
   GI_FilePath : String ;      {--- Parameter 1 }
   GI_ParseMode : String[20];      {--- Parameter 2 }

   G_BufLen : Longint ;
   G_BufPtr : Pointer ;
   G_File   : File ;

   G_DataLen       : Longint ;
   G_DataPAfterEnd : PChar ;

   G_Text     : Text ;
   G_TextLine : String ;

VAR
   G_HelpUP : String[10];

BEGIN
   {===== Help =========================================================}
   G_HelpUP := UpperCase ( ParamStr(1) );
   IF (G_HelpUP = '?'   ) Or (G_HelpUP = '-?'   ) Or (G_HelpUP = '/?'   ) Or
      (G_HelpUP = 'HELP') Or (G_HelpUP = '-HELP') Or (G_HelpUP = '/HELP') Or
      (ParamCount = 0)
   THEN BEGIN
      WriteLn ;
      WriteLn (   '***** ParseADA Help ***********************************************************'   );
      WriteLn (   'Parse an ADA source, in small "tokens"  ( or symbol, comment, ... ).'              );
      WriteLn (   ''                                                                                  );
      WriteLn (   'ParseADA   FilePath   [/OutputOpt]   [>Destination]'                               );
      WriteLn (   ''                                                                                  );
      WriteLn (   '   FilePath    : The file to parse.'                                               );
      WriteLn (   '   OutputOpt   : Default option is  /Verbose'                                      );
      WriteLn (   '                 /Verbose   : Add the "type" of each "token"'                      );
      WriteLn (   '                              ( or symbol, comment, ... ) found by the parser.'    );
      WriteLn (   '                 /Parse     : One "token" ( or symbol, comment, ... ) per line.'   );
      WriteLn (   '                 /NoComment : One "token" per line, but without source comments'   );
      WriteLn (   '                 /Compact   : All "tokens" grouped together, with as less'         );
      WriteLn (   '                              empty spaces as possible  ( line length <= 79 ).'    );
      WriteLn (   '                 /PackLine  : Each line packed as short as possible.'              );
      WriteLn (   '   Destination : Default is screen, to output to a file use usual'                 );
      WriteLn (   '                 "DOS output redirection"  ( CMD  ...  >MyOutput.TXT ).'           );
      WriteLn (   ''                                                                                  );
      WriteLn (   '----- Examples :'                                                                  );
      WriteLn (   'ParseADA   MyProg1.ADB'                                                            );
      WriteLn (   'ParseADA   MyProg1.ADB   /Parse'                                                   );
      WriteLn (   '*******************************************************************************'   );

      HALT ( 0 );
   END;

   {----- CONTROL Parameter 1 : File exists ?  }
   GI_FilePath := ParamStr(1);
   IF not FileExists ( GI_FilePath ) THEN BEGIN
      WriteLn (   'ERROR: '  ,  'File not found  ( Parameter 1 ).'   );
      HALT ( 1 );
   END;

   {----- OPTIONAL : Parameter 2 }
   GI_ParseMode := ParamStr(2);
   G_ParseMode := pmVerbose ;
   IF GI_ParseMode = '/Same'      THEN G_ParseMode := pmSame ;
   IF GI_ParseMode = '/Verbose'   THEN G_ParseMode := pmVerbose ;
   IF GI_ParseMode = '/Parse'     THEN G_ParseMode := pmParse ;
   IF GI_ParseMode = '/NoComment' THEN G_ParseMode := pmNoComment ;
   IF GI_ParseMode = '/Compact'   THEN G_ParseMode := pmCompact ;
   IF GI_ParseMode = '/PackLine'  THEN G_ParseMode := pmPackLine ;

   {----- Prepare buffer }
   {--G_BufLen := 10000 ;--}      {--- KNOWN BUG: Comment just before the end of the small buffer }
   Assign ( G_File , GI_FilePath );
   Reset  ( G_File , 1 );
   G_BufLen := FileSize ( G_File );
   Close ( G_File );
   IF G_BufLen > 65530
   THEN G_BufLen := 65530 ;      {--- KNOWN BUG: Comment just before the end of the big buffer }
   GetMem ( G_BufPtr , G_BufLen );


   Assign ( G_Text , GI_FilePath );
   Reset  ( G_Text );

   G_DataLen       := 0 ;
   G_DataPAfterEnd := G_BufPtr ;

   ProcessBuffer ( G_BufPtr , nil );      {--- Before Process }

   {----- LOOP , Read text file , line by line }
   WHILE not EOF ( G_Text ) DO BEGIN
      ReadLn ( G_Text , G_TextLine );
      G_TextLine := G_TextLine + #13#10 ;
      (*Debug: WriteLn ( G_TextLine ); *)

      IF ( G_DataLen + Length(G_TextLine) ) > G_BufLen
      THEN BEGIN
         {----- PROCESS BUFFER, "buffer size" by "buffer size" }
         ProcessBuffer ( G_BufPtr , PChar(Longint(G_BufPtr)+G_DataLen-1) );

         {----- Reset buffer }
         G_DataLen       := 0 ;
         G_DataPAfterEnd := G_BufPtr ;
      END;

      {----- Add line to buffer }
      Move ( G_TextLine[1] , G_DataPAfterEnd^ , Length(G_TextLine) );
      Inc ( Longint(G_DataPAfterEnd) , Length(G_TextLine) );
      Inc ( G_DataLen                , Length(G_TextLine) );
   END;{while}

   IF G_DataLen > 0 THEN BEGIN
      ProcessBuffer ( G_BufPtr , PChar(Longint(G_BufPtr)+G_DataLen-1) );
   END;
   ProcessBuffer ( nil , nil );      {--- After Process }

   Close ( G_Text );


   {----- Release buffer }
   FreeMem ( G_BufPtr , G_BufLen );
END.

(*   "Bug:comment>BufferSize" + "Limitation:can't use BlockRead(BufferSize)"   *)
