I want to share the result, perhaps it is usefull elsewehere. I hope it is bug-free but no garanties... Additions and suggestions are welcome.
Code: Select all
; ProcCrossReference.pb
; === Procedure Cross reference / dependancy examiner / Code Analysis for PureBasic=== by Al_the_dutch 20160530
; === Who makes a flow chart /html extension from this info?
; With thanx to Zebuddi123 in his "Tool Procedure sorter & dep finder 4 x platform porting incs"
; http://www.purebasic.fr/english/viewtopic.php?f=27&t=60561
EnableExplicit
Structure Statement
StatementsFile$ ; The source filename
StatementsInProc$ ; The statements in the procedure without comments
StatementsLines.l ; The associated linenumbers
EndStructure
Structure CalledBy
CalledByStatement$
CalledByFile$
CalledByType$
CalledByProcNameShort$
CalledByProcNameFull$
CalledByLine.l
EndStructure
Structure ProcList
ProcFile$ ; for handling includes
ProcName$
ProcType$ ; Procedure, Macro or FileLevel code
List ProcStatements.Statement()
EndStructure
Structure Dependancy
ProcFile$ ; for handling includes
ProcName$
Proctype$ ; Procedure, Macro or FileLevel code
Rank.l ; Number To sort
NumberCalls.l
NumberNestedCalls.l
NumberCalledBy.l
List ChainFromTop$()
List CalledBys.CalledBy()
List Calls.CalledBy()
EndStructure
Structure Calls2Rank
ProcName$
Rank.l
EndStructure
Structure SaveList
List ChainFromTop$()
EndStructure
Global NewList Proc.ProcList()
Global NewList Dependancy.Dependancy()
Global NewList StatementsInFiles.Statement()
Global NewList SourceFiles.s()
Global NewList DependancyCalls2Rank.Calls2Rank()
Global NewList UniqueCallChains$()
Procedure.l Maxl(a.l,b.l)
If a>b
ProcedureReturn a
Else
ProcedureReturn b
EndIf
EndProcedure
Procedure.s GetProcName(Statement.s, Type$) ; Statements like Procedure Abc(a,b,c) or Procedure Abc (a,b,c) or Procedure.x Abc(a,b,c)
Protected se.l, sp.l, Key$
If Type$ = "F"
ProcedureReturn "***File***"
Else
If Type$ = "M"
Key$ = "Macro"
Else
Key$ = "Procedure"
EndIf
Statement = Trim(Statement)
Statement = Trim(Mid(Statement, Len(Key$) + 1)) ; "Abc(a,b,c)" or "Abc (a,b,c)" or ".x Abc (a,b,c)"
If Left(Statement, 1) = "."
sp=FindString(Statement,(" ")) ; //3
Statement = Trim(Mid(Statement, sp)) ; "Abc(a,b,c)" or "Abc (a,b,c)" or "Abc (a,b,c)"
EndIf
se=FindString(Statement,("(")) ; 4 or 5 or 6
Statement = Left(Statement,se-1) ; "Abc" or "Abc " or "Abc "
ProcedureReturn Trim(Statement) ; "Abc"
EndIf
EndProcedure
Procedure.s GetFirstString(Statement.s)
Protected sp.l, ep.l
Statement = Trim(Statement)
sp=FindString(Statement, Chr(34)) ; a " like Include "This.pbi"
ep=FindString(Statement, Chr(34), sp+1) ; next " 1 9 18
Statement = Mid(Statement,sp+1,(ep-sp-1))
ProcedureReturn Trim(Statement)
EndProcedure
Procedure.s WithoutComments(Statement.s)
Protected Pos.l
Pos = FindString(Statement, Chr(59))
If Pos > 0
ProcedureReturn Trim(Left(Statement, Pos - 1))
Else
ProcedureReturn Trim(Statement)
EndIf
EndProcedure
Procedure.b FoundInSourceFiles(File$)
FirstElement(SourceFiles())
ForEach SourceFiles()
If SourceFiles() = File$
ProcedureReturn #True
EndIf
Next SourceFiles()
ProcedureReturn #False
EndProcedure
Procedure AllStatements2List(File$)
Protected l.i, a$, LineNr.l, NrFile.i, File2$, bNoDebugger.b, bData.b
Debug "Phase 1. AllStatements2List " + File$
NrFile = ReadFile(#PB_Any, File$)
If IsFile(NrFile)
LineNr = 0
AddElement(SourceFiles())
SourceFiles() = File$
While Not Eof(NrFile)
a$=ReadString(NrFile,ReadStringFormat(NrFile))
a$=Trim(WithoutComments(a$))
LineNr+1
If a$ = "DisableDebugger"
bNoDebugger = #True
ElseIf a$ = "EnableDebugger"
bNoDebugger = #False
EndIf
If a$ = "DataSection"
bData = #True
ElseIf a$ = "EndDataSection"
bData = #False
EndIf
If a$>"" And Left(a$,1)<>Chr(59) And Not bNoDebugger And Not bData And Left(a$, 7) <> "Declare"
AddElement(StatementsInFiles())
StatementsInFiles()\StatementsFile$ = File$
StatementsInFiles()\StatementsInProc$ = a$
StatementsInFiles()\StatementsLines = LineNr
If Left(a$,12) = "XIncludeFile" Or Left(a$,11) = "IncludeFile"
File2$ = GetFirstString(a$) ; the include file
; Scan SourceFiles() if not already done
If Not FoundInSourceFiles(File2$)
Debug "Waiting for your answer, should I add " + File2$ + "? (move debug window if necassary)"
If MessageRequester("Include file to analyze?", "Add " + File2$ + "?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_Yes
;@@2DO: IncludePath support
AllStatements2List(File2$) ; nested call to add includefile(s)
EndIf
EndIf
EndIf
EndIf
Wend
CloseFile(NrFile)
EndIf
; Debug "" + ListSize(StatementsInFiles()) + " StatementsInFiles."
EndProcedure
Procedure.s TypeRoutine(Statement$)
If Left(Statement$,10)="Procedure " Or
Left(Statement$,10)="Procedure." Or
Left(StatementsInFiles()\StatementsInProc$,6)="Macro "
ProcedureReturn Left(Statement$,1)
Else
ProcedureReturn "F" ; filelevel OR next statement within a procedure or Macro...
EndIf
EndProcedure
Procedure.b FoundProcElement(ProcFile$, ProcName$, ProcType$)
FirstElement(Proc())
ForEach Proc()
If Proc()\ProcFile$ = ProcFile$ And Proc()\ProcName$ = ProcName$ And Proc()\ProcType$ = ProcType$
ProcedureReturn #True
EndIf
Next Proc()
ProcedureReturn #False
EndProcedure
Procedure CreateOrFindProcElement(ProcFile$, ProcName$, ProcType$)
If ProcType$ = "F" And FoundProcElement(ProcFile$, "***File***", ProcType$)
ElseIf FoundProcElement(ProcFile$, ProcName$, ProcType$)
Else
AddElement(proc())
Proc()\ProcFile$ = ProcFile$
Proc()\ProcName$=ProcName$
If ProcType$ = "F"
Proc()\ProcName$ = "***File***"
EndIf
Proc()\ProcType$ = ProcType$
;Debug "TESTING Proc added: " + Proc()\ProcName$
EndIf
EndProcedure
Procedure StatemensInFiles2Procedures()
Protected Type$, OldType$ ; for Procedures, Macros or Filelevel code
Protected EndType$, Statement$, bInProcedure.b
Debug "Phase 2. StatementsInFiles2Procedures()"
With Proc()
If ListSize(StatementsInFiles())>2
ForEach StatementsInFiles()
Statement$ = Trim(StatementsInFiles()\StatementsInProc$)
; not empty, no comment or constant assigns
If Statement$ > "" And Left(Statement$,1) <> Chr(59) And Left(Statement$,1) <> Chr(35)
OldType$ = Type$
Type$ = TypeRoutine(Statement$)
If Type$ = "P"
EndType$ = "EndProcedure"
bInProcedure = #True
ElseIf Type$ = "M"
EndType$ = "EndMacro"
bInProcedure = #True
ElseIf Type$ = "F" And Not bInProcedure
EndType$ = "<EOF>"
Else
; within a procedure
Type$ = OldType$
If Statement$ = EndType$ ; EXIT procedure or macro
bInProcedure = #False
EndIf
EndIf
If OldType$ <> Type$
CreateOrFindProcElement(StatementsInFiles()\StatementsFile$, Statement$, Type$)
EndIf
AddElement(\ProcStatements())
\ProcStatements()\StatementsInProc$ =Statement$
\ProcStatements()\StatementsLines = StatementsInFiles()\StatementsLines
If Not bInProcedure ; Two Procedure or macros behind each other need a reset of Type$
Type$ = ""
EndIf
EndIf
Next StatementsInFiles()
EndIf ; listsize
EndWith
; Debug "TESTING Proc-listing ===================================================="
; ForEach Proc()
; Debug " ProcFile$, ProcName$, ProcType$ " + Proc()\ProcFile$ +"\"+ Proc()\ProcName$ +"\"+ Proc()\ProcType$
; ForEach Proc()\ProcStatements()
; Debug Proc()\ProcStatements()\StatementsFile$ + "\\line:\\" +
; Proc()\ProcStatements()\StatementsLines + "\\stat:\\" +
; Proc()\ProcStatements()\StatementsInProc$
; Next Proc()\ProcStatements()
; Next Proc()
; End ; enditall
; Debug "END TESTING Proc-listing ===================================================="
EndProcedure
Procedure.s NoStrings(Statement$)
Protected i.l, L$, Return$, InString.b
For i = 1 To Len(Statement$)
L$ = Mid(Statement$, i,1)
If L$ = Chr(34) ; dwz "
If InString
InString = #False
Else
InString = #True
EndIf
EndIf
If Not InString And L$ <> Chr(34)
Return$ + L$
EndIf
Next i
ProcedureReturn Return$
EndProcedure
Procedure Statement2RealWords(Statement$, List Words.s()) ; not words within strings ; statement already trimmed.
Protected Word$, i.l, L$
; A Statement like 'Debug("MyProcedureABC " + MyProcedureABC("ABC DEF") + Shit())' should give the 3 Words
; Debug
; MyProcedureABC (2e)
; Shit
; Debug "Statement was " + Statement$
Statement$ = NoStrings(Statement$) ; ==> Debug+MyProcedureABC+Shit
; Debug "Statement became " + Statement$
For i = 1 To Len(Statement$)
L$ = Mid(Statement$, i, 1)
If L$ = " " Or L$ = "+" Or L$ = "-" Or L$ = "*" Or L$ = "/" Or L$ = "(" Or L$ = ","; Word seprators
Word$ = Trim(Word$)
If Len(Word$) > 0
AddElement(Words())
Words() = Word$
Word$ = ""
EndIf
ElseIf L$ <> ")"
Word$ + L$
EndIf
Next i
EndProcedure
Procedure.b CreateOrFindDependancyListElement(ProcName$, Make.b = #True, Rank = 0)
FirstElement(Dependancy())
ForEach Dependancy()
If UCase(Dependancy()\ProcName$) = UCase(ProcName$) Or (Rank > 0 And Dependancy()\Rank = Rank)
ProcedureReturn #False
EndIf
Next Dependancy()
If Make
AddElement(Dependancy())
ProcedureReturn #True ; Created
Else
Debug "*****************************************CreateOrFindDependancyListElement did not find " + ProcName$
EndIf
EndProcedure
Procedure Dependencies()
Protected NrLine.l, CallingProc$, CalledByPos.l, CallingPos.l
Protected T1$, T2$ ; debug
Debug "Phase 3. Dependencies for " + ListSize(Proc()) + " procedures/macros."
NewList ProcCopy.ProcList()
CopyList(Proc(), ProcCopy())
FirstElement(ProcCopy())
ForEach ProcCopy()
CallingProc$ = GetProcName(ProcCopy()\ProcName$, ProcCopy()\ProcType$)
If Trim(CallingProc$) = "" Or FindString(CallingProc$, ",") > 0
Debug "1. WRONG! " + CallingProc$
EndIf
If CreateOrFindDependancyListElement(CallingProc$)
Dependancy()\ProcName$ = CallingProc$
;Debug "I. TESTING Dependancy #" + ListSize(Dependancy()) + " created With name " + Dependancy()\ProcName$ + " from " + ProcCopy()\ProcFile$
EndIf
Dependancy()\ProcFile$ = ProcCopy()\ProcFile$
Dependancy()\Proctype$ = ProcCopy()\Proctype$
CalledByPos = ListIndex(Dependancy())
FirstElement(Proc())
ForEach Proc() ; loop through the code lines in the procs to search for calls
NrLine = 0
ForEach Proc()\ProcStatements()
NrLine+1
If NrLine = 1
CallingProc$ = GetProcName(Proc()\ProcStatements()\StatementsInProc$, Proc()\ProcType$)
If Trim(CallingProc$) = "" Or FindString(CallingProc$, ",") > 0
Debug "2. WRONG! " + CallingProc$
EndIf
If CreateOrFindDependancyListElement(CallingProc$)
Dependancy()\ProcName$ = CallingProc$
;Debug "II. TESTING Dependancy #" + ListSize(Dependancy()) + " created With name " + Dependancy()\ProcName$ + " from " + Proc()\ProcFile$
EndIf
CallingPos = ListIndex(Dependancy())
EndIf
SelectElement(Dependancy(), CalledByPos)
T1$ = Proc()\ProcStatements()\StatementsInProc$
T2$ = Dependancy()\ProcName$
If NrLine > 1 And FindString(UCase(T1$), UCase(T2$)) ; not its own but nested calls will be added
; Whole word has to be exact the same and not within strings
; like A_MyRoutine = 1 should not be added as a dependancy of MyRoutine
; like MyRoutineABC = 1 should not be added as a dependancy of MyRoutine
; like Debug( "MyRoutine") should not be added as a dependancy of MyRoutine
NewList Words.s() ; reset
Statement2RealWords(Proc()\ProcStatements()\StatementsInProc$, Words()) ; not words within strings etc
ForEach Words()
If UCase(Words()) = UCase(Dependancy()\ProcName$) Or UCase(Words()) = "@" + UCase(Dependancy()\ProcName$)
AddElement(Dependancy()\CalledBys())
Dependancy()\CalledBys()\CalledByFile$ = Proc()\ProcFile$
Dependancy()\CalledBys()\CalledByProcNameFull$ = Proc()\ProcName$
Dependancy()\CalledBys()\CalledByProcNameShort$ = GetProcName(Proc()\ProcName$, Proc()\ProcType$)
Dependancy()\CalledBys()\CalledByType$ = Proc()\Proctype$
Dependancy()\CalledBys()\CalledByLine = Proc()\ProcStatements()\StatementsLines
Dependancy()\CalledBys()\CalledByStatement$ = Proc()\ProcStatements()\StatementsInProc$
SelectElement(Dependancy(), CallingPos)
AddElement(Dependancy()\Calls())
Dependancy()\Calls()\CalledByFile$ = ProcCopy()\ProcFile$
Dependancy()\Calls()\CalledByProcNameFull$ = ProcCopy()\ProcName$
Dependancy()\Calls()\CalledByProcNameShort$ = GetProcName(ProcCopy()\ProcName$, ProcCopy()\ProcType$)
Dependancy()\Calls()\CalledByType$ = ProcCopy()\ProcType$
;Proc() and not ProcCopy()!
Dependancy()\Calls()\CalledByLine = Proc()\ProcStatements()\StatementsLines
Dependancy()\Calls()\CalledByStatement$ = Proc()\ProcStatements()\StatementsInProc$
EndIf
Next Words()
EndIf
Next Proc()\ProcStatements()
Next Proc()
; If Mod(ListIndex(ProcCopy()), 10) = 0
; Debug "Progress in Dependancies " + ListIndex(ProcCopy())+ "/" +ListSize(ProcCopy())
; EndIf
Next ProcCopy()
EndProcedure
Procedure UpdateDependancyCalls2Rank(ProcName$, Rank.l)
; Only Non existing CalledByProcNameShort$ With Rank+1.
; Update existing CalledByProcNameShort$ With lower Rank
Protected bFound.b
FirstElement(DependancyCalls2Rank())
ForEach DependancyCalls2Rank()
If DependancyCalls2Rank()\ProcName$ = ProcName$ ; already existing item
If bFound ; already earlier found
DeleteElement(DependancyCalls2Rank())
Debug DependancyCalls2Rank()\ProcName$ + " Redundant Item of DependancyCalls2Rank Deleted."
Else
bFound = #True
DependancyCalls2Rank()\Rank = Maxl(DependancyCalls2Rank()\Rank, Rank)
; Debug DependancyCalls2Rank()\ProcName$ + " Item of DependancyCalls2Rank Updated to Rank " +
; DependancyCalls2Rank()\Rank
EndIf
EndIf
Next DependancyCalls2Rank()
If Not bFound
AddElement(DependancyCalls2Rank())
DependancyCalls2Rank()\ProcName$ = ProcName$
DependancyCalls2Rank()\Rank = Rank
; Debug "2. DependancyCalls2Rank added " + DependancyCalls2Rank()\ProcName$ + " with Rank " + DependancyCalls2Rank()\Rank
EndIf
EndProcedure
Procedure.l RankFirstCalledDependancys(Rank.l)
Protected Number.l, Position1.l, Position2.l
Position1 = ListIndex(Dependancy())
ForEach Dependancy()\Calls()
Position2 = ListIndex(Dependancy()\Calls())
CreateOrFindDependancyListElement(Dependancy()\Calls()\CalledByProcNameShort$, #False) ; only find
Dependancy()\Rank = Maxl(Rank, Dependancy()\Rank)
Debug Dependancy()\ProcName$ + " Dependancy()\Rank := " + Dependancy()\Rank
Number+1
If Dependancy()\NumberCalls > 0
FirstElement(Dependancy()\Calls())
ForEach Dependancy()\Calls()
UpdateDependancyCalls2Rank(Dependancy()\Calls()\CalledByProcNameShort$, Rank+1)
; Debug "1. DependancyCalls2Rank added " + DependancyCalls2Rank()\ProcName$ + " with Rank " + DependancyCalls2Rank()\Rank
Next Dependancy()\Calls()
EndIf
SelectElement(Dependancy(), Position1)
SelectElement(Dependancy()\Calls(), Position2) ; to be sure
Next Dependancy()\Calls()
ProcedureReturn Number
EndProcedure
Procedure RankProcedures()
Protected Rank.l, Position.l
Debug "Phase 4. RankProcedures"
FirstElement(Dependancy())
ForEach Dependancy()
Dependancy()\NumberCalledBy = ListSize(Dependancy()\CalledBys())
Dependancy()\NumberCalls = ListSize(Dependancy()\Calls())
Next Dependancy()
FirstElement(Dependancy())
ForEach Dependancy()
If Dependancy()\Proctype$ = "F" And Dependancy()\NumberCalls > 0
Rank = 0
Dependancy()\Rank = Rank
RankFirstCalledDependancys(Rank+1)
EndIf
Next Dependancy()
While ListSize(DependancyCalls2Rank()) > 0
Debug "Ranking start loop with elements: " + ListSize(DependancyCalls2Rank())
FirstElement(DependancyCalls2Rank())
ForEach DependancyCalls2Rank()
Rank = DependancyCalls2Rank()\Rank
; Debug DependancyCalls2Rank()\ProcName$ + " Rank " + Rank + " DependancyCalls2Rank size" +
; ListSize(DependancyCalls2Rank()) + " Index: " + ListIndex(DependancyCalls2Rank())
CreateOrFindDependancyListElement(DependancyCalls2Rank()\ProcName$, #False)
Dependancy()\Rank = Maxl(Rank, Dependancy()\Rank)
; Debug Dependancy()\ProcName$ + " Dependancy()\Rank ==> " + Dependancy()\Rank
FirstElement(Dependancy()\Calls())
ForEach Dependancy()\Calls()
If UCase(Dependancy()\Calls()\CalledByProcNameShort$) = UCase(DependancyCalls2Rank()\ProcName$)
; Nested Call no ranking (eternal loop)
Debug "No Ranking for Nested Call in " + DependancyCalls2Rank()\ProcName$
Else
Position = ListIndex(DependancyCalls2Rank())
UpdateDependancyCalls2Rank(Dependancy()\Calls()\CalledByProcNameShort$, Rank+1)
SelectElement(DependancyCalls2Rank(), Position)
EndIf
Next Dependancy()\Calls()
DeleteElement(DependancyCalls2Rank())
Next DependancyCalls2Rank()
Wend
EndProcedure
Procedure FillDependenciesChainFromTop(Chain$) ; This proces is dependant of the right ranking (Dependancy is sorted on rank)
Static RankDebug.l
Protected Pos1.l, Pos2.l, Pos3.l
NewList CallChain$() ; of only 1 dependancy(), the last element Chain$, in 1e call the main procedure
Static NewList CallChainNextLevel.SaveList() ; of only 1 dependancy() further in the chain
If Dependancy()\NumberCalls > 0
Pos1 = ListIndex(Dependancy())
ForEach Dependancy()\Calls() ; of Chain$
Pos2 = ListIndex(Dependancy()\Calls())
If Dependancy()\Calls()\CalledByProcNameShort$ <> Dependancy()\ProcName$ ; non nested calls
AddElement(CallChain$())
CallChain$() = Chain$ + ";" + Dependancy()\Calls()\CalledByProcNameShort$
CreateOrFindDependancyListElement(Dependancy()\Calls()\CalledByProcNameShort$)
If Dependancy()\NumberCalls - Dependancy()\NumberNestedCalls = 0 And Right(CallChain$(),1) <> "."
CallChain$() + "."
EndIf
AddElement(CallChainNextLevel())
Pos3 = ListIndex(CallChainNextLevel())
; Debug "FillDependenciesChainFromTop before nested call with # " + ListSize(CallChain$()) + " CallChain: " +
; CallChain$() + " Position "+ Pos3
CopyList(CallChain$(), CallChainNextLevel()\ChainFromTop$()) ; CallChainNextLevel$ is static so can be given to the nested call
FillDependenciesChainFromTop(CallChain$()) ; Nested call!!
SelectElement(CallChainNextLevel(), Pos3)
CopyList(CallChainNextLevel()\ChainFromTop$(), CallChain$()) ; Take it over
; DeleteElement(CallChainNextLevel())
; Debug "FillDependenciesChainFromTop after nested call with # " + ListSize(CallChain$()) + " CallChain: " +
; CallChain$() + " Position "+ Pos3
Else
Debug "Nested call not in (endless) chain: " + Dependancy()\ProcName$
Dependancy()\NumberNestedCalls+1
If Dependancy()\NumberCalls - Dependancy()\NumberNestedCalls = 0
If ListSize(CallChain$()) > 0
If Right(CallChain$(),1) <> "."
CallChain$() + "."
EndIf
Else
If Right(Chain$,1) <> "."
Chain$ + "."
EndIf
EndIf
EndIf ; Last element in chain?
EndIf ; nested call?
SelectElement(Dependancy(), Pos1)
SelectElement(Dependancy()\Calls(), Pos2)
Next Dependancy()\Calls()
EndIf
If ListSize(CallChain$()) > 0 ; Ready; save list to our Dependancy
;Testing
; Debug Dependancy()\ProcName$ + "'s ChainFromTop$ is being filled with"
; ForEach CallChain$()
; Debug "- " + CallChain$()
; Next CallChain$()
CopyList(CallChain$(), Dependancy()\ChainFromTop$())
ClearList(CallChain$())
Else
;Testing
; Debug Dependancy()\ProcName$ + "'s ChainFromTop$ is being filled with "
If Right(Chain$,1) <> "."
Chain$ + "."
EndIf
; Debug "* " + Chain$
AddElement(Dependancy()\ChainFromTop$())
Dependancy()\ChainFromTop$() = Chain$
EndIf
; If Dependancy()\Rank > RankDebug
; Debug "Progress in FillDependenciesChainFromTop " + Dependancy()\Rank
; RankDebug = Dependancy()\Rank
; EndIf
EndProcedure
; Procedure.s SeekCompleteChain()
; ; Dependancy()\ChainFromTop$() is not complete; with multiple calls and different chains this might be buggy
;
; Protected LastProc$, Chain$, ChainOld$
;
; Chain$ = Dependancy()\ChainFromTop$()
; Debug "SeekCompleteChain$ for " + Chain$
;
; While Right(Chain$,1) <> "." And ChainOld$ <> Chain$; Found none
; ChainOld$ = Chain$
; LastProc$ = ReverseString(StringField(ReverseString(Chain$), 1, ";"))
; CreateOrFindDependancyListElement(LastProc$, #False)
;
; ForEach Dependancy()\ChainFromTop$()
; If Left(Dependancy()\ChainFromTop$(), Len(Chain$)) = Chain$
; Chain$ = Dependancy()\ChainFromTop$()
; If Right(Chain$,1) = "." ; Found one
; Debug "SeekCompleteChain$ found " + Chain$
; Break 2
; Else
; Debug "SeekCompleteChain$ found non complete " + Chain$
; EndIf
; EndIf
; Next Dependancy()\ChainFromTop$()
; Wend
;
; If Right(Chain$,1) <> "."
; Chain$ + "@"
; EndIf
;
;
; ProcedureReturn Chain$
;
; EndProcedure
; Procedure AddChainInfo()
;
; ; The chains that do not end with a "." are not complete. This procedure adds the rest of the chains
;
; Protected Pos1.l, Pos2.l, Chain$
;
; ForEach Dependancy()
; Pos1 = ListIndex(Dependancy())
; ForEach Dependancy()\ChainFromTop$()
; If Right(Dependancy()\ChainFromTop$(),1) <> "."
; Pos2 = ListIndex(Dependancy()\ChainFromTop$())
; ;Seek remaining info
; Chain$ = SeekCompleteChain()
; ;return to original position
; SelectElement(Dependancy(), Pos1)
; SelectElement(Dependancy()\ChainFromTop$(), Pos2)
; Dependancy()\ChainFromTop$() = Chain$
; EndIf
; Next Dependancy()\ChainFromTop$()
; Next Dependancy()
;
;
; EndProcedure
Procedure BuildUniqueCallChains()
Protected Chain$
ForEach Dependancy()
ForEach Dependancy()\ChainFromTop$()
If Right(Dependancy()\ChainFromTop$(),1) = "."
AddElement(UniqueCallChains$())
UniqueCallChains$() = Dependancy()\ChainFromTop$()
EndIf
Next Dependancy()\ChainFromTop$()
Next Dependancy()
SortList(UniqueCallChains$(), #PB_Sort_Ascending)
ForEach UniqueCallChains$()
If UniqueCallChains$() = Chain$
DeleteElement(UniqueCallChains$())
EndIf
Chain$ = UniqueCallChains$()
Next UniqueCallChains$()
EndProcedure
Procedure ShowInfo(NrDep.l)
SelectElement(Dependancy(), NrDep-1)
If OpenWindow(1, 0, 0, 800, 400, "Info of procedure " +
Dependancy()\ProcName$, #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
ListViewGadget(0, 10, 10, 780, 380)
AddGadgetItem (0, -1, "Called By " + Dependancy()\NumberCalledBy)
NrDep = 0
ForEach Dependancy()\CalledBys()
NrDep+1
AddGadgetItem (0, -1, "CB-" + Str(NrDep) + Dependancy()\CalledBys()\CalledByFile$ + ":" +
Dependancy()\CalledBys()\CalledByProcNameShort$) ; define listview content
Next Dependancy()\CalledBys()
AddGadgetItem (0, -1, "Calling " + Dependancy()\NumberCalls)
NrDep = 0
ForEach Dependancy()\Calls()
NrDep+1
AddGadgetItem (0, -1, "CA-" + Str(NrDep) + Dependancy()\Calls()\CalledByFile$ + ":" +
Dependancy()\Calls()\CalledByProcNameShort$) ; define listview content
Next Dependancy()\Calls()
AddGadgetItem (0, -1, "Calling trees")
ForEach UniqueCallChains$()
If FindString(UniqueCallChains$(), ";"+ Dependancy()\ProcName$ + ";") > 0 Or
FindString(UniqueCallChains$(), ";"+ Dependancy()\ProcName$ + ".") > 0 Or
FindString(UniqueCallChains$(), Dependancy()\ProcName$ + ";") = 1
AddGadgetItem (0, -1, UniqueCallChains$())
EndIf
Next UniqueCallChains$()
Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
CloseWindow(1)
EndIf
EndProcedure
Procedure Main()
Protected f$, NrDep.l, Text$, MainProc$
Protected Event.l, Quit.l
f$=OpenFileRequester("Select A .pb Source File","*.pb","PureBasic (*.pb)|*.pb",1)
If f$
AllStatements2List(f$) ; process file(s) to a linked list with only code lines
StatemensInFiles2Procedures() ; process lines into procedures
Dependencies() ; examine dependencies (called by)
RankProcedures() ; rank the procedures
;SortStructuredList(Proc(), #PB_Sort_Ascending, OffsetOf(ProcList\ProcName$) ,TypeOf(ProcList\ProcName$))
SortStructuredList(Dependancy(), #PB_Sort_Ascending, OffsetOf(Dependancy\Rank) ,TypeOf(Dependancy\Rank))
CreateOrFindDependancyListElement("", #False, 1)
If Dependancy()\Rank = 1
MainProc$ = Dependancy()\ProcName$
Debug "Main procedure found: " + MainProc$
Debug "Phase 5: FillDependenciesChainFromTop called with " + MainProc$
FillDependenciesChainFromTop(MainProc$)
; buggy, lets make FillDependenciesChainFromTop better so we don't need AddChainInfo()
Debug "Phase 6: Building unique call-chains."
BuildUniqueCallChains()
Else
Debug "No main procedure (rank 1) was found so no chain-building"
EndIf
Debug "========================================================================="
Debug "TESTING List of called Dependencies with full info ======================"
Debug "========================================================================="
ForEach Dependancy()
If Dependancy()\NumberCalledBy > 0 Or Dependancy()\Proctype$ = "F" Or Dependancy()\Rank = 0
If Dependancy()\Rank = 0 And Dependancy()\Proctype$ <> "F"
Debug Dependancy()\ProcName$ + " : does not seem to be used"
Else
Text$ = Str(Dependancy()\Rank) + "." + Dependancy()\ProcName$ + " is called by " +
Dependancy()\NumberCalledBy + " and is calling " + Dependancy()\NumberCalls +
"-" + Dependancy()\NumberNestedCalls +" :"
Debug RSet("", Len(Text$), "=")
Debug Text$
Debug RSet("", Len(Text$), "=")
NrDep = 0
ForEach Dependancy()\CalledBys()
NrDep+1
Debug "CB- " + NrDep + ". " + Dependancy()\CalledBys()\CalledByFile$ +" //type:// "+
Dependancy()\CalledBys()\CalledByType$ + " //proc:// "+
Dependancy()\CalledBys()\CalledByProcNameShort$ + " //full:// "+
Dependancy()\CalledBys()\CalledByProcNameFull$ + " //line:// "+
Dependancy()\CalledBys()\CalledByLine + " //stat:// "+
Dependancy()\CalledBys()\CalledByStatement$
Next Dependancy()\CalledBys()
NrDep = 0
ForEach Dependancy()\Calls()
NrDep+1
Debug "CA- " + NrDep + ". " + Dependancy()\Calls()\CalledByFile$ +" //type:// "+
Dependancy()\Calls()\CalledByType$ + " //proc:// "+
Dependancy()\Calls()\CalledByProcNameShort$ + " //full:// "+
Dependancy()\Calls()\CalledByProcNameFull$ + " //line:// "+
Dependancy()\Calls()\CalledByLine + " //stat:// "+
Dependancy()\Calls()\CalledByStatement$
Next Dependancy()\Calls()
EndIf
EndIf
Next Dependancy()
Debug "==========================================================================="
; Debug "TESTING List of Dependencies with basic calling info ======================"
; Debug "==========================================================================="
;
; ForEach Dependancy()
; If Dependancy()\NumberCalls > 0
; Debug Str(Dependancy()\Rank) + "." + Dependancy()\ProcName$ + " is calling"
; Else
; Debug Str(Dependancy()\Rank) + "." + Dependancy()\ProcName$ + " is the end of a line"
; EndIf
;
; NrDep = 0
; ForEach Dependancy()\Calls()
; NrDep+1
; Debug "- " + NrDep + ". " + Dependancy()\Calls()\CalledByFile$ +" //type:// "+
; Dependancy()\Calls()\CalledByType$ + " //proc:// "+
; Dependancy()\Calls()\CalledByProcNameShort$ + " //stat:// "+
; Dependancy()\Calls()\CalledByStatement$
; Next Dependancy()\Calls()
; Next Dependancy()
Debug "==========================================================================="
Debug "TESTING List of called Dependencies without calling info =================="
Debug "==========================================================================="
ForEach Dependancy()
If Dependancy()\NumberCalledBy > 0 Or Dependancy()\Proctype$ = "F" Or Dependancy()\Rank > 0
If Dependancy()\Rank = 0 And Dependancy()\Proctype$ <> "F"
Debug Dependancy()\ProcName$ + " : does not seem to be used"
Else
Debug Str(Dependancy()\Rank) + "." + Dependancy()\ProcName$ + " is calling " + Dependancy()\NumberCalls +
" - " + Dependancy()\NumberNestedCalls +" :"
EndIf
EndIf
Next Dependancy()
; Debug "==========================================================================="
; Debug "TESTING List of calling chaines"
; Debug "==========================================================================="
;
; ForEach Dependancy()
; If Dependancy()\Rank > 0
; Text$ = Str(Dependancy()\Rank) + "." + Dependancy()\ProcName$ + " has calling chains: "
; Debug RSet("", Len(Text$), "=")
; Debug Text$
; Debug RSet("", Len(Text$), "=")
;
; ForEach Dependancy()\ChainFromTop$()
; Debug Dependancy()\ChainFromTop$()
; Next Dependancy()\ChainFromTop$()
; EndIf
; Next Dependancy()
Debug "==========================================================================="
Debug "TESTING List of unique calling chaines (" + ListSize(UniqueCallChains$()) + ")"
Debug "==========================================================================="
NrDep = 0
ForEach UniqueCallChains$()
NrDep+1
Debug Str(NrDep) + ". " + UniqueCallChains$()
Next UniqueCallChains$()
Debug ""
Debug "Finished."
Debug "Saving debug info to " + f$ + "-CR.txt"
SaveDebugOutput(f$ + "-CR.txt")
SortStructuredList(Dependancy(), #PB_Sort_Ascending, OffsetOf(Dependancy\ProcName$) ,TypeOf(Dependancy\ProcName$))
If OpenWindow(0, 200, 200, 400, 400, "Select procedure")
If CreateMenu(0, WindowID(0)) ; menu creation starts....
MenuTitle("Procedure")
NrDep = 0
ForEach Dependancy()
NrDep+1
MenuItem(NrDep, Dependancy()\ProcName$)
Next Dependancy()
Repeat
; Event = WindowEvent()
; Delay(5) ; for other programs, don't eat all CPU time
Event = WaitWindowEvent()
Select Event
Case #PB_Event_Menu
NrDep = EventMenu()
ShowInfo(NrDep)
Case #PB_Event_CloseWindow
Quit = 1
EndSelect ; Event
Until Quit > 0
EndIf ; CreateMenu
EndIf ; OpenWindow
EndIf ;File
EndProcedure
Main()
End
