'===========================================================================
' Subject: CREATES LIST OF DECLARATIONS      Date: 06-02-98 (14:32)       
' Author:  Alexander Podkolzin               Code: PB                     
' Origin:  app@nw.sbank.e-burg.su          Packet: PB.ABC
'===========================================================================
'---------------------------------------------------------------------------
' Author  : Alexander Podkolzin
' Status  : Freeware
'
' This programm makes procedures declaration list (PB3+).
' Features:
' Does not declares libs procedures.
' Does not supports nested "$include" files.
' Does not changes initial names.
'
' Thanks to Scott Tucker, author of "PARSER" procedure, its very handy here!
'
' Hope this program will do some work for you... Enjoy!
'---------------------------------------------------------------------------
 $COMPILE EXE
 $DIM ALL
 $CPU 80386      '!!! N.B. !!!         'Check your CPU
 $LIB ALL OFF
 $STRING 32
 $SOUND 1
 $DEBUG MAP OFF
 $FLOAT NPX      '!!! N.B. !!!         'Check if you have it
 $DYNAMIC
 $OPTIMIZE SIZE
'---------------------------------------------------------------------------
 %FALSE = 0
 %TRUE = -1
 %TabPos = 14
'---------------------------------------------------------------------------
'
'That declaration list is made by this program:
'
 Declare Function fDeleteWord( _
             Byval Src As String, _    ' Begins from %TabPos = 14
             Byval Search As String _
             ) As String
 Declare Function fInstrAnyCase( _
             Byval Src As String, _
             Byval Search As String _
             ) As Integer
 Declare Function fIsQuoted( _
             Byval ss As String, _
             Byval n As Integer _
             ) As Integer
 Declare Function fIsWord( _
             Byval s As String, _
             Byval Ns As Integer _
             ) As Integer
 Declare Function fRinstr( _
             Byval Main As String, _
             Byval Search As String _
             ) As Integer
 Declare Function fStripComment( _
             Byval St As String _
             ) As String
 Declare Function f_Normal( _
             Byval ss As String _
             ) As String
 Declare Sub AppendItTo( _
             Byval Dest As Integer, _
             Byval FileName As String _
             )
 Declare Sub Indicator( _
              _
             )
 Declare Sub Parser( _
             Byval Text As String, _
             Byval Delimiter As String, _
             Parms() As String, _
             Byval Flag As Integer _
             )
'
' End of declaration list
'---------------------------------------------------------------------------
 Dim Skip As Integer
 Dim s As String
 Dim sa As String
 Dim sb As String
 Dim sc As String
 Dim DestName As String
 Dim IncName As String
 Dim SrcName As String
 Dim TempName As String
 Dim Src As Integer
 Dim Dest As Integer
 Dim Sind As String
 Dim Zind As Integer
 Dim i As Integer
 Dim k As Integer
 Dim l As Integer
 Dim m As Integer
 Dim n As Integer
 Dim More As Integer
 Dim DefaultType As String
 Dim Nvars As Integer
 Dim Work(0) As Shared String
 Dim Pnames(200) As Shared String      'Procedures names
 Dim ip As Integer
'---------------------------------------------------------------------------
 DefaultType = " As Integer"           'Change it if you need...

 SrcName = Command$

 If SrcName = "" Then
    Print "Using: DECL.EXE <SrcName>"
    End
 End If

 If Dir$(SrcName) = "" Then
    Print SrcName; " - not found"
    End
 End If

 i = Instr(SrcName, ".")
 If i Then
    DestName = Left$(SrcName, i) + "DCL"
 Else
    DestName = SrcName + ".DCL"
 End If

 TempName = "$_DECL_$.TMP"
'---------------------------------------------------------------------------
 Cls
 Print "  Loading file(s)..."
 Src = Freefile
 Open SrcName For Input As Src
 Dest = Freefile
 Open TempName For Output As Dest
 While Not Eof(Src)

    Line Input #Src, s
    s = f_Normal(fStripComment(s))

    If Ltrim$(s) = "" Then Iterate
    If Left$(s, 1) = "!" Or Ucase$(Left$(s, 4)) = "ASM " Then Iterate
'
'   To combine main and all `include` files:
'
    If Ucase$(Left$(s, 8)) = "$INCLUDE" Then
       IncName = Mid$(s, 10)
       IncName = Remove$(IncName, Any Chr$(34, 32))
       If Dir$(IncName) = "" Then
         Print IncName; " - not found"
         Iterate
       End If
       AppendItTo Dest, IncName
    Else
       Print #Dest, s
    End If

    Indicator                          'Shows process...

 Wend
 Close Src
 Close Dest

 ip = 1
 Src = Freefile
 Open TempName For Input As Src
 Print "  Making procedures declaration list..."
 sb = ""
 While Not Eof(Src)

    Line Input #Src, s

    s = fStripComment(s)

    If s = "" Then Iterate

    If Right$(s, 1) = "_" Then
       sb = sb + Rtrim$(Left$(s, Len(s) - 1))
       More = %TRUE
       Iterate
    Else
       If sb <> "" Then
          s = sb + s
          sb = ""
          More = %FALSE
       End If
    End If

    sa = f_Normal(s)
'
'   Below two `If`s may be removed, as are not precise conditions
'   (string may contain `$IF %DEBUG` or something else).
'
    If Ucase$(Left$(sa, 5)) = "$IF 0" Then
       Skip = %TRUE
    End If

    If Ucase$(Left$(sa, 5)) = "$ELSE" Or Ucase$(Left$(sa, 6)) = "$ENDIF" Then
       Skip = %FALSE
    End If

    If Skip Then Iterate

    If Ucase$(Left$(sa, 4)) = "SUB " Or Ucase$(Left$(sa, 9)) = "FUNCTION " _
       And Instr(Left$(sa, 11), "=") = 0 Then

       Redim Work(0)
       Parser sa, ":", Work(), 2
       If Ubound(Work()) > 0 Then
          Pnames(ip) = Work(1)
       Else
          Pnames(ip) = sa
       End If
       Incr ip
    End If
    Indicator

 Wend
 Decr ip
 Close Src
 Print String$(79, 45)

 For k = 1 To ip

    If Ucase$(Left$(Pnames(k), 4)) = "SUB " Or _
       Ucase$(Left$(Pnames(k), 9)) = "FUNCTION " Then

       Pnames(k) = fDeleteWord(Pnames(k), "LOCAL")
       Pnames(k) = fDeleteWord(Pnames(k), "SHARED")
       Pnames(k) = fDeleteWord(Pnames(k), "PRIVATE")
       Pnames(k) = fDeleteWord(Pnames(k), "PUBLIC")
       Pnames(k) = fDeleteWord(Pnames(k), "STATIC")

    End If

    If Instr(Pnames(k), Any "?&#@$%!#") = 0 And _
       fInstrAnyCase(Pnames(k), " AS ") <> 0 Then

       Pnames(k) = fDeleteWord(Pnames(k), "PUBLIC")
       Pnames(k) = fDeleteWord(Pnames(k), "STATIC")
       Iterate For
    End If

    If Instr(Pnames(k), "(") = 0 Then
       Pnames(k) = Rtrim$(Pnames(k)) + "()"
    End If

    While Instr(Pnames(k), " (") > 0 _
       Or Instr(Pnames(k), " ,") > 0 _
       Or Instr(Pnames(k), "( ") > 0 _
       Or Instr(Pnames(k), ", ") > 0

       Replace " (" With "(" In Pnames(k)
       Replace " ," With "," In Pnames(k)
       Replace "( " With "(" In Pnames(k)
       Replace ", " With "," In Pnames(k)

    Wend

    m = Instr(Pnames(k), "(")
    n = fRinstr(Pnames(k), ")")
    If n - m > 1 Then

       Pnames(k) = Rtrim$(Left$(Pnames(k), m - 1)) _
                  + Ltrim$(Rtrim$(Mid$(Pnames(k), m, n - m))) _
                  + ")"
    End If

    If fInstrAnyCase(Pnames(k), "FUNCTION ") Then

       sa = Mid$(Pnames(k), m - 1, 1)
       sb = Mid$(Pnames(k), m - 2, 2)
       sc = Mid$(Pnames(k), m - 3, 3)
       If sc = "???" Then
          s = " As Dword"
          l = 3
       Elseif sb = "??" Then
          s = " As Word"
          l = 2
       Elseif sb = "&&" Then
          s = " As Quad"
          l = 2
       Elseif sb = "##" Then
          s = " As Ext"
          l = 2
       Elseif sb = "@@" Then
          s = " As Bcd"
          l = 2
       Elseif sb = "$$" Then
          s = " As Flex"
          l = 2
       Elseif sa = "?" Then
          s = " As Byte"
          l = 1
       Elseif sa = "%" Then
          s = " As Integer"
          l = 1
       Elseif sa = "&" Then
          s = " As Long"
          l = 1
       Elseif sa = "!" Then
          s = " As Single"
          l = 1
       Elseif sa = "#" Then
          s = " As Double"
          l = 1
       Elseif sa = "@" Then
          s = " As Ptr"                'PTR or FIX ???
          l = 1
       Elseif sa = "$" Then
          s = " As String"
          l = 1
       Else
          s = DefaultType
          l = 0
       End If
       Pnames(k) = Left$(Pnames(k), m - l - 1) _
       + Mid$(Pnames(k), m, n - m + 1) _
       + s
    End If
'
'   Temporary replacement:
'
    Replace "()" With "[]" In Pnames(k)

    m = Instr(Pnames(k), "(") + 1
    n = Instr(Pnames(k), ")")

    If m < n Then
       sa = Mid$(Pnames(k), m, n - m + 1)
       Redim Work(0)
       Parser sa, ",)", Work(), 2
       Nvars = Ubound(Work()) - 1
       For i = 1 To Nvars

          If Instr(Work(i), Any "?&#@$%!#") = 0 And _
             fInstrAnyCase(Work(i), " AS ") = 0 Then
             Work(i) = Work(i) + DefaultType
          End If

          Replace "???" With " As Dword"   In Work(i)
          Replace  "??" With " As Word"    In Work(i)
          Replace  "&&" With " As Quad"    In Work(i)
          Replace  "##" With " As Ext"     In Work(i)
          Replace  "@@" With " As Bcd"     In Work(i)
          Replace  "$$" With " As Flex"    In Work(i)
          Replace   "?" With " As Byte"    In Work(i)
          Replace   "%" With " As Integer" In Work(i)
          Replace   "&" With " As Long"    In Work(i)
          Replace   "!" With " As Single"  In Work(i)
          Replace   "#" With " As Double"  In Work(i)
          Replace   "@" With " As Ptr"     In Work(i)
          Replace   "$" With " As String"  In Work(i)
'
'         Restore initial form:
'
          If Instr(Work(i), "[]") Then
             Replace " As" With "() As" In Work(i)
             Replace "[]" With "" In Work(i)
          End If

       Next
       sa = ""
       For i = 1 To Nvars
          sa = sa + Work(i) + ","
       Next
       sa = Rtrim$(sa, ",")

    End If

    Replace "[]" With "()" In Pnames(k)

    If n > m Then
       Pnames(k) = Left$(Pnames(k), m - 1) _
       + sa _
       + Mid$(Pnames(k), n)
    End If

 Next

 Array Sort Pnames() For ip + 1

 Dest = Freefile
 Open DestName For Output As Dest
 For i = 1 To ip

    Pnames(i) = fDeleteWord(Pnames(i), "PUBLIC")
    Pnames(i) = fDeleteWord(Pnames(i), "STATIC")
    Pnames(i) = " Declare " + Pnames(i)

    If Instr(Pnames(i), ",") > 0 Then
       Replace "()" With "[]" In Pnames(i)
       Replace ")" With "," In Pnames(i)
       Redim Work(0)
       Parser Pnames(i), ",", Work(), 2
       n = Ubound(Work())
       Replace "[]" With "()" In Work(1)
       Replace "," With ")" In Work(1)
       Work(1) = Work(1) + ", _"
       For k = 2 To n - 1
          Replace "[]" With "()" In Work(k)
          Work(k) = Space$(%TabPos - 1) + Ltrim$(Work(k)) + ", _"
       Next
       Replace "}" With ")" In Work(n)
       Replace "," With ")" In Work(n)
       Work(n) = Space$(%TabPos - 1) + Ltrim$(Work(n))
       If n > 1 Then
          Replace ", _" With ")" In Work(n - 1)
          Work(n - 1) = Work(n - 1) + " " + Ltrim$(Work(n))
          Work(n) = ""
          Decr n
       End If
       For k = 1 To n

          If k = 1 Then
             l = Instr(Work(k), "(")
             Print #Dest, Left$(Work(k), l); " _"
             Print #Dest, Tab(%TabPos) Ltrim$(Mid$(Work(k), l + 1))
             Iterate For
          End If

          If k = n Then
             l = fRinstr(Work(k), ")")
             Print #Dest, Left$(Work(k), l - 1); " _"
             Print #Dest, Tab(%TabPos) Mid$(Work(k), l)
             Iterate For
          End If

          Print #Dest, Work(k)

       Next
    Else
       k = Instr(Pnames(i), "(")
       l = fRinstr(Pnames(i), ")")
       Print #Dest, Left$(Pnames(i), k); " _"
       Print #Dest, Tab(%TabPos) Ltrim$(Mid$(Pnames(i), k + 1, l - k - 1)); " _"
       Print #Dest, Tab(%TabPos) Ltrim$(Mid$(Pnames(i), l))
'       Print #Dest, Pnames(i)
    End If

 Next
 Close Dest
 Kill TempName

 Print "  Destination file = "; DestName
 Print "  Thank you for using this program!"
 End
'---------------------------------------------------------------------------
'Returns string with deleted Search from Src. Case non-sensitive!
 Function fDeleteWord(Byval Src As String, Byval Search As String) As String

    Dim p As Integer

    p = fInstrAnyCase(Src, Search)
    If p > 0 And fIsWord(Src, p) Then
       Function = Left$(Src, p - 1) + Mid$(Src, p + Len(Search))
    Else
       Function = Src
    End If

 End Function
'---------------------------------------------------------------------------
 Function fInstrAnyCase(Byval Src As String, Byval Search As String) As Integer

    Dim csr As String
    Dim cse As String

    csr = Ucase$(Src)
    cse = Ucase$(Search)

    Function = Instr(csr, cse)

 End Function
'---------------------------------------------------------------------------
'Checks whether n-th simbol is quoted
 Function fIsQuoted(Byval ss As String, Byval n As Integer) As Integer

    Function = ((Tally(Left$(ss, n - 1), Chr$(34)) Mod 2) <> 0) And _
               ((Tally(Right$(ss, n + 1), Chr$(34)) Mod 2) <> 0)
 End Function
'---------------------------------------------------------------------------
'Returns TRUE if chunk at 'Ns' position of 's' is whole word
 Function fIsWord(Byval s As String, Byval Ns As Integer) As Integer

    Dim a As Integer
    Dim b As Integer

    b = (Instr(Ns, s, " ") > 0)

    If Ns = 1 Then
       a = %TRUE
    Else
       a = (Mid$(s, Ns - 1, 1) = " ")
    End If

    Function = a And b

 End Function
'---------------------------------------------------------------------------
'Revers "Instr". Case sensitive. It`s slow, but we do not need speed here...
 Function fRinstr(Byval Main As String, Byval Search As String) As Integer

    Dim i As Integer

    For i = Len(Main) - Len(Search) + 1 To 1 Step - 1
       If Mid$(Main, i, Len(Search)) = Search Then
          Function = i
          Exit Function
       End If
    Next

    Function = 0

 End Function
'---------------------------------------------------------------------------
 Function fStripComment(Byval St As String) As String

    Dim k As Integer
    Dim s As String

    s = Ltrim$(St)
    If Ascii(s) = 39 Or s = "" Then
       Function = ""
       Exit Function
    End If

    Function = Rtrim$(s)
    k = Instr(St, "'")
    If k Then
       If Not fIsQuoted(St, k) Then
          Function = Rtrim$(Left$(St, k - 1))
       End If
    End If

 End Function
'---------------------------------------------------------------------------
' This function "normalizes" string. Example:
' Initial string = "aaa   a aaa      aaaaa"
' Result string  = "aaa a aaa aaaaa "
 Function f_Normal(Byval ss As String) As String

    Dim z As String

    z = Ltrim$(Rtrim$(ss))
    While Instr(z, "  ")
       Replace "  " With " " In z
    Wend
    Function = z + " "

 End Function
'---------------------------------------------------------------------------
'
'Author:  Scott Tucker
'
 Sub Parser(Byval Text As String, Byval Delimiter As String, Parms() As String, Byval Flag As Integer)
'
'   This procedure parses text based on a given set of delimiters.
'   The delimiter can either separate the items in the string, or
'   it can precede items in the string. The resulting parsed items
'   are returned in the array PARMS$().
'
'                      Parameter Descriptions
'                      ----------------------
'Text$      = This is the string of text containing the delimiters to
'             parse.
'Delimiters$= This is the list of delimiters used to parse the string.
'             These delimiters can be any single string item, or a
'             multiple list of items. Examples: "/" or "/\-"
'Parms$()   = The array that contains each item parsed out of the string.
'             This array is redimensioned (from 1) to hold the proper
'             number of parsed items. It should initially be Dim'ed to
'             Parms$(0) before being passed into this procedure. If no
'             delimiters are found in the string, the array will have a
'             dim'ed index of (0) and a null value is returned
'             in the array.
'Flag%      = A flag indicating whether the delimiters separate the
'             string, or precede delimited items.
'             1 = Precede      2 = Separate
'
'             The difference is defined as follows:
'   Type 1    A type 1 delimiter means that you are only interested
'             in the text that follows a delimiter. For example, as in a
'             command line string, you may have a string passed into your
'             Program that looks like Text$=" /n /o /d". The parser would
'             return 3 items in the array Parms$(1)="n", (2)="o", (3)="d".
'             All text up to the first delimiter is ignored.
'
'   Type 2    A type 2 delimiter means that text is separated by the
'             delimiter, an all values on both sides of the delimiters
'             are returned. For example: If you have a string that is to
'             be broken apart based on where a Chr$(13) char is inserted,
'             may look like this: Text$="This is"+Chr$(13)+"a sample."
'             The parser would return 2 items in the array.
'             Parms$(1)="This is "   and    Parms$(2)="a sample."
'
'   Given these examples, it should be very easy to create other
'   types of delimiters. For example, it might be desirable to
'   have a delimiter type that is at the end of a string section.
'   This would be the opposite of a Type 1, such that any text
'   after the last delimiter would be ignored. Example:
'
'   Text$ = "This is| a sample| text line."
'   Call Parser$(Text$, "|", Parms$(), 3)   ' type 3
'   This would return 2 items; Parms$(1)="This is", (2)="a sample"
'---------------------------------------------------------------------------

    Dim L As Local Integer
    Dim T As Local Integer
    Dim C As Local Integer

    C = 0                              'item counter

    Select Case Flag
    Case 1                             'delimiter precedes items being returned
'      Example  Del="/"  String="/m /no /yes"
'      returns 3 items

       T = Tally(Text, Any Delimiter)  'number of delimiters found

       If T = 0 Then                   'no delimiters
          Redim Parms(0)               'erase array values
          Exit Select                  'exit sub
       End If

       Redim Parms(1: T)               'create array to hold items

       Do
          Incr C                       'increment counter
          L = Instr(Text, Any Delimiter)'pointer for first delimiter
          Text = Right$(Text, Len(Text) - L)'ignore all up to first delim
'                                       since the delimiter precedes.

          L = Instr(Text, Any Delimiter)'pointer for next delimiter

          If L <> 0 Then
             Parms(C) = Left$(Text, L - 1)'get all up to next delim.
          Else
             Parms(C) = Text           'get all remaining
          End If

          Text = Right$(Text, Len(Text) - Len(Parms(C)))
       Loop While Len(Text)

    Case 2                             'delimiter separates items being returned
'      Example  Del=Chr(13)  String="This is"+Chr(13)+" a test".
'      returns 2 items

       T = Tally(Text, Any Delimiter)  'number of delimiters found

       If T = 0 Then                   'no delimiters
          Redim Parms(0)               'erase array values
          Exit Select                  'exit sub
       End If

       Redim Parms(1: T + 1)           'create array to hold items

       Do
          Incr C                       'increment counter
          L = Instr(Text, Any Delimiter)'pointer for delimiter

          If L <> 0 Then
             Parms(C) = Left$(Text, L - 1)'get all up to delimiter
             Text = Right$(Text, Len(Text) - Len(Parms(C)) - 1)
          Else
             Parms(C) = Text           'get all remaining
             Text = ""
          End If
       Loop While Len(Text)

    Case Else                          'some other flag

       Redim Parms(1)
       Parms(1) = Text                 'Bad flag

    End Select

 End Sub
'---------------------------------------------------------------------------
'Shows process...
 Sub Indicator()

    Dim OldX As Integer
    Dim OldY As Integer
    Dim Sind As String
    Dim Zind As Static Integer

    Sind = "-\|/"

    OldX = Pos(0)
    OldY = Csrlin
    If Zind = 0 Or Zind > Len(Sind) Then
       Zind = 1
    End If
    Locate Csrlin, 1
    Print Mid$(Sind, Zind, 1);
    Incr Zind
    Locate OldY, OldX

 End Sub
'---------------------------------------------------------------------------
 Sub AppendItTo(Byval Dest As Integer, Byval FileName As String)

    Dim Src As Integer
    Dim s As String

    Src = Freefile
    Open FileName For Input As Src
    While Not(Eof(Src))
       Line Input #Src, s
       s = f_Normal(fStripComment(s))
       If Ltrim$(s) = "" Then Iterate
       If Left$(s, 1) = "!" Or Ucase$(Left$(s, 4)) = "ASM " Then Iterate
       Print #Dest, s
       Indicator
    Wend
    Close Src
    Exit Sub
    s = "Copyright 1998 Alexander Podkolzin"

 End Sub
'----------------------------< END OF FILE >--------------------------------