Fast Build Procedure

Category: Source Code Analysis

Date: 03-28-2012

Return to Index


 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
Global hDlg As Dword
 
Function PBMain() As Long
   Local Style&
   Style& = %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
      Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop
 
   Dialog New Pixels, 0, "Test Code",300,300,400,400, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, 100,"Slow", 30,10,100,20
   Control Add Button, hDlg, 101,"Fast", 150,10,100,20
   Control Add Button, hDlg, 102,"Fastest", 270,10,100,20
   Control Add TextBox, hDlg, 150, Repeat$(10,SampleCode), 20,40,350,350, Style&
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local i, iStart As Long, temp$
   Select Case Cb.Msg
      Case %WM_Command
         Select Case Cb.Ctl
            Case 100
               iStart = GetTickCount
               For i = 0 To 1000
                  Control Get Text hDlg, 150 To temp$
                  slowBuildProcedureList(temp$)
               Next i
               ? Format$((GetTickCount - iStart)/1000,3) & " seconds"
            Case 101
               iStart = GetTickCount
               For i = 0 To 1000
                  Control Get Text hDlg, 150 To temp$
                  fastBuildProcedureList(temp$)
               Next i
               ? Format$((GetTickCount - iStart)/1000,3) & " seconds"
            Case 102
               iStart = GetTickCount
               For i = 0 To 1000
                  Control Get Text hDlg, 150 To temp$
                  GetProcNames2(temp$)
               Next i
               ? Format$((GetTickCount - iStart)/1000,3) & " seconds"
         End Select
   End Select
End Function
 
Function slowBuildProcedureList(ProcListBuf As StringAs String
   Local i As Long, tmp$, w1$, w2$, w3$, w4$, r$
   Dim BufArray(ParseCount(ProcListBuf,$CrLf)-1) As String   'break input string into an array
   Parse ProcListBuf, BufArray(), $CrLf
   For i = 0 To UBound(BufArray)
      tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
      Replace Any "()" With "  " In tmp$
      While InStr(tmp$, "  ") : Replace "  " With " " In tmp$ : Wend  'remove all pairs of spaces
      w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
      If LCase$(w1$+" "+w2$+" "+w3$) = "override property getThen r$=r$+$CrLf+w4$ : Iterate For
      If LCase$(w1$+" "+w2$+" "+w3$) = "override property setThen r$=r$+$CrLf+w4$ : Iterate For
      If LCase$(w1$+" "+w2$) = "macro function"                Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "callback function"             Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "thread function"               Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "class method"                  Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "override method"               Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "property get"                  Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$+" "+w2$) = "property set"                  Then r$=r$+$CrLf+w3$ : Iterate For
      If LCase$(w1$) = "union"                                 Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "macro"                                 Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "sub"                                   Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "functionAnd w2$ <> "="               Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "class"                                 Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "methodAnd w2$ <> "="                 Then r$=r$+$CrLf+w2$ : Iterate For
      If LCase$(w1$) = "interface"                             Then r$=r$+$CrLf+w2$ : Iterate For
   Next i
   Function = Trim$(r$,$CrLf)
End Function
 
Function fastBuildProcedureList(ProcListBuf As StringAs String
   Local i As Long, tmp$, w1$, w2$, w3$, w4$, r$, s1$, s2$, s3$, s4$, s12$, s123$
   Dim BufArray(ParseCount(ProcListBuf,$CrLf)-1) As String   'break input string into an array
   Parse ProcListBuf, BufArray(), $CrLf
   For i = 0 To UBound(BufArray)
      tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
      Replace Any "()" With "  " In tmp$
      While InStr(tmp$, "  ") : Replace "  " With " " In tmp$ : Wend  'remove all pairs of spaces
      w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
      s1$ = LCase$(w1$) : s2$ = LCase$(w2$) : s3$ = Lcase$(w3$) : s4$ = LCase$(w4$)
      s12$ = Build$(s1$," ",s2$)   :   s123$ = Build$(s1$," ",s2$," ",s3$)
 
      If s1$   = "sub"                           Then r$=Build$(r$,$CrLf,w2$) : Iterate For
      If s1$   = "functionAnd w2$ <> "="       Then r$=Build$(r$,$CrLf,w2$) : Iterate For
      If s12$  = "callback function"             Then r$=Build$(r$,$CrLf,w3$) : Iterate For
 
      If s1$   = "macro"                         Then r$=Build$(r$,$CrLf,w2$) : Iterate For
      If s12$  = "macro function"                Then r$=Build$(r$,$CrLf,w3$) : Iterate For
 
      If s12$  = "thread function"               Then r$=Build$(r$,$CrLf,w3$) : Iterate For
 
      If s1$   = "class"                         Then r$=Build$(r$,$CrLf,w2$) : Iterate For
      If s1$   = "methodAnd w2$ <> "="         Then r$=Build$(r$,$CrLf,w2$) : Iterate For
      If s12$  = "class method"                  Then r$=Build$(r$,$CrLf,w3$) : Iterate For
      If s12$  = "override method"               Then r$=Build$(r$,$CrLf,w3$) : Iterate For
      If s1$   = "interface"                     Then r$=Build$(r$,$CrLf,w2$) : Iterate For
 
      If s12$  = "property get"                  Then r$=Build$(r$,$CrLf,w3$) : Iterate For
      If s12$  = "property set"                  Then r$=Build$(r$,$CrLf,w3$) : Iterate For
      If s123$ = "override property get"         Then r$=Build$(r$,$CrLf,w4$) : Iterate For
      If s123$ = "override property set"         Then r$=Build$(r$,$CrLf,w4$) : Iterate For
      If s1$   = "union"                         Then r$=Build$(r$,$CrLf,w2$) : Iterate For
   Next i
   Function = Trim$(r$,$CrLf)
End Function
 
Sub fastestBuildProcedureList(ProcListBuf$)
   Local i, pCount As Long, tmp$, w1$, w2$, w3$, w4$, r$, s1$, s2$, s3$, s4$, s12$, s123$
   Dim MUser(1000) As String
   Dim BufArray(ParseCount(ProcListBuf$,$CrLf)-1) As String   'break input string into an array
   Parse ProcListBuf$, BufArray(), $CrLf
   For i = 0 To UBound(BufArray)
      tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
      Replace Any "()" With "  " In tmp$
      While InStr(tmp$, "  ") : Replace "  " With " " In tmp$ : Wend  'remove all pairs of spaces
      w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
      s1$ = LCase$(w1$) : s2$ = LCase$(w2$) : s3$ = Lcase$(w3$) : s4$ = LCase$(w4$)
      s12$ = Build$(s1$, s2$)   :   s123$ = Build$(s1$, s2$, s3$)
      If s1$   = "sub"                           Then MUser(pCount) = w2$ : Incr pCount : Iterate For
      If s1$   = "functionAnd w2$ <> "="       Then MUser(pCount) = w2$ : Incr pCount : Iterate For
      If s12$  = "callback function"             Then MUser(pCount) = w3$ : Incr pCount : Iterate For
 
      If s1$   = "macro"                         Then MUser(pCount) = w2$ : Incr pCount : Iterate For
      If s12$  = "macro function"                Then MUser(pCount) = w3$ : Incr pCount : Iterate For
 
      If s12$  = "thread function"               Then MUser(pCount) = w3$ : Incr pCount : Iterate For
 
      If s1$   = "class"                         Then MUser(pCount) = w2$ : Incr pCount : Iterate For
      If s1$   = "methodAnd w2$ <> "="         Then MUser(pCount) = w2$ : Incr pCount : Iterate For
      If s12$  = "class method"                  Then MUser(pCount) = w3$ : Incr pCount : Iterate For
      If s12$  = "override method"               Then MUser(pCount) = w3$ : Incr pCount : Iterate For
      If s1$   = "interface"                     Then MUser(pCount) = w2$ : Incr pCount : Iterate For
 
      If s12$  = "property get"                  Then MUser(pCount) = w3$ : Incr pCount : Iterate For
      If s12$  = "property set"                  Then MUser(pCount) = w3$ : Incr pCount : Iterate For
      If s123$ = "override property get"         Then MUser(pCount) = w4$ : Incr pCount : Iterate For
      If s123$ = "override property set"         Then MUser(pCount) = w4$ : Incr pCount : Iterate For
 
      If s1$   = "union"                         Then MUser(pCount) = w2$ : Incr pCount : Iterate For
   Next i
 
   ReDim Preserve MUser(IIF(pCount>0, pCount-1, pCount))
End Sub
 
Function SampleCode() As String
   Local temp$
   '4 word possibilities
   temp$ = temp$ + $CrLf + "Override Property Get myOPG"
   temp$ = temp$ + $CrLf + "Override Property Set myOPS"
 
   '3 word possibilities
   temp$ = temp$ + $CrLf + "Macro Function myMacroFunction"
   temp$ = temp$ + $CrLf + "CallBack Function myCallbackFunction"
   temp$ = temp$ + $CrLf + "Thread Function myThreadFunction"
   temp$ = temp$ + $CrLf + "Class Method myClassMethod"
   temp$ = temp$ + $CrLf + "Override Method myOverrideMethod"
   temp$ = temp$ + $CrLf + "Property Get myPropertyGet"
   temp$ = temp$ + $CrLf + "Property Set myPropertySGet"
 
   '2 word possibilities
   temp$ = temp$ + $CrLf + "Union myUnion"
   temp$ = temp$ + $CrLf + "Macro myMacro"
   temp$ = temp$ + $CrLf + "Sub mySub"
   temp$ = temp$ + $CrLf + "Function myFunction"
   temp$ = temp$ + $CrLf + "Thread myThread"       'invalid
   temp$ = temp$ + $CrLf + "Callback myCallback"   'invalid
   temp$ = temp$ + $CrLf + "Class myClass"
   temp$ = temp$ + $CrLf + "Method myMethod"
   temp$ = temp$ + $CrLf + "Interface myInterface"
   temp$ = temp$ + $CrLf + "Override myOverride"    'invalid
   temp$ = temp$ + $CrLf + "Property myProperty"    'invalid
 
   temp$ = temp$ + $CrLf + "Function=50"        'code should ignore
   temp$ = temp$ + $CrLf + "    Function = 10"  'code should ignore
   temp$ = temp$ + $CrLf + "Method=50"          'code should ignore
   temp$ = temp$ + $CrLf + "    Method = 10"    'code should ignore
   Function = Trim$(temp$,$CrLf)
End Function
 
MACRO AddLine(value)
   IF cntProcs>=maxProcs THEN
      maxProcs = maxProcs + 1000
      REDIM PRESERVE procs(maxProcs)
   END IF
   procs(cntProcs)=value
   INCR cntProcs
   END MACRO
 
Sub GetProcNames1(value As String)
   DIM maxProcs AS INTEGER
   maxProcs=1000
   DIM procs(maxProcs) As String
   DIM cntProcs AS INTEGER
   cntProcs = 0
   DIM translate(255) AS STATIC BYTE
   ARRAY ASSIGN translate() = _
      0, 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, 0, 0, 13, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 0, 0, 0, 61, 0, 0 _
      , 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
      , 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 95 _
      , 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
      , 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
 
   REGISTER i AS INTEGER, p AS INTEGER
   DIM t AS INTEGER
   i=MAX(LEN(value)-13, 0): ' Forget last 13 characters
   DIM v AS BYTE PTR, d AS BYTE PTR
   v = STRPTR(value)
   DIM dest As String
   dest = STRING$(i,32)
   d = STRPTR(dest)
   DIM lastSpace AS INTEGER
   DIM c AS BYTE
   p = 0
   DO WHILE i
      DO
         ' Skip leading spaces
         WHILE i AND translate(@v)<=32
            DECR i
            INCR v
         WEND
         ' Only consider possible lines
         IF INSTR("CFIMOPST",CHR$(translate(@v)))>0 THEN EXIT DO
         ' So find next carriage return
         WHILE i AND translate(@v)<>13
            DECR i
            INCR v
         WEND
      LOOP WHILE i
      IF i=0 THEN EXIT DO
      ' translate possible line
      lastSpace=0
      DO
         c=translate(@v)
         IF c=0 THEN
            ' Skip over rubbish
            WHILE i AND translate(@v)<>13
               DECR i
               INCR v
            WEND
            c = 13
         END IF
         IF lastSpace AND c=32 THEN
            c=0
         ELSE
            lastSpace = (c = 32)
         END IF
         IF c THEN
            @d = c
            INCR d
         END IF
         DECR i
         INCR v
      LOOP WHILE i AND c<>13
   LOOP
   value=RTRIM$(dest)
   p = PARSECOUNT(value, $CR)
   DIM iLines(p-1) As String
   PARSE value, iLines(), $CR
   FOR i=0 TO p-1
      IF LEFT$(iLines(i), 9) = "CALLBACK THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 6) = "CLASS THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "Function AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 10) = "INTERFACE THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 6) = "MACRO THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 7) = "METHOD AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "OVERRIDE THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "PROPERTY AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 4) = "SUB THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 7) = "THREAD THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
   NEXT
   REDIM PRESERVE procs(cntProcs)
End Sub
 
Sub GetProcNames2(SOURCE As String)
   DIM maxProcs As Long:        ' Room we have for procs right now
   DIM cntProcs As Long:        ' Number of procs found
   maxProcs=1000
   cntProcs = 0
   DIM procs(maxProcs) As String:  ' List of found procs
   DIM valid(6) As String:         ' List of valid signatures
   DIM pSource AS BYTE PTR:        ' Pointer to incomming code string
   DIM pValid AS BYTE PTR:         ' Pointer to a line signature
   DIM dest As String:             ' Working buffer
   DIM pDest AS BYTE PTR:          ' Pointer to working buffer
   REGISTER dstLen AS INTEGER:     ' Length of line in working buffer
   REGISTER p AS INTEGER:          ' General variable
   DIM firstStatement AS INTEGER:  ' Indicates we're still in first statement
   ARRAY ASSIGN valid() = "class ","function ","method ","override ","property ","sub ","thread "
   pSource = STRPTR(SOURCE)
   dest = STRING$(1000, " ")
   DO WHILE @pSource
      DO
         ' Skip leading spaces
         WHILE @pSource AND @pSource <= 32
            INCR pSource
         WEND
         SELECT CASE @pSource OR 32
            CASE 99: p=0: ' c
            CASE 102: p=1: ' f
            CASE 109: p=2: ' m
            CASE 111: p=3: ' o
            CASE 112: p=4: ' p
            CASE 115: p=5: ' s
            CASE 116: p=6: ' t
            CASE ELSE: p=-1
         END SELECT
         IF p>-1 THEN
            pValid = STRPTR(valid(p))
            pDest = STRPTR(dest)
            dstLen = 0
            ' Check line signature
            DO WHILE @pSource AND @pValid
               IF (@pSource OR 32) <> @pValid THEN EXIT LOOP
               @pDest = @pSource:                  ' Copy while checking
               INCR pDest
               INCR dstLen
               INCR pSource
               INCR pValid
            LOOP
            IF @pValid=0 THEN
               ' Finish line copy
               firstStatement = -1
               DO WHILE @pSource AND @pSource<>13
                  IF firstStatement THEN
                     SELECT CASE @pSource
                        CASE 58: firstStatement=0: ' :
                        CASE 61: EXIT DO' =
                     END SELECT
                  END IF
                  @pDest = @pSource
                  INCR pSource
                  INCR pDest
                  INCR dstLen
               LOOP
               IF @pSource=13 OR @pSource=0 THEN
                  ' Ensure room for new proc signature
                  IF cntProcs>=maxProcs THEN
                     maxProcs = maxProcs + 1000
                     REDIM PRESERVE procs(maxProcs)
                  END IF
                  ' Add proc signature to list
                  procs(cntProcs)=LEFT$(dest, dstLen)
                  INCR cntProcs
               END IF
            END IF
         END IF
         ' Move on to the end of the line if not there
         WHILE @pSource AND @pSource<>13
            INCR pSource
         WEND
      LOOP WHILE @pSource
   LOOP
   REDIM PRESERVE procs(cntProcs-1)
End Sub
 
'gbs_01079
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm