Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Profile Creator Function

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Gösta H. Lovgren-2
    replied
    Profile_Ordered_with_Variables.Inc Updated

    Added a couple features. Now launches text editor if wanted. Can adjust parameters of of arrays in cases where wanted. Some other minor stuff.

    Leave a comment:


  • Gösta H. Lovgren-2
    replied
    Changed formatting in Profile_Ordered_with_Variables.Inc to make it more readable Now only two colums of variables instead of 4, which was too wide to fit on a single screen.

    Leave a comment:


  • Gösta H. Lovgren-2
    replied
    Updated Dec 2, 2008
    '
    Code:
    '**************************************************************************************************
    '**************************************************************************************************
    '**************************************************************************************************
    '                        Profile_Ordered_with_Variables.Inc 
    '**************************************************************************************************
    '
    ';;;; Reorders and reformats the file Created by the "Profile" command
    ';;;; This Output is "Willie Sutton Style" (robbed from many PB'ers)
    ';;;; Comments here: [URL]http://www.powerbasic.com/support/pbforums/showthread.php?t=39105[/URL]
    ';;;;
    ';;;;             Instructions to install: 
    '
    ';;;; At top of PBMain put the next 7 lines
    '   'Profile Starting Data
    '  Local PD As Profile_Data 
    '  PD.Start_Date = Date$ 
    '  PD.Start_Time = Time$ 
    '      comment out next line if no Profile is wanted
    '  PD.Start_Ticks = GetTickCount 'WinApi that keeps track of elapsed time 'resets every 49 days
    '    ///End Profile Starting Data
    '
    ';;;; At the end of PBMain put this line:
    '  Profile_Ordered(PD) 
    '
    ';;;; Search for this next line and change the folder to point to your WinApi location  
    '   fname$ = "C:\Power Basic\PB9\WinAPI\WIN32API.INC" 
    ';;;; If you don't change it, no harm no foul. It will just list Calls in the WinApi as "Uncalled" 
    '
    ';;;; Also this version will launch/reload the default text editor with the output file.
    ';;;; If you don't want this to happen, comment out (or = 0) this next line in Function Profile_Ordered
    '    Load_Into_Text_Editor = 1
    '
    ';;;; Note all procedures (as well as Macros) begin with "Profile_" in order to (hopefully) not conflict with
    ';;;; other Procedure names when using this as an .Inc     
    '
    ';;;; If memory is a problem or it's a large complicated program you can change these constants to lower/higher numbers
    ';;;; Varible & Procedure Type sizers 
    %Profile_Array_Elements = 250 'Likely largest number of any variety of variables, Procedures, Subs, Macros, etc. 
    %Profile_Variable_Name_Length = 50 'chars for variable names
    %Profile_Procedure_Name_Length = 255 'chars for Procedure & Macros 
    ';;;; Note if the Equates:
    ';;;; are set too high, no error will occur but the Variables section just won't print
    ';;;; are set too low, Profile will GPF after the Uncalled Procedures section prints
    '
    ';;;; Memory requirement examples with the Equates set to:
    '
    '*********************************************************************'
    '         1,000 = %Profile_Array_Elements 
    '            50 = %Profile_Variable_Name_Length 
    '           255 = %Profile_Procedure_Name_Length 
    '       960,000 = Size of each Profile_Program_Info array Element
    '           937 =  Free Memory needed in Megabytes
    '*********************************************************************'
    '
    '*********************************************************************'
    '           150 = %Profile_Array_Elements 
    '            25 = %Profile_VariableName_Length 
    '           100 = %Profile_Procedure_Name_Length 
    '        63,750 = Size of each Profile_Program_Info array Element
    '             9 =  Free Memory needed in Megabytes
    '*********************************************************************'
    '
    '*********************************************************************'
    '           250 = %Profile Array Elements 
    '            50 = %Profile_Variable_Name_Length 
    '           255 = %Profile_Procedure_Name_Length 
    '       240,000 = Size of each Profile_Program_Info array Element
    '            57 =  Free Memory needed in Megabytes
    '*********************************************************************'
    '
    '
    '
    ';;;; End of Profile Comments. 
    '*********************************************************************'
    '*********************************************************************'
    '*********************************************************************'
    '
    Macro pfl1 = Print #1,    
    '
    Macro Profile_Print_Array
      If InStr(n$, "Alpha") Then    
         Array Sort p_Info(), Ascend 'Names
        Else 
         Array Sort p_Info(), Descend 'Numbers so start with largest first
      End If   
     
      RSet u1$ = " *** " & n$ & " ***" & Blank_Line$'sorted title 
      pfl1  blank_line$
      pfl1  "*****************************************************************************************************"
      pfl1  u1$ & Space$(16) & "Calls         Tot ms  ms/call    % of time"
        Reset ctr
        For i = LBound(p_Info()) To UBound(p_Info()) 
           If p_Info(i).Calls > 0 Then 'Only show those that have been called
              Incr ctr
              LSet u2$ = Trim$(p_Info(i).Name) & " " & String$(50, "_") 'Procedure name
              u3$ = Using$("  ###,###,###",   p_Info(i).Calls) & _ 'calls to procedure
                    Using$("  #,###,###,###", p_Info(i).Time_Used) & _  'time spent there
                    Using$("  #,###.#",       p_Info(i).Time_Used / p_Info(i).Calls) & _ 'avg per call
                    Using$("  ##%",        p_Info(i).Time_Used / Ms_Ttl * 100) 'time spent here as part of program run
              Replace " " With "_" In u3$ 'lines all the way across
              pfl1  Using$("###) ", ctr) & _
                        u2$ & _
                        u3$     
           End If 
        Next i 
    End Macro  
    '
    Macro Profile_Top_Header
      Open Profile_FileName For Output As #1
    '  
        Secs = (GetTickCount - pfl.Start_Ticks) \ 1000 
        Actual_Ms = (GetTickCount - pfl.Start_Ticks)
        hrs = Secs \ 3600
        mins = (Secs  - (hrs * 3600)) \ 60
        secs = (Secs -  (hrs * 3600)) - (mins * 60)
    '    
        Local t1, t2 As String 
        Local td As Long
        td = Actual_Ms - Ms_Ttl
        
          t1$ = Using$("# Hours # Minutes # Seconds ", hrs, mins, secs)
          t2$ = "                              Call overhead: " &  $CrLf & _
                 Using$("                     Total Calls = #, ", Calls_Ttl) & $CrLf  & _
                 Using$("                       Total Ms  = #, ", Ms_Ttl) & $CrLf  & _
                 Using$("                   Time Difference #, ", td) & $CrLf  & _
                 Using$("Apparent Call Overhead for Profile #.#####   (Time dif / Call Total)", td / Calls_Ttl)            
    '      t2$ = Time$
    '      Replace " " With "0" In t1$ '0's instead of spaces
    '      Replace " " With "0" In t2$ ' ""
    '      
        pfl1 , "Profile for " &  Profile_FileName 
        pfl1 , " Started " & pfl.Start_Date & " at " & pfl.Start_Time
        pfl1 , "Finished " & Date$          & " at " & Time$
        pfl1 , "Ran for " & t1$       
        pfl1  t2$
        pfl1 , "(Note elapsed seconds may not agree exactly due to the different methods used"
        pfl1 , "  to calculate each. Especially on shorter runs - say under 2 minutes)"           
    End Macro
    '
    Macro Profile_File_to_Temp_Array
      fnum = FreeFile
    retry:
      Try
        Open fname$ For Binary As #fnum
      Catch 'Error so not ready to open yet
        Sleep 100 'take a nap
        GoTo retry 'try again
      End Try
    '  
      sFile = Space$(Lof(#fnum)) 'make string to hold file
      Get #fnum,, sFile  'put te file in the string
      Close fnum  'don't need it anymore
     '
      ctr = ParseCount(sFile, $CrLf ) 'get number of lines
      Local temp$()
      ReDim temp$(1 To ctr)' to hold lines
      Parse sFile, Temp$(), $CrLf 'put lines in here
    End Macro
    '
    Type Profile_Type_Info
      Sort_Field As String * %Profile_Procedure_Name_Length + 10
      Name As String * %Profile_Procedure_Name_Length 'way plenty long
      Calls As Long
      Time_Used As Long
    End Type
    '
    '
    Type Profile_Program_Info
      Bytes      (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length      '# of Byte variables
      Integers   (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length   '  " Integers
      Longs      (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Dwords     (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Singles    (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Doubles    (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Quads      (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Strings    (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Pointers   (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Types      (1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length
      Procedures (1 To %Profile_Array_Elements) As String * %Profile_Procedure_Name_Length 'Should be plenty
      Macros     (1 To %Profile_Array_Elements) As String * %Profile_Procedure_Name_Length '
    End Type     
    '                                 
    Macro Profile_Function_or_Sub 'code de-clutterer makes easier readability
      s2$ = UCase$(Left$(temp$(ctr), Len(s1$)))
      If s1$ = s2$ Then
         Incr tmp
      End If 
    End Macro
    '
    Macro Profile_Remove_Win_Api_References
       Local fnum1 As Long
       fnum1 = FreeFile
    '   Open "WIN32API.INC" 
      fname$ = "C:\Power Basic\PB9\WinAPI\WIN32API.INC" 'you'll have to change this
      ErrClear
      Open fname$ For Binary As #fnum1
       ctr = Lof(#fnum1)   'how big?
      If ctr < 100 Then 'not very
         ? fname$,, "Not good WinApi location"
         Close #fnum1
         GoTo no_good
      End If                     
    '  
       sfile$ = Space$(ctr) 'make string that big
       Get #fnum1, , sfile$ 'now get the file
       Close #fnum1 'don't need it anymore
    '
       sfile$ = UCase$(sfile$) 'easier searching
       For ctr = LBound(p_Info()) To UBound(p_Info()) 
          If  p_Info(ctr).Calls < 1 Then 'not called
              n$ = " " & Trim$(UCase$(p_Info(ctr).Name)) & " "'add spaces make sure it's not embedded somewhere
              i = InStr(sfile$, n$) 'search for it
              If i Then 'in WinApi
                 p_Info(ctr).Calls = 1 'so it gets skipped in Uncalled
              End If
          End If  
       Next ctr
    ' 
    No_good:     
    End Macro       
    '
    Macro Profile_Duplicate_Check
      If ctr > 1 And _
         srt(ctr) = srt(ctr - 1) Then 
         srt(ctr)  = "*" & srt(ctr)
      End If                        
    End Macro
    '                
    Function Profile_ProcessAnyArray_Procedures (pZ As Dword) As Long 
     ReDim  Z(1 To %Profile_Array_Elements)  As String * %Profile_Procedure_Name_Length At pZ '255 bytes long   
       Array Sort z()
    End Function 
    '                
    Function Profile_ProcessAnyArray_Variable (pZ As Dword) As Long 
     ReDim  Z(1 To %Profile_Array_Elements)  As String * %Profile_Variable_Name_Length At pZ '50 bytes long    
       Array Sort z()
    End Function 
    '------------------/ProcessAnyArray'
    '
    Macro Profile_Sort_Arrays_Cleaner_Code '13 lines
      tim1 = Timer - tim
      tim = Timer
    '                                                      '255 chars
      ReDim srt1(1 To %Profile_Array_Elements) As String * %Profile_Procedure_Name_Length  At VarPtr(pfi.Procedures(1)) 
             Profile_ProcessAnyArray_Procedures(VarPtr(pfi.Procedures(1)))
             Profile_ProcessAnyArray_Procedures(VarPtr(pfi.Macros(1)))
    '                                                       '50 chars
      ReDim srt1(1 To %Profile_Array_Elements) As String * %Profile_Variable_Name_Length  At VarPtr(pfi.Bytes(1)) 
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Bytes(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Integers(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Longs(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Dwords(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Singles(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Doubles(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Quads(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Strings(1)))
             Profile_ProcessAnyArray_Variable(VarPtr(pfi.Pointers(1)))
    End Macro
    '
    Macro Profile_Sort_Arrays '150+ lines
    ''  Bytes (1 To %Profile_Array_Elements) As String * 50
    '  Integers (1 To %Profile_Array_Elements) As String * 50
    '  Longs (1 To %Profile_Array_Elements) As String * 50
    '  Dwords (1 To %Profile_Array_Elements) As String * 50
    '  Singles (1 To %Profile_Array_Elements) As String * 50
    '  Doubles (1 To %Profile_Array_Elements) As String * 50
    '  Quads (1 To %Profile_Array_Elements) As String * 50
    '  Strings (1 To %Profile_Array_Elements) As String * 50
    '  Pointers (1 To %Profile_Array_Elements) As String * 50
    '  Procedures (1 To %Profile_Array_Elements) As String * 255
    '  Macros (1 To %Profile_Array_Elements) As String * 255
     
      askey = Asc("~") 'use for sorts and formatting output
    '
      tim = Timer
      ReDim srt(1 To %Profile_Array_Elements) As String 
    ' 
     If Prcd Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Procedures(ctr))
       Next ctr                    
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Procedures(ctr) = dup$ & MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    ' 
     If Mcro Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Macros(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Macros(ctr) = dup$ & MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     ReDim srt(1 To %Profile_Array_Elements) As String' * 50 'rest of stuff
    '              
     If Prs Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Pointers(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Pointers(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
      ReDim srt(1 To %Profile_Array_Elements) As String' * 50 'rest of stuff
    '
     If Srng Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Strings(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Strings(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If qad Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Quads(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Quads(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If Dbl Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Doubles(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Doubles(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If Sng Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Singles(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Singles(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If Dwrd Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Dwords(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Dwords(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If Lng Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Longs(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Longs(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If Intg Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Integers(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Integers(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If             
    '              
     If byt Then
       For ctr = 1 To %Profile_Array_Elements 'put in to sort
          srt(ctr) = UCase$(pfi.Bytes(ctr))
       Next ctr                 
       Array Sort srt()
       For ctr = 1 To %Profile_Array_Elements  'sorted, so put back
          If Asc(srt(ctr)) < askey Then 
             Profile_Duplicate_Check
             pfi.Bytes(ctr) = MCase$(srt(ctr))
          End If   
       Next ctr                 
     End If                          
    ' 
     
    End Macro
    '
    Function Profile_Program_Variables(Prog_Name As String, p_Info() As Profile_Type_Info, Blank_Line$) As Long
       Local MsTtl, most, ctr1, tmp, jump_Flag, glb_flag, i,  fnum, ctr As Long
       Local tps, prs, sb, mcro, Prcd, sng, dbl, byt, intg, dwrd, qad, srng, lng As Long 'counters
       Local temp(), u, z, vrbls(), casting, glb, n, n1, t1, t2, sfile, fname, s1, s2 As String              
       Local pfi As Profile_Program_Info
    '
      fname$ = Prog_Name 'Program_Name.bas
      Profile_File_to_Temp_Array 'put .bas into temp$()
    ' 
      ctr1 = 45          
      s1$ = String$(ctr1, "~") 'high ascii for sorting
    '
      For ctr = 1 To %Profile_Array_Elements  'makes easier empty or unused field readability in prinout to fill field
         pfi.Bytes(ctr) = s1$
         pfi.Integers(ctr) = s1$
         pfi.Longs(ctr) = s1$
         pfi.Dwords(ctr) = s1$
         pfi.Singles(ctr) = s1$
         pfi.Doubles(ctr) = s1$
         pfi.Quads(ctr) = s1$
         pfi.Strings(ctr) = s1$
         pfi.Pointers(ctr) = s1$
         pfi.Types(ctr) = s1$
         pfi.Macros(ctr) = s1$ & s1$ & s1$ & s1$ & s1$
         pfi.Procedures(ctr) = s1$ & s1$ & s1$ & s1$ & s1$
      Next ctr
     
    '
      For ctr = LBound(Temp$()) To UBound(temp$()) 'clean it up   
        n$ = UCase$(temp$(ctr)) 'n$ less clumsy to use, so is all caps
        n$ = Trim$(n$)  'get rid of extra spaces
        If Left$(n$, 1) = "'" Then Iterate For 'Remmed line so skip it
    '
        i = InStr(n$, "'") 'remarks in line
        If i Then 'rem at end of actionable stuff so strip it off
           n$ = Left$(n$, i - 1)
           n$ = Trim$(n$) 'any spaces left
        End If
    '    
        s1$ = "MACRO ": tmp = Mcro: Profile_Function_or_Sub '3 statements. just easier to follow code than 3 lines
           If tmp <> Mcro Then 'incremented tmp so found one
              Mcro = tmp 'counter
              pfi.Macros(Mcro) = Mid$(n$, Len(s1$))      
             Iterate For 'get next line - skip rest of parsing this ine 
           End If   
    '
        s1$ = "FUNCTION ": tmp = Prcd: Profile_Function_or_Sub '3 statements. just easier to follow code than 3 lines
           If Prcd <> tmp Then 'incremented tmp so found one
              Prcd = tmp 'counter
              pfi.Procedures(Prcd) = Mid$(n$, Len(s1$))                 
             Iterate For 'get next line - skip rest of parsing this ine 
           End If               
           
          s1$ = "END FUNCTION" 'check for end of function
          s2$ = Left$(n$, Len(s1$)) 
          If s1$ = s2$ Then 'at end
             Iterate For 'get next line - skip rest of parsing this ine 
          End If
     
        s1$ = "SUB ": tmp = Prcd: Profile_Function_or_Sub '3 statements. just easier to follow code than 3 lines
           If Prcd <> tmp Then 'found one
              Prcd = tmp 'counter
              pfi.Procedures(Prcd) = Mid$(n$, Len(s1$))
             Iterate For 'get next line - skip rest of parsing this ine 
           End If  
          s1$ = "END SUB" 'check for end of function
          s2$ = Left$(n$, Len(s1$)) 
          If s1$ = s2$ Then 'at end
             Iterate For 'get next line - skip rest of parsing this ine 
          End If
     
        s1$ = "TYPE ": tmp = tps: Profile_Function_or_Sub '3 statements. just easier to follow code than 3 lines
           If tps <> tmp Then 'found one
              tps = tmp 'counter
              pfi.Types(tps) = Mid$(n$, Len(s1$))
             Iterate For 'get next line - skip rest of parsing this ine 
           End If  
          s1$ = "END TYPE" 'check for end of type
          s2$ = Left$(n$, Len(s1$)) 
          If s1$ = s2$ Then 'at end
             Iterate For 'get next line - skip rest of parsing this ine 
          End If
     
     
     
        s1$ = "GLOBAL "
        s2$ = Left$(n$, Len(s1$)) 'get from line
        t1$ = n$ ' use t1$ instead of n$ to preserve n$ JIC needed later
    '
        If s1$ = s2$ Then 'starting new Global
           Glb_flag = 1'
           t1$ = Mid$(n$, Len(s1$) + 1) 'strip off beginning of line
        End If   
    '
        If Glb_flag Then 'Part of Global casting
        End If   
    '
        If  glb_flag > 0 Then 'Working on Global
           i = InStr(t1$, " _") 'line continuation marker
             If i Then 'yes
                glb$ = glb$ & Left$(t1$, i-1) 'concatenate lines
               Else 
                glb$ = glb$ & t1$ 'line to print 
             End If
        End If
    '
        i = InStr(t1$, " AS ")
        If I And glb_Flag > 0 Then 'end of this casting
           GoSub Accumulate 'put them into array for later use
           Reset glb$
           glb_flag = InStr(i, t1$, " _") 'if exists then multi casting on same "Global " so keep flag set
        End If  
    '
      Next ctr    'all code lines read
    ' 
      Local tim, tim1, askey As Long
      Local dup As String
     
      Profile_Sort_Arrays' faster than Cleaner
    '  Profile_Sort_Arrays_Cleaner_Code
        s1$ = Using$("        Profile_Sort_Arrays took #,.## seconds" & $CrLf & _
                     "Profile_Sort_Arrays_Cleaner took #,.## seconds", tim1, Timer -tim)
    '   ClipBoard Set Text s1$ To ctr
    '   ? s1$
     
    '                                
      GoSub Print_Variables   
    '                                                     
     Exit Function '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
    '
    Print_Variables:
    '
      t1$ = Space$(5) 'for ctr
      t2$ = t1$ 'for header to line up
     
     Local wdth As Long 
      wdth = 48 
      u$ =       "\" & Space$(Wdth) & "\ " & _ 'format string
                 "\" & Space$(wdth) & "\ "
    ' 
      pfl1  "************************************** Variables  ****************************************************"
      pfl1  t2$ & _
               Using$(u$, Str$(byt) & " Bytes", _
                          Str$(intg) &  " Integers") 
      For ctr = 1 To %Profile_Array_Elements
         If ctr > byt And _
            ctr > intg Then
           Exit For  'no more here
         End If      
         RSet t1$ = Str$(ctr) & ") "
         pfl1  t1$ & _
                      Using$(u$,  _
                      pfi.Bytes(ctr), _
                      pfi.Integers(ctr))
      Next ctr               
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
     
     'lng, dwrd 
      pfl1  "*****************************************************************************************************"
      pfl1  t2$ & _
               Using$(u$, Str$(lng) & " Longs", _
                          Str$(dwrd) & " Dwords")
      For ctr = 1 To %Profile_Array_Elements
         If ctr > lng And _
            ctr > dwrd Then
           Exit For  'no more
         End If      
         RSet t1$ = Str$(ctr) & ") "
         pfl1  t1$ & _
                      Using$(u$,  _
                      pfi.Longs(ctr), _
                      pfi.Dwords(ctr))
      Next ctr               
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
    '
    'sng, dbl
      pfl1  "*****************************************************************************************************"
      pfl1  t2$ & _
               Using$(u$, _
               Str$(sng) & " Singles", _
               Str$(dbl) & " Doubles")       'header
      For ctr = 1 To %Profile_Array_Elements
         If ctr > sng And _
            ctr > dbl Then
           Exit For  'no more
         End If      
         RSet t1$ = Str$(ctr) & ") "
         pfl1  t1$ & _
                      Using$(u$,  _
                      pfi.Singles(ctr), _
                      pfi.Doubles(ctr))
      Next ctr               
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
    '                           
    ' qad, srng
      pfl1  "*****************************************************************************************************"
      pfl1  t2$ & _
               Using$(u$, _
               Str$(qad) & " Quads", _
               Str$(srng) & " Strings")       'header
      For ctr = 1 To %Profile_Array_Elements
         If ctr > qad And _
            ctr > srng Then
           Exit For  'no more
         End If      
         RSet t1$ = Str$(ctr) & ") "
         pfl1  t1$ & _
                      Using$(u$,  _
                      pfi.Quads(ctr), _
                      pfi.Strings(ctr))
      Next ctr               
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
    '
    '  Pointers (1 To %Profile_Array_Elements) As String * 50  'prs
      pfl1  "*****************************************************************************************************"
      pfl1  t2$ & _
               Using$(u$, _
               Str$(prs) & " Pointers", _
               Str$(tps) & " Types")       'header
      For ctr = 1 To prs '1000
         RSet t1$ = Str$(ctr) & ") "
         pfl1  t1$ & _
                      Using$(u$,  _
                      pfi.Types(ctr), _
                      " ")
      Next ctr               
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
    '
      pfl1  "*****************************************************************************************************"
     pfl1  "         Procedures (Functions & Subs)" & Blank_Line$
     For ctr = 1 To prcd 
          pfl1  Using$("###) ", ctr) & MCase$(pfi.Procedures(ctr)) & " ***"
      Next ctr
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
    '
      pfl1  "*****************************************************************************************************"
     pfl1  "         Macros" & Blank_Line$
     For ctr = 1 To mcro 
          pfl1  Using$("###) ", ctr); MCase$(pfi.Macros(ctr)) 
      Next ctr
      pfl1  Blank_Line$ 'allow for full column scrolling in editor 
     
    Return                  
    '
    Accumulate:
      glb$ = Trim$(glb) 'JIC
    '     
      i = InStr(glb$, " AS ") 'find casting
       If i = 0 Then
          ? glb$, , "Casting Error in " & FuncName$
          Return
       End If
       casting$ = Mid$(glb$, i)'what kind is it?
       n1$ = Left$(glb$, i) 'get the globals alone
       n1$ = Trim$(n1$) 'JIC
    '
      If Right$(glb$, 4) = " PTR" Then 
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr prs   'count them
               pfi.Pointers(prs) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
         Return 'so it doesn't get caught in Select.Case
      End If
    '
       Select Case Casting$
          Case " AS BYTE"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr byt   'count them
               pfi.Bytes(byt) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
          '
          Case " AS INTEGER"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr intg   'count them
               pfi.Integers(intg) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Longs (1 To %Profile_Array_Elements) As String * 50    'lng
          Case " AS LONG"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr lng   'count them
               pfi.Longs(lng) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Dwords (1 To %Profile_Array_Elements) As String * 50   'dwrd
          Case " AS DWORD"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr dwrd   'count them
               pfi.Dwords(dwrd) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Singles (1 To %Profile_Array_Elements) As String * 50  'sng
          Case " AS SINGLE"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr sng   'count them
               pfi.Singles(sng) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Doubles (1 To %Profile_Array_Elements) As String * 50  'dbl
          Case " AS DOUBLE"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr dbl   'count them
               pfi.Doubles(lng) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Quads (1 To %Profile_Array_Elements) As String * 50    'qad
          Case " AS QUAD"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr qad   'count them
               pfi.Quads(qad) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
    '  Strings (1 To %Profile_Array_Elements) As String * 50  'srng
          Case " AS STRING"
            GoSub Parse_Globals 'split them up
            For ctr1 =LBound(vrbls$()) To UBound(vrbls$())
               Incr srng   'count them
               pfi.Strings(srng) = MCase$(vrbls$(ctr1)) 'put name in here 
            Next ctr1
       End Select
      Return      
    '      
    Parse_Globals:
     Reset ctr1            'JIC
     ctr1 = ParseCount(n1$)' How many?
     ReDim vrbls(1 To ctr1)' place to put them
     Parse n1$, vrbls$()  
     Return
    End Function
    '
    '
    'Function Profile_Ordered(Profile_Start_Time As Long, Profile_Start_Ticks As Dword) As Long
    '
    Type Profile_Data
      Start_Date As String * 10
      Start_Time As String * 8
      Start_Ticks As Dword
    End Type
    '
    Function Profile_Ordered(pfl As Profile_Data) As Long
    '
      Local Load_Into_Text_Editor, fnum, Actual_Ms, Ms_Ttl, Calls_Ttl, Longest, ctr, i, hrs, mins, secs  As Long
      Local P_info() As Profile_Type_Info              
      Local Blank_Line, sfile, temp(), Profile_FileName, PFN, fname, n, u, u1, u2, u3, u4 As String
    '
      Blank_Line$ = Space$(255) 'for text editor scrolling
      Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                         Exe.Name$ & _ 'Progran running name
                         "_Profile.txt" 'Add a unique identifier to it
    '
      Load_Into_Text_Editor = 1 'comment out if not wanted or = 0
    '
      Pfn$ = Remove$(Profile_FileName, "_Profile.txt")& ".bas" 'for use in Profile_Program_Variables later
    '
      Profile Profile_FileName 'create the file
     '
      fname$ = Profile_FileName
      Profile_File_to_Temp_Array
    '  
      ReDim P_info(ctr) 'get our Type ready. ctr set in Macro Profile_File_to_Temp_Array
    '
      Longest = 20 'name length to format for later
      For ctr = LBound(temp$()) To UBound(temp$()) 
           p_Info(ctr).Name = Parse$(temp$(ctr), 1)
           p_Info(ctr).Name = MCase$(p_Info(ctr).Name)'cleaner looking
          If Len(Trim$(p_Info(ctr).Name)) > Longest Then
             longest = Len(Trim$(p_Info(ctr).Name)) 'Longest variable name
          End If             
     
           p_Info(ctr).Calls     = Val(Parse$(temp$(ctr), 2)) 
           p_Info(ctr).Time_Used = Val(Parse$(temp$(ctr), 3)) 
           Ms_Ttl = Ms_Ttl + p_Info(ctr).Time_Used 
           Calls_Ttl = Calls_Ttl + p_Info(ctr).Calls
      Next ctr                           
     
    '      'formatting strings
        u1$ = Space$(30) 'for header string
        u2$ = Space$(Longest + 1) 'for procedure & variable names
    '
        Profile_Top_Header 'Print Top of page
    '                                        
    '
        n$ = "Alphabetical"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = p_Info(ctr).Name 'sort by name
        Next ctr 
        Profile_Print_Array 'Sort & print results
    '   
        n$ =  "Call Frequency"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Profile_Print_Array 'Sort & print results
     '
        n$ = "Time Used"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Time_Used) & _'sort by Calls
                                   p_Info(ctr).Name
        Next ctr 
        Profile_Print_Array 
    '
        n$ =  "UnCalled For"
        'put in Alpha order
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Array Sort p_info()
    '      
        Profile_Remove_Win_Api_References
    '''
        Reset i                
        pfl1  Blank_Line$ 
      pfl1  "*****************************************************************************************************"
     
        pfl1  "    *** Uncalled Procedures ***" & Blank_Line$    
    '        
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          If p_Info(ctr).Calls < 1 And _
              Asc(p_Info(ctr).Name) > 34  Then 
            Incr i
            pfl1  Using$("###) ", i) & p_Info(ctr).Name & Blank_Line$
          End If  
        Next ctr        
        If i = 0 Then pfl1  "        *** No Uncalled *** "   & Blank_Line$
    '
       pfl1  Blank_Line$
    '
       Profile_Program_Variables(Pfn$, p_Info(), Blank_Line$) 'now get and print program variables 
    '
       pfl1  "*****************************************************************************************************"
       pfl1  "                 **** This format courtesy of many PB Programmers ****"  
       pfl1  "Discussion of Profile_Ordered is at [URL]http://www.powerbasic.com/support/pbforums/showthread.php?t=39105[/URL]" 
       pfl1  "*****************************************************************************************************"
       pfl1  " " 
    t1$ = "'*********************************************************************'" & $CrLf & _
          "        %Profile_Array_Elements =" & Using$(" #,", %Profile_Array_Elements) & $CrLf & _
          "  %Profile_Variable_Name_Length =" & Using$(" #,", %Profile_Variable_Name_Length) &  $CrLf & _
          " %Profile_Procedure_Name_Length =" & Using$(" #,", %Profile_Procedure_Name_Length) & $CrLf & _
          "           Profile_Program_Info =" & Using$(" #, Size of each array element", Len(Profile_Program_Info)) & $CrLf &  _
          "                         Memory =" & Using$(" #, Megabytes to run Profile_With_Variables",  %Profile_Array_Elements * Len(Profile_Program_Info) / 1024 / 1024) & $CrLf  & _
          "'*********************************************************************'"
       pfl1  t1$   
      
      t1$ = "Profiles\" & Date$ & "-" & Time$ & "-" & Exe.Name$ & _ 
           ".txt" 
     
       Replace ":" With "-" In t1$ ' ":" not acceptable in filename
       pfl1 t1$ & " (Quick C&P for saving in 'Profiles\') - already in Clipboard."
      ClipBoard Set Text t1$ To ctr
       
      Close #1
    '  
        If Load_Into_Text_Editor = 1 Then
         Close  'JIC
           ShellExecute ByVal 0&, "open", Profile_FileName + Chr$(0), ByVal 0&, ByVal 0&, %SW_SHOW
      End If
     
    '
    End Function
    '**************************************************************************************************
    '**************************************************************************************************
    '**************************************************************************************************
    '***********                     End Profile_Ordered_with_Variables  ******************************
    '**************************************************************************************************
    '
    Last edited by Gösta H. Lovgren-2; 2 Dec 2008, 10:10 PM. Reason: Now shows memory requirement examples

    Leave a comment:


  • Gösta H. Lovgren-2
    replied
    Here is the routine as Include.Inc. Note this version also removes any references to Win32Api in the "Uncalled Procedures" list. You will have to change the hard coded folder to activate it though.

    '
    Code:
    '**************************************************************************************************
    '**************************************************************************************************
    '**************************************************************************************************
    '                        Profile_Ordered.Inc 
    '**************************************************************************************************
    '
    ';;;; Reorders and reformats the file Created by the "Profile" command
    ';;;; This Output is "Willie Sutton" (robbed from many PB'ers)
    ';;;;             Instructions to install: 
    '
    ';;;; Inside PBMain the top put the next 2 lines
    '  Local Profile_Start_Time as long
    '  Profile_Start_Time = timer                  
    '
    ';;;; At the end of PBMain put this line:
    ' Profile_Ordered(Profile_Start_Time)  'Applikashunfurstunkendun
    '
    ';;;; Search for this next line and change the folder to point to your location  
    '   fname$ = "C:\Power Basic\PB9\WinAPI\WIN32API.INC" 
    ';;;; If you don't change it, no harm no foul. It will just list Calls in the WinApi as "Uncalled" 
    ';;;
    '''' 
    Macro Profile_Print_Array
      If InStr(n$, "Alpha") Then    
         Array Sort p_Info(), Ascend 'Names
        Else 
         Array Sort p_Info(), Descend 'Numbers so start with largest first
      End If   
      RSet u1$ = "*** " & n$ & " ***" 'sorted name
      Print #1 'blank line
      Print #1, u1$ & "        Calls         Tot ms  ms/call   % of time"
        Reset ctr
        For i = LBound(p_Info()) To UBound(p_Info()) 
           If p_Info(i).Calls > 0 Then 'no sense showing these
              Incr ctr
              RSet u2$ = Trim$(p_Info(i).Name) 'Procedure name
              Print #1,  Using$("###) ", ctr); _ 'counter
                 u2$; _     'Name
                 Using$("  ###,###,###",   p_Info(i).Calls); _ 'calls to procedure
                 Using$("  #,###,###,###", p_Info(i).Time_Used); _  'time spent there
                 Using$("  #,###.#",       p_Info(i).Time_Used / p_Info(i).Calls); _ 'avg per call
                 Using$("    ##% ",        p_Info(i).Time_Used / ttl_secs * 100) 'time spent here as part of program run
           End If 
        Next i 
    End Macro  
    '
    Macro Profile_Top_Header
      Open Profile_FileName For Output As #1
    '  
        hrs = Profile_Start_Time \ 3600
        mins = (Profile_Start_Time  - (hrs * 3600)) \ 60
        secs = (Profile_Start_Time -  (hrs * 3600)) - (mins * 60)
    '    
        Local t1, t2 As String 
          t1$ = Using$("##:##:##", hrs, mins, secs)
          t2$ = Time$
          Replace " " With "0" In t1$ '0's instead of spaces
          Replace " " With "0" In t2$ ' ""
    '      
        Print #1,, "Profile for " &  Profile_FileName 
        Print #1,, Date$ & "   Ran from " & _
                   t1$ & " to " & _
                   t2$ & _
                   Using$(" for #, seconds", Timer - Profile_Start_Time) 
        Print #1,, "(Note elapsed seconds may not agree with ms Total due "
        Print #1,, "to the different methods used to calculate each."
        Print #1,, " Especially on shorter runs - say under 2 minutes)"           
    End Macro
    '
    Macro Profile_File_to_Temp_Array
      fnum = FreeFile
    retry:
      Try
        Open fname$ For Binary As #fnum
      Catch 'Error so not ready to open yet
        Sleep 100 'take a nap
        GoTo retry 'try again
      End Try
    '  
      sFile = Space$(Lof(#fnum)) 'make string to hold file
      Get #fnum,, sFile  'put te file in the string
      Close  'don't need it anymore
     '
      ctr = ParseCount( sFile, $CrLf ) 'get number of lines
      Local temp$()
      ReDim temp$(1 To ctr)' to hold lines
      Parse sFile, Temp$(), $CrLf 'put lines in here
    End Macro
    '
    Type Profile_Type_Info
      Sort_Field As String * 500
      Name As String * 50 'way plenty long
      Calls As Long
      Time_Used As Long
    End Type
    ' variables  
    Type Profile_Program_Info
      Longs (1 To 1000) As String * 50
      Singles (1 To 1000) As String * 50
      Doubles (1 To 1000) As String * 50
      Dwords (1 To 1000) As String * 50
      Quads (1 To 1000) As String * 50
      Functions (1 To 1000) As String * 50
      Subs (1 To 1000) As String * 50
      Bytes (1 To 1000) As String * 50
      BytePtr (1 To 1000) As String * 50
    End Type     
    '                                 
    Macro Profile_DeClutter1 'code de-clutterer makes easier readability
      s2$ = UCase$(Left$(temp$(ctr), Len(s1$)))
      If s1$ = s2$ Then
         Incr tmp
      End If 
    End Macro
    '
    Macro Profile_Remove_Win_Api_References
       Local fnum1 As Long
       fnum1 = FreeFile
    '   Open "WIN32API.INC" 
      fname$ = "C:\Power Basic\PB9\WinAPI\WIN32API.INC" 'you'll have to change this
      ErrClear
      Open fname$ For Binary As #fnum1
       ctr = Lof(#fnum1)   'how big?
      If ctr < 100 Then 'not very
         ? fname$,, "Not good WinApi location"
         Close #fnum1
         GoTo no_good
      End If                     
    '  
       sfile$ = Space$(ctr) 'make string that big
       Get #fnum1, , sfile$ 'now get the file
       Close #fnum1 'don't need it anymore
    '
       sfile$ = UCase$(sfile$) 'easier searching
       For ctr = LBound(p_Info()) To UBound(p_Info()) 
          If  p_Info(ctr).Calls < 1 Then 'not called
              n$ = " " & Trim$(UCase$(p_Info(ctr).Name)) & " "'add spaces make sure it's not embedded somewhere
              i = InStr(sfile$, n$) 'search for it
              If i Then 'in WinApi
                 p_Info(ctr).Calls = 1 'so it gets skipped in Uncalled
              End If
          End If  
       Next ctr
    ' 
    No_good:     
    End Macro
    Function Profile_Program_Variables(Prog_Name As String, p_Info() As Profile_Type_Info) As Long
       Local i, b, bp, tmp, g, l, s, d, dw, q, f, sb, fnum, ctr As Long
       Local t1, t2, sfile, fname, s1, s2 As String              
       Local pfi As  Profile_Program_Info
      fname$ = Prog_Name
      Profile_File_to_Temp_Array 'put .bas into tempR()
      For ctr = LBound(Temp$()) To UBound(temp$())   
        'clean it up
        temp$(ctr) = Trim$(Temp$(ctr))
        i = InStr(temp$(ctr), "'") 'remarks
        If i = 1 Then Iterate For 'rem line so ignore
        If i Then 'rem at end of actionable stuff so strip it off
           temp$(ctr) = Left$(temp$(ctr), i - 1)
           temp$(ctr) = Trim$(Temp$(ctr)) 'any spaces left
        End If
        
        s1$ = "FUNCTION ": tmp = f: Profile_DeClutter1 '3 statements. just easier to follow code than 3 lines
           If f <> tmp Then 'found one
              f = tmp
              pfi.functions(f) = Mid$(temp$(ctr), Len(s1$))
           End If  
    '
        s1$ = "SUB ": tmp = s: Profile_DeClutter1 '3 statements. just easier to follow code than 3 lines
           If s <> tmp Then 'found one
              s = tmp
              pfi.Subs(s) = Mid$(temp$(ctr), Len(s1$))
           End If  
        s1$ = "GLOBAL "
        s2$ = UCase$(Left$(temp$(ctr), Len(s1$)))
          If s1$ = s2$ Then 'found one
             t1$ = Mid$(temp$(ctr), Len(s1$) + 1) 'strip off beginning of line 
          End If
      Next ctr           
    '  ? Using$("f= # s=#  ", f, s ), , t1$  
    End Function
    Function Profile_Ordered(Profile_Start_Time As Long) As Long
      Local fnum, ttl_secs, Longest, ctr, i, hrs, mins, secs As Long
      Local P_info() As Profile_Type_Info
      Local sfile, temp(), Profile_FileName, PFN, fname, n, u, u1, u2 As String
      
      Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                           Exe.Name$ & _ 'Progran running name
                           "_Profile.txt" 'Add a unique identifier to it
    '
      Pfn$ = Remove$(Profile_FileName, "_Profile.txt")& ".bas" 'for use in Profile_Program_Variables later
      '
      Profile Profile_FileName 'create the file
     '
      fname$ = Profile_FileName
      Profile_File_to_Temp_Array
      
      ReDim P_info(ctr) 'get our Type ready
    '
      Longest = 20 'name format field 
      For ctr = LBound(temp$()) To UBound(temp$()) 
           p_Info(ctr).Name = Parse$(temp$(ctr), 1)
             p_Info(ctr).Name = MCase$(p_Info(ctr).Name)'cleaner looking
          If Len(Trim$(p_Info(ctr).Name)) > Longest Then
             longest = Len(Trim$(p_Info(ctr).Name))
          End If
           p_Info(ctr).Calls     = Val(Parse$(temp$(ctr), 2)) 
           p_Info(ctr).Time_Used = Val(Parse$(temp$(ctr), 3)) 
           ttl_Secs = Ttl_Secs + p_Info(ctr).Time_Used 
      Next ctr                           
    '
        Profile_Program_Variables(Pfn$, p_Info()) 'get program variables 
    '      'formatting strings
        u1$ = Space$(30) 'for header string
        u2$ = Space$(Longest) 'for procedure name
    '
        Profile_Top_Header 'Print Top of page
    '
        n$ = "Alphabetical"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = p_Info(ctr).Name 'sort by name
        Next ctr 
        Profile_Print_Array 'print results
    '   
        n$ =  "Call Frequency"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Profile_Print_Array
     '
        n$ = "Time Used"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Time_Used) & _'sort by Calls
                                   p_Info(ctr).Name
        Next ctr 
        Profile_Print_Array 
    '
        n$ =  "UnCalled For"
        'put in Alpha order
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Array Sort p_info()  
        Profile_Remove_Win_Api_References
    '''
        Reset i                
        Print #1, " " 
        Print #1, "    *** Uncalled Procedures ***"     
            pfn$ ="        *** No Uncalled *** "
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          If p_Info(ctr).Calls < 1 And _
              Asc(p_Info(ctr).Name) > 34  Then 
            Incr i
            Print #1, Using$("###) ", i) & p_Info(ctr).Name 
          End If  
        Next ctr        
        If i = 0 Then Print #1, pfn$  
    '  
    '
    '
       Print #1, " "
       Print #1,, "**** This format courtesy of many PB Programmers ****"  
      Close #1
    '
    End Function
    '**************************************************************************************************
    '**************************************************************************************************
    '**************************************************************************************************
    '***********                     End Profile_Ordered  *********************************************
    '**************************************************************************************************
    '
    Last edited by Gösta H. Lovgren-2; 16 Nov 2008, 09:55 AM.

    Leave a comment:


  • Gösta H. Lovgren-2
    replied
    Code above was changed using a UDT array, enabling the code to be MUCH cleaner and easier to follow.

    ============================================
    "We can chart our future clearly and wisely
    only when we know the path
    which has led to the present."
    Adlai E. Stevenson"
    ============================================

    Leave a comment:


  • Gösta H. Lovgren-2
    started a topic Profile Creator Function

    Profile Creator Function

    This puts a Profile in more readable order. (Lots of PB'ers contributed to this.)

    Comments here: http://www.powerbasic.com/support/pb...968#post301968

    Code:
    '
    ' Profile_Ordered
    'Reorders and reformats the file Created by the "Profile" command
    'This Output is "Willie Sutton Style" (robbed from many PB'ers)
    'Instructions to install: 
    '
    ''''Just before PBMain (outside of Functions/subs) put these 2 Macros and 1 Type
    '
    Macro Profile_Print_Array
      If InStr(n$, "Alpha") Then    
         Array Sort p_Info(), Ascend 'Names
        Else 
         Array Sort p_Info(), Descend 'Numbers so start with largest first
      End If   
      RSet u1$ = "*** " & n$ & " ***" 'sorted name
      Print #1 'blank line
      Print #1, u1$ & "        Calls         Tot ms  ms/call   % of time"
        Reset ctr
        For i = LBound(p_Info()) To UBound(p_Info()) 
           If p_Info(i).Calls > 0 Then 'no sense showing these
              Incr ctr
              RSet u2$ = Trim$(p_Info(i).Name) 'Procedure name
              Print #1,  Using$("###) ", ctr); _ 'counter
                 u2$; _     'Name
                 Using$("  ###,###,###",   p_Info(i).Calls); _ 'calls to procedure
                 Using$("  #,###,###,###", p_Info(i).Time_Used); _  'time spent there
                 Using$("  #,###.#",       p_Info(i).Time_Used / p_Info(i).Calls); _ 'avg per call
                 Using$("    ##% ",        p_Info(i).Time_Used / ttl_secs * 100) 'time spent here as part of program run
           End If 
        Next i 
    End Macro  
    '
    Macro Profile_Top_Header
      Open Profile_FileName For Output As #1
    '  
        hrs = Profile_Start_Time \ 3600
        mins = (Profile_Start_Time  - (hrs * 3600)) \ 60
        secs = (Profile_Start_Time -  (hrs * 3600)) - (mins * 60)
    '    
        Local t1, t2 As String 
          t1$ = Using$("##:##:##", hrs, mins, secs)
          t2$ = Time$
          Replace " " With "0" In t1$ '0's instead of spaces
          Replace " " With "0" In t2$ ' ""
    '      
        Print #1,, "Profile for " &  Profile_FileName 
        Print #1,, Date$ & "   Ran from " & _
                   t1$ & " to " & _
                   t2$ & _
                   Using$(" for #, seconds", Timer - Profile_Start_Time) 
        Print #1,, "(Note elapsed seconds may not agree with ms Total due "
        Print #1,, "to the different methods used to calculate each."
        Print #1,, " Especially on shorter runs - say under 2 minutes)"           
    End Macro
    '
    Type Profile_Type_Info
      Sort_Field As String * 100
      Name As String * 50 'way plenty
      Calls As Long
      Time_Used As Long
    End Type
    '
    ''''Inside PBMain the top put the next 2 lines
    '  Local Profile_Start_Time as long
    '  Profile_Start_Time = timer
    ''''At the end of PBMain put this line:
    ' Profile_Ordered(Profile_Start_Time)  'Applikashunfurstunkendun
    '
    Function Profile_Ordered(Profile_Start_Time As Long) As Long
      Local ttl_secs, Longest, ctr, i, k, del, hrs, mins, secs As Long
      Local P_info() As Profile_Type_Info
      Local sfile, Profile_FileName, n, u, u1, u2 As String
     
      Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                           Exe.Name$ & _ 'Progran running name
                           "_Profile.txt" 'Add a unique identifier to it
      '
      Profile Profile_FileName 'create the file
     '
    retry:
      Try
        Open Profile_FileName For Binary As #1 
      Catch 'Error so not ready to open yet
        Sleep 100 'take a nap
        GoTo retry 'try again
      End Try
    '  
      sFile = Space$(Lof(#1)) 'make string to hold file
      Get #1,, sFile  'put te file in the string
      Close  'don't need it anymore
     '
      ctr = ParseCount( sFile, $CrLf ) 'get number of lines
      Local temp$()
      ReDim temp$(1 To ctr)' to hold lines
      Parse sFile, Temp$(), $CrLf 'put lines in here
      ReDim P_info(ctr) 'get out Type ready
    '
       'Parse Temp$() into Type Fields
      For ctr = LBound(temp$()) To UBound(temp$()) 
           p_Info(ctr).Name = Parse$(temp$(ctr), 1)
             p_Info(ctr).Name = MCase$(p_Info(ctr).Name)'cleaner looking
           p_Info(ctr).Calls     = Val(Parse$(temp$(ctr), 2)) 
           p_Info(ctr).Time_Used = Val(Parse$(temp$(ctr), 3)) 
           ttl_Secs = Ttl_Secs + p_Info(ctr).Time_Used 
      Next ctr                           
     
    '      'formatting strings
        u1$ = Space$(30) 'for header string
        u2$ = Space$(25) 'for procedure name
    '
        Profile_Top_Header 'Print Top of page
    '
        n$ = "Alphabetical" 
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = p_Info(ctr).Name 'sort by name
        Next ctr 
        Profile_Print_Array 'print results
    '   
        n$ =  "Call Frequency"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Profile_Print_Array
     '
        n$ = "Time Used"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Time_Used) & _'sort by Calls
                                   p_Info(ctr).Name
        Next ctr 
        Profile_Print_Array 
    '
    '
        n$ =  "UnCalled For"
        'put in Alpha order
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          p_Info(ctr).Sort_Field = Using$("#########.######", p_Info(ctr).Calls) & _
                                   p_Info(ctr).Name 
        Next ctr
        Array Sort p_info()  
        Reset i                
        Print #1, " " 
        Print #1, "    *** Uncalled Procedures ***"
        For ctr = LBound(p_Info()) To UBound(p_Info()) 
          If  p_Info(ctr).Calls < 1 Then 
            Incr i
            Print #1, Using$("###) ", i) & p_Info(ctr).Name 
          End If  
        Next ctr
    '  
    '
    
       Print #1, " "
       Print #1,, "**** The format courtesy of many PB Programmers ****"  
      Close #1
    '
    End Function
    '***********/Profile_Ordered
    Last edited by Gösta H. Lovgren-2; 14 Nov 2008, 11:13 AM. Reason: Changed Header to include Starting time, formatting, ...
Working...
X