'
'---------------
' Const: Parser Result prXXXXX
'---------------
'
   CONST  prToken             = 1
   CONST  prSymbol            = 2
   CONST  prSymbol2Ch         = 3
   CONST  prQuotedText        = 4
   CONST  prIllegalToken      = 5

   CONST  prLineComment       = 6
   CONST  prComment           = 7
   CONST  prFilling           = 8

   CONST  prEndQuoteMissing   = 9
   CONST  prEndCommentMissing = 10
   CONST  prEndOfBuffer       = 11


   DIM  ParserResultStrC(10)      '--- 11 - 1
      ParserResultStrC(0) = "Token"
      ParserResultStrC(1) = "Symbol"
      ParserResultStrC(2) = "Symbol2Ch"
      ParserResultStrC(3) = "QuotedText"
      ParserResultStrC(4) = "IllegalToken"
      ParserResultStrC(5) = "LineComment"
      ParserResultStrC(6) = "Comment"
      ParserResultStrC(7) = "Filling"
      ParserResultStrC(8) = "EndQuoteMissing"
      ParserResultStrC(9) = "EndCommentMissing"
      ParserResultStrC(10) = "EndOfBuffer"

'
'---------------
' Parser main variables
'---------------
'
   DIM  StrParseMeG
   DIM  PBeginG
   DIM  PAfterEndG

'
'---------------
' _Compact & _PackLine specific variables
'---------------
'
   DIM  TmpBufLineCompactedG
   DIM  PREVprResultG

'
'---------------
' ProcessBuffer const & variables
'---------------
'
   CONST  pmSame      = 0
   CONST  pmVerbose   = 1
   CONST  pmParse     = 2
   CONST  pmNoComment = 3
   CONST  pmCompact   = 4
   CONST  pmPackLine  = 5

   DIM  ParseModeG


   DIM  ParseModeGI

   DIM  Time1G
   DIM  Time2G

   StrParseMeG = TextArea1.Value
   ParseModeGI = OutputOpt.Value

   '----- OPTIONAL : Parameter 2
   ParseModeG = pmVerbose
   IF ParseModeGI = "/Same"      THEN ParseModeG = pmSame
   IF ParseModeGI = "/Verbose"   THEN ParseModeG = pmVerbose
   IF ParseModeGI = "/Parse"     THEN ParseModeG = pmParse
   IF ParseModeGI = "/NoComment" THEN ParseModeG = pmNoComment
   IF ParseModeGI = "/Compact"   THEN ParseModeG = pmCompact
   IF ParseModeGI = "/PackLine"  THEN ParseModeG = pmPackLine

   Time1G = Now
   ProcessBuffer   1 , Null
   ProcessBuffer   1 , Len(StrParseMeG)
   ProcessBuffer   Null , Null
   Time2G = Now
   print "*****  "  ;  ((Time2G-Time1G)*(24*60*60*1000))  ;  "  milliseconds"

'
'------------------------------------------------------------------------------
' This file toolbox
'------------------------------------------------------------------------------
'
'
'---------------
' NEXTxxx: Mini parser for QBASIC language
'---------------
'
'===== NEXTxxx
'
FUNCTION   NEXTxxx   ( BuffPLastI , PBeginIO , PAfterEndO )   'Parser Result const, prXXXXX

                                                      '   <>   <=   >=

   CONST  OneCharSymbolsC   = "+-*/>=<(),:\^;?"       '---
   CONST  CharsEndingTokenC = "+-*/>=<(),:\^;?'"      '---

   DIM  ChL

   PBeginG = PBeginIO
'DEBUG:print "DEBUG.NEXTxxx.1:"  ;  ""
'NEXTxxx = prSymbol2Ch
'EXIT FUNCTION

   '----- Controls : nil, non sense values
   IF IsNull(BuffPLastI) or IsNull(PBeginG) or (BuffPLastI < PBeginG) THEN
      NEXTxxx = prEndOfBuffer
      EXIT FUNCTION
   END IF

   '===== 0. Search first char of the token
   '----- Buffer   :  Other...  CRLF  Other...   TokenBeeingSearched
   '----- Pointers :                      PBeginG^                  ^PAfterEndG
   ChL = Mid$ ( StrParseMeG , PBeginG , 1 )
   WHILE (ChL = " ") or (ChL = Chr(9)) or (ChL = Chr(10)) or (ChL = Chr(13))
      PBeginG = PBeginG + 1
      IF BuffPLastI < PBeginG THEN  NEXTxxx = prEndOfBuffer  :  EXIT FUNCTION  :  END IF
      ChL = Mid$ ( StrParseMeG , PBeginG , 1 )
   WEND
   PAfterEndG = PBeginG

   DO      '--- PATCH  ( 1 / 2 ) , "Not aloud: goto LABEL_Bloc3"

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

   '===== 2. Special two non alpha chars tokens, like   <>   <=   >=

   '----- 2.1. case:   <>
   IF ChL = "<" THEN
      PAfterEndG = PAfterEndG + 1
      IF BuffPLastI < PAfterEndG               THEN  PAfterEndG = PAfterEndG - 1  :  EXIT DO  :  END IF
      IF Mid$(StrParseMeG,PAfterEndG,1) <> ">" THEN
         PAfterEndG = PAfterEndG - 1
      ELSE
         PAfterEndG = PAfterEndG + 1
         NEXTxxx     = prSymbol2Ch
         EXIT FUNCTION
      END IF
   END IF

   '----- 2.2. case:   <=
   IF ChL = "<" THEN
      PAfterEndG = PAfterEndG + 1
      IF BuffPLastI < PAfterEndG               THEN  PAfterEndG = PAfterEndG - 1  :  EXIT DO  :  END IF
      IF Mid$(StrParseMeG,PAfterEndG,1) <> "=" THEN
         PAfterEndG = PAfterEndG - 1
      ELSE
         PAfterEndG = PAfterEndG + 1
         NEXTxxx     = prSymbol2Ch
         EXIT FUNCTION
      END IF
   END IF

   '----- 2.3. case:   >=
   IF ChL = ">" THEN
      PAfterEndG = PAfterEndG + 1
      IF BuffPLastI < PAfterEndG               THEN  PAfterEndG = PAfterEndG - 1  :  EXIT DO  :  END IF
      IF Mid$(StrParseMeG,PAfterEndG,1) <> "=" THEN
         PAfterEndG = PAfterEndG - 1
      ELSE
         PAfterEndG = PAfterEndG + 1
         NEXTxxx     = prSymbol2Ch
         EXIT FUNCTION
      END IF
   END IF

   LOOP UNTIL TRUE      '--- PATCH  ( 2 / 2 ) , "Not aloud: goto LABEL_Bloc3"

   '===== 3. Other cases
 '--LABEL_Bloc3:--
   '----- 3.1. case:   '... comment
   IF ChL = "'" THEN
      DO
         PAfterEndG = PAfterEndG + 1
         IF BuffPLastI < PAfterEndG THEN EXIT DO
         ChL = Mid$ ( StrParseMeG , PAfterEndG , 1 )
      LOOP UNTIL (ChL = Chr(10)) or (ChL = Chr(13))
      NEXTxxx = prLineComment
      EXIT FUNCTION
   ELSE

   '----- 3.2. case:   one char symbol,  like + - * < ; etc
   IF InStr$ ( OneCharSymbolsC , ChL ) >= 1 THEN
      PAfterEndG = PAfterEndG + 1
      NEXTxxx     = prSymbol
      EXIT FUNCTION
   ELSE

   '----- 3.3. case:   quote "
   IF ChL = """" THEN
      '----- Buffer  :  Other...  CRLF  Other...   " Quotes beeing processed "
      '----- Pointers:                      PBeginG^                          ^PAfterEndG
      DO   ' search end quote, skipping double quotes
         PAfterEndG = PAfterEndG + 1
         IF BuffPLastI < PAfterEndG THEN  NEXTxxx = prEndQuoteMissing  :  EXIT FUNCTION  :  END IF
         ChL = Mid$ ( StrParseMeG , PAfterEndG , 1 )
         IF (ChL = Chr(10)) or (ChL = Chr(13)) THEN  NEXTxxx = prEndQuoteMissing  :  EXIT FUNCTION  :  END IF
         IF ChL = """" THEN
            PAfterEndG = PAfterEndG + 1
            IF BuffPLastI < PAfterEndG THEN  NEXTxxx = prQuotedText  :  EXIT FUNCTION  :  END IF
            NEXTxxx = prQuotedText
            EXIT FUNCTION
         END IF
      LOOP UNTIL False
   ELSE

   '----- 3.5. case:   normal token
   '--BEGIN--
      '----- Buffer   :  Other...  CRLF  Other...   TokenBeeingSearched
      '----- Pointers :                      PBeginG^                  ^PAfterEndG
      DO
         PAfterEndG = PAfterEndG + 1
         IF BuffPLastI < PAfterEndG THEN EXIT DO
         ChL = Mid$ ( StrParseMeG , PAfterEndG , 1 )
         IF InStr$ ( CharsEndingTokenC , ChL ) >= 1 THEN EXIT DO
      LOOP UNTIL (ChL = " ") or (ChL = Chr(9)) or (ChL = Chr(10)) or (ChL = Chr(13))
      NEXTxxx = prToken
      EXIT FUNCTION
   '--END--
   END IF
   END IF
   END IF
END FUNCTION

'
'------------------------------------------------------------------------------
' This file toolbox  ( bis )
'------------------------------------------------------------------------------
'
'
'---------------
' ProcessBufferSame
' ProcessBufferVerbose
' ProcessBufferParse
' ProcessBufferNoComment
' ProcessBufferCompact
' ProcessBufferPackLine
'---------------
'
'===== ProcessBufferSame
'
SUB   ProcessBufferSame   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- LOOP 2.1 , OUTPUT : Filling
      WHILE (ChL = " ") or (ChL = Chr(9)) or (ChL = Chr(10)) or (ChL = Chr(13))
         PRINT ChL  ;
         PtrL = PtrL + 1
         IF BufLastI < PtrL THEN EXIT SUB
         ChL = Mid$ ( StrParseMeG , PtrL , 1 )
      WEND
'DEBUG:print "DEBUG.1:"  ;  prResultL  ;  ":"  ;  PtrL  ;  "-->"  ;  PAfterEndL
'EXIT SUB

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF    (prResultL = prToken) or (prResultL = prSymbol) or (prResultL = prSymbol2Ch) or (prResultL = prQuotedText) or (prResultL = prIllegalToken)  _
         or (prResultL = prLineComment) or (prResultL = prComment)  _
      THEN
         '----- LOOP 2. , OUTPUT : Token, Symbol,... as found
         WHILE PtrL < PAfterEndL
            ChL = Mid$ ( StrParseMeG , PtrL , 1 )
            print ChL   ;
            PtrL = PtrL + 1
         WEND
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'===== ProcessBufferVerbose
'
SUB   ProcessBufferVerbose   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  TmpStrL

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF TRUE THEN
         '----- LOOP 2. , OUTPUT : Token, Symbol,... as found
         WHILE PtrL < PAfterEndL
            ChL = Mid$ ( StrParseMeG , PtrL , 1 )
            print ChL   ;
            PtrL = PtrL + 1
         WEND

         '----- OUTPUT : Token type
         TmpStrL = ParserResultStrC(prResultL-1)
         WHILE Len(TmpStrL) < 11  :  TmpStrL = " "  +  TmpStrL  :  WEND
         IF Len(TmpStrL) > 11 THEN TmpStrL = Mid$ ( TmpStrL , 1 , 11 )
         print "   ' "  ;  TmpStrL   ;

         print
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'===== ProcessBufferParse
'
SUB   ProcessBufferParse   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF    (prResultL = prToken) or (prResultL = prSymbol) or (prResultL = prSymbol2Ch) or (prResultL = prQuotedText) or (prResultL = prIllegalToken)  _
         or (prResultL = prLineComment) or (prResultL = prComment)  _
      THEN
         '----- LOOP 2. , OUTPUT : Token, Symbol,... as found
         WHILE PtrL < PAfterEndL
            ChL = Mid$ ( StrParseMeG , PtrL , 1 )
            print ChL   ;
            PtrL = PtrL + 1
         WEND

         print
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'===== ProcessBufferNoComment
'
SUB   ProcessBufferNoComment   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF (prResultL = prToken) or (prResultL = prSymbol) or (prResultL = prSymbol2Ch) or (prResultL = prQuotedText) or (prResultL = prIllegalToken)  _
      THEN
         '----- LOOP 2. , OUTPUT : Token, Symbol,... as found
         WHILE PtrL < PAfterEndL
            ChL = Mid$ ( StrParseMeG , PtrL , 1 )
            print ChL   ;
            PtrL = PtrL + 1
         WEND

         print
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'===== ProcessBufferCompact
'
SUB   ProcessBufferCompact   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  String0L
   DIM  TokenLenL
   DIM  String1L

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      IF IsNull(BufFirstI) = False THEN   ' Before Process
         TmpBufLineCompactedG = ""
         PREVprResultG        = prFilling
      ELSE   ' After Process
         IF TmpBufLineCompactedG <> "" THEN
            print TmpBufLineCompactedG
         END IF
      END IF
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF (prResultL = prToken) or (prResultL = prSymbol) or (prResultL = prSymbol2Ch) or (prResultL = prQuotedText) or (prResultL = prIllegalToken)  _
      THEN
         '----- Put a space between 2 tokens ?
         IF (PREVprResultG = prToken) and (prResultL = prToken) THEN
            String0L = " "
         ELSE
            String0L = ""
         END IF

         '----- CONTROL : Current token too long ?
         TokenLenL = PAfterEndL - PtrL
         IF TokenLenL > 126 THEN
            '----- OUTPUT : Previous temp buffer
            print TmpBufLineCompactedG
            TmpBufLineCompactedG = ""

            '----- OUTPUT : Current token
            String1L = Mid$ ( StrParseMeG , PtrL , 126 )
            print String1L

            '----- OUTPUT : Error message
            print "ERROR: "  ;  "Token too long."
            EXIT SUB '--throw ( 1 );--
         END IF

         '----- Copy current token ==> TmpString
         String1L = Mid$ ( StrParseMeG , PtrL , TokenLenL )

         '----- "Temp line buffer" would be full ?
         IF ( Len(TmpBufLineCompactedG) + Len(String0L) + Len(String1L) ) > 79 THEN
            '----- OUTPUT : Previous temp buffer
            print TmpBufLineCompactedG
            TmpBufLineCompactedG = ""
            String0L              = ""   ' Token sent to next line
         END IF

         '----- Temp line buffer : add "token"
         TmpBufLineCompactedG = TmpBufLineCompactedG  +  String0L  +  String1L

         PREVprResultG = prResultL
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'===== ProcessBufferPackLine
'
SUB   ProcessBufferPackLine   ( BufFirstI , BufLastI )
   DIM  PtrL
   DIM  PAfterEndL
   DIM  prResultL

   DIM  NewLineQL

   DIM  String0L
   DIM  TokenLenL
   DIM  String1L

   DIM  ChL

   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      IF IsNull(BufFirstI) = False THEN   ' Before Process
         TmpBufLineCompactedG = ""
         PREVprResultG        = prFilling
      ELSE   ' After Process
         IF TmpBufLineCompactedG <> "" THEN
            print TmpBufLineCompactedG
         END IF
      END IF
      EXIT SUB
   END IF

   PAfterEndL = BufFirstI

   '----- LOOP 1 , Call parser
   DO

      PtrL = PAfterEndL
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )

      '----- LOOP 2.1 , Skip filling
      DO WHILE (ChL = " ") or (ChL = Chr(9))
         PtrL = PtrL + 1
         IF BufLastI < PtrL THEN EXIT DO
         ChL = Mid$ ( StrParseMeG , PtrL , 1 )
      LOOP

      '----- Check NewLine
      IF ChL = Chr(10) THEN
         PtrL = PtrL + 1
         NewLineQL = TRUE
      ELSE
         IF ChL = Chr(13) THEN
            NewLineQL = TRUE
            PtrL = PtrL + 1
            IF PtrL <= BufLastI THEN
               ChL = Mid$ ( StrParseMeG , PtrL , 1 )
               IF ChL = Chr(10) THEN
                  PtrL = PtrL + 1
               END IF
            END IF
         ELSE
            NewLineQL = False
         END IF
      END IF
      IF NewLineQL = TRUE THEN
         '----- OUTPUT : temp line buffer
         IF TmpBufLineCompactedG <> "" THEN
            print TmpBufLineCompactedG
            TmpBufLineCompactedG = ""
            PREVprResultG        = prFilling
         END IF
      END IF
      IF BufLastI < PtrL THEN EXIT DO

      '----- PARSER , Get "next token"
      prResultL = NEXTxxx ( BufLastI , PtrL , PAfterEndL )  :  PtrL=PBeginG  :  PAfterEndL=PAfterEndG

      IF (prResultL = prToken) or (prResultL = prSymbol) or (prResultL = prSymbol2Ch) or (prResultL = prQuotedText) or (prResultL = prIllegalToken)  _
      THEN
         '----- Put a space between 2 tokens ?
         IF (PREVprResultG = prToken) and (prResultL = prToken) THEN
            String0L = " "
         ELSE
            String0L = ""
         END IF

         '----- CONTROL : Current token too long ?
         TokenLenL = PAfterEndL - PtrL
         IF TokenLenL > 126 THEN
            '----- OUTPUT : Previous temp buffer
            print TmpBufLineCompactedG
            TmpBufLineCompactedG = ""

            '----- OUTPUT : Current token
            String1L = Mid$ ( StrParseMeG , PtrL , 126 )
            print String1L

            '----- OUTPUT : Error message
            print "ERROR: "  ;  "Token too long."
            EXIT SUB '--throw ( 1 );--
         END IF

         '----- Copy current token ==> TmpString
         String1L = Mid$ ( StrParseMeG , PtrL , TokenLenL )

         '----- "Temp line buffer" would be full ?
         IF ( Len(TmpBufLineCompactedG) + Len(String0L) + Len(String1L) ) > 126 THEN
            '----- OUTPUT : Previous temp buffer
            print TmpBufLineCompactedG
            TmpBufLineCompactedG = ""

            '----- OUTPUT : Current token
            print String1L

            '----- OUTPUT : Error message
            print "ERROR: "  ;  "Line too long."
            EXIT SUB '--throw ( 1 );--
         END IF

         '----- Temp line buffer : add "token"
         TmpBufLineCompactedG = TmpBufLineCompactedG  +  String0L  +  String1L

         PREVprResultG = prResultL
      END IF

   LOOP UNTIL PtrL > BufLastI
END SUB

'
'------------------------------------------------------------------------------
' This file routines
'------------------------------------------------------------------------------
'
'
'---------------
' ProcessBuffer
'---------------
'
'===== ProcessBuffer
'
SUB   ProcessBuffer   ( BufFirstI , BufLastI )
'--   SELECT CASE ParseModeG
'--      CASE pmSame       :  ProcessBufferSame        BufFirstI , BufLastI
'--      CASE pmVerbose    :  ProcessBufferVerbose     BufFirstI , BufLastI
'--      CASE pmParse      :  ProcessBufferParse       BufFirstI , BufLastI
'--      CASE pmNoComment  :  ProcessBufferNoComment   BufFirstI , BufLastI
'--      CASE pmCompact    :  ProcessBufferCompact     BufFirstI , BufLastI
'--      CASE pmPackLine   :  ProcessBufferPackLine    BufFirstI , BufLastI
'--   END SELECT

'--
   IF IsNull(BufLastI) or IsNull(BufFirstI) THEN
      IF IsNull(BufFirstI) = False THEN
         print "***** Begin"      '--- Before Process
      ELSE
         print "***** End"        '--- After Process
      END IF
      EXIT SUB
   END IF
'--   
   '----- Input ==> Output, char by char
   PtrL = BufFirstI
   WHILE PtrL <= BufLastI
      ChL = Mid$ ( StrParseMeG , PtrL , 1 )
      print ChL   ;
      PtrL = PtrL + 1
   WEND
'--
END SUB
