paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-10-31 16:02:33 +01:00
Code Issues Packages Projects Releases Wiki Activity
3667bb992a
lazarus/components/codetools/finddeclarationcache.pas
juha e800a738ad Copy AVL_Tree from FPC trunk and replace classes in AvgLvlTree and in CodetoolsStructs with it. 
The unit in FPC packages will be used directly later.

git-svn-id: trunk@54524 -
2017-04-05 08:34:48 +00:00

1377 lines
40 KiB
ObjectPascal
Raw Blame History

{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Cache objects for TFindDeclarationTool.
}
unit FindDeclarationCache;
{$mode objfpc}{$H+}
interface
{$I codetools.inc}
// for debugging
{ $DEFINE HardExceptions}
uses
Classes, SysUtils, Laz_AVL_Tree,
// Codetools
FileProcs, BasicCodeTools, CodeTree, LinkScanner,
PascalParserTool, KeywordFuncLists, CodeToolMemManager;
type
{
1. interface cache: (unit interfaces, not class interfaces)
Every FindIdentifierInInterface call is cached
- stores: Identifier -> Node+CleanPos
- cache must be deleted, everytime the codetree is rebuilt
this is enough update, because it does only store internals
-> This improves search time for interface requests
}
PInterfaceIdentCacheEntry = ^TInterfaceIdentCacheEntry;
TInterfaceIdentCacheEntry = record
Identifier: PChar;
Node: TCodeTreeNode; // if node = nil then identifier does not exist in
// this interface
CleanPos: integer;
Overloaded: PInterfaceIdentCacheEntry;
NextEntry: PInterfaceIdentCacheEntry; // used by memory manager
end;
{ TInterfaceIdentifierCache }
TInterfaceIdentifierCache = class
private
FComplete: boolean;
FItems: TAVLTree; // tree of PInterfaceIdentCacheEntry
FTool: TPascalParserTool;
function FindAVLNode(Identifier: PChar): TAVLTreeNode;
procedure SetComplete(const AValue: boolean);
public
function FindIdentifier(Identifier: PChar): PInterfaceIdentCacheEntry;
procedure Add(Identifier: PChar; Node: TCodeTreeNode; CleanPos: integer);
procedure Clear;
procedure ClearMissingIdentifiers;
constructor Create(ATool: TPascalParserTool);
destructor Destroy; override;
procedure ConsistencyCheck;
property Tool: TPascalParserTool read FTool;
property Complete: boolean read FComplete write SetComplete;
property Items: TAVLTree read FItems; // Tree of PInterfaceIdentCacheEntry
function CalcMemSize: PtrUInt;
end;
{
2. code tree node cache:
Some nodes (class, proc, record) contain a node cache. A node cache caches
search results of searched identifiers for child nodes.
Every entry in the node cache describes the following relationship:
Identifier+Range -> Source Position
and can be interpreted as:
Identifier is a PChar to the beginning of an identifier string.
Range is a cleaned source range (CleanStartPos-CleanEndPos).
Source position is a tuple of NewTool, NewNode, NewCleanPos.
If the current context node is a child of a caching node and it is in the
range, then the result is valid. If NewNode=nil then there is no such
identifier valid at the context node.
Every node that defines local identifiers contains a node cache.
These are: class, interface, proc, record, withstatement
Because node caches can store information of used units, the cache must be
deleted every time a used unit is changed.
}
const
AllNodeCacheDescs =
AllClasses+[ctnProcedure, ctnWithVariable];
type
TNodeCacheEntryFlag = (ncefSearchedInParents, ncefSearchedInAncestors);
TNodeCacheEntryFlags = set of TNodeCacheEntryFlag;
PCodeTreeNodeCacheEntry = ^TCodeTreeNodeCacheEntry;
TCodeTreeNodeCacheEntry = record
Identifier: PChar;
CleanStartPos: integer;
CleanEndPos: integer;
NewNode: TCodeTreeNode;
NewTool: TPascalParserTool;
NewCleanPos: integer;
Flags: TNodeCacheEntryFlags;
NextEntry: PCodeTreeNodeCacheEntry; // used for mem manager
end;
{ TCodeTreeNodeCache }
TCodeTreeNodeCache = class
private
FItems: TAVLTree; // tree of PCodeTreeNodeCacheEntry
public
Next: TCodeTreeNodeCache;
Owner: TCodeTreeNode;
function FindLeftMostAVLNode(Identifier: PChar): TAVLTreeNode;
function FindRightMostAVLNode(Identifier: PChar): TAVLTreeNode;
function FindAVLNode(Identifier: PChar; CleanPos: integer): TAVLTreeNode;
function FindAVLNodeInRange(Identifier: PChar;
CleanStartPos, CleanEndPos: integer): TAVLTreeNode;
function FindInRange(Identifier: PChar;
CleanStartPos, CleanEndPos: integer): PCodeTreeNodeCacheEntry;
function FindNearestAVLNode(Identifier: PChar;
CleanStartPos, CleanEndPos: integer; {%H-}InFront: boolean): TAVLTreeNode;
function FindNearest(Identifier: PChar;
CleanStartPos, CleanEndPos: integer;
InFront: boolean): PCodeTreeNodeCacheEntry;
function Find(Identifier: PChar): PCodeTreeNodeCacheEntry;
procedure Add(Identifier: PChar;
SrcTool: TPascalParserTool; CleanStartPos, CleanEndPos: integer;
NewNode: TCodeTreeNode; NewTool: TPascalParserTool; NewCleanPos: integer;
Flags: TNodeCacheEntryFlags);
procedure Clear;
procedure BindToOwner(NewOwner: TCodeTreeNode);
procedure UnbindFromOwner;
constructor Create(AnOwner: TCodeTreeNode);
destructor Destroy; override;
procedure WriteDebugReport(const Prefix: string);
procedure ConsistencyCheck;
function CalcMemSize: PtrUInt;
end;
{
3. Base type node cache
All nodes, that are aliases, has this type of cache.
For example a variable 'i: integer' creates several basetype nodes:
1. i variable node points to its type node 'integer'.
2. 'integer' node points to type definition node 'integer'.
3. 'integer' identifier node points to its base type 'longint'.
4. 'longint' identifier node points points to its range.
FindBaseTypeOfNode will search this chain, and on success will create
TBaseTypeCache(s). The All four nodes will point directly to the range.
}
{ TBaseTypeCache }
TBaseTypeCache = class
private
public
BaseNode: TCodeTreeNode; // final base type
BaseTool: TPascalParserTool;
NextNode: TCodeTreeNode; // next node on path to the BaseNode
NextTool: TPascalParserTool;
NextCache: TBaseTypeCache; // used for mem manager
Owner: TCodeTreeNode;
procedure BindToOwner(NewOwner: TCodeTreeNode);
procedure UnbindFromOwner;
constructor Create(AnOwner: TCodeTreeNode);
destructor Destroy; override;
function CalcMemSize: PtrUInt;
end;
{
4. CodeTool Cache Dependencies
Node- and BaseTypeCache depends on their codetool and the
node- and basetypecaches of other codetools (=used codetools). The used
codetools dependencies are saved in the TCodeToolDependencies, which is
simply an TAVLTree of codetools. This allows one to decide, wether the cache of
a codetools must be rebuilt.
}
//----------------------------------------------------------------------------
type
{ TGlobalIdentifierTree }
TGlobalIdentifierTree = class
private
FItems: TAVLTree; // tree of PChar;
FDefaultDataBlockSize: integer;
FDataBlockSize: integer;
FDataBlock: Pointer;
FDataBlockEnd: integer;
FFullDataBlocks: TFPList; // full blocks of data
function InternalGetMem(Size: integer): Pointer;
public
function AddCopy(Identifier: PChar): PChar;
function Find(Identifier: PChar): PChar;
procedure Clear;
constructor Create;
destructor Destroy; override;
function Count: integer;
function CalcMemSize: PtrUInt;
end;
//----------------------------------------------------------------------------
// Memory Managers
// memory system for PInterfaceIdentCacheEntry(s)
TInterfaceIdentCacheEntryMemManager = class(TCodeToolMemManager)
protected
procedure FreeFirstItem; override;
public
procedure DisposeEntry(Entry: PInterfaceIdentCacheEntry);
function NewEntry: PInterfaceIdentCacheEntry;
end;
// memory system for PCodeTreeNodeCacheEntry(s)
TNodeCacheEntryMemManager = class(TCodeToolMemManager)
protected
procedure FreeFirstItem; override;
public
procedure DisposeEntry(Entry: PCodeTreeNodeCacheEntry);
function NewEntry: PCodeTreeNodeCacheEntry;
end;
// memory system for TCodeTreeNodeCache(s)
TNodeCacheMemManager = class(TCodeToolMemManager)
protected
procedure FreeFirstItem; override;
public
procedure DisposeNodeCache(NodeCache: TCodeTreeNodeCache);
function NewNodeCache(AnOwner: TCodeTreeNode): TCodeTreeNodeCache;
end;
// memory system for TBaseTypeCache(s)
TBaseTypeCacheMemManager = class(TCodeToolMemManager)
protected
procedure FreeFirstItem; override;
public
procedure DisposeBaseTypeCache(BaseTypeCache: TBaseTypeCache);
function NewBaseTypeCache(AnOwner: TCodeTreeNode): TBaseTypeCache;
end;
//----------------------------------------------------------------------------
// stacks for cycle checking
const
CodeTreeNodeFixedItemCount = 12;
type
TCodeTreeNodeStackEntry = record
Tool: TPascalParserTool;
Node: TCodeTreeNode;
end;
PCodeTreeNodeStackEntry = ^TCodeTreeNodeStackEntry;
TCodeTreeNodeStack = record
FixedItems: array[0..CodeTreeNodeFixedItemCount-1] of TCodeTreeNodeStackEntry;
DynItems: PCodeTreeNodeStackEntry;
StackPtr: integer;
Capacity: integer; // size of DynItems in entries
end;
PCodeTreeNodeStack = ^TCodeTreeNodeStack;
procedure InitializeNodeStack(NodeStack: PCodeTreeNodeStack);
function GetNodeStackEntry(NodeStack: PCodeTreeNodeStack;
Index: integer): PCodeTreeNodeStackEntry;
procedure AddNodeToStack(NodeStack: PCodeTreeNodeStack;
NewTool: TPascalParserTool; NewNode: TCodeTreeNode);
function NodeExistsInStack(NodeStack: PCodeTreeNodeStack;
Node: TCodeTreeNode): boolean;
procedure FinalizeNodeStack(NodeStack: PCodeTreeNodeStack);
const
ncefAllSearchRanges = [ncefSearchedInAncestors,ncefSearchedInParents];
NodeCacheEntryFlagNames: array[TNodeCacheEntryFlag] of string = (
'SearchedInParents', 'SearchedInAncestors'
);
var
GlobalIdentifierTree: TGlobalIdentifierTree;
InterfaceIdentCacheEntryMemManager: TInterfaceIdentCacheEntryMemManager;
NodeCacheEntryMemManager: TNodeCacheEntryMemManager;
NodeCacheMemManager: TNodeCacheMemManager;
BaseTypeCacheMemManager: TBaseTypeCacheMemManager;
function NodeCacheEntryFlagsAsString(Flags: TNodeCacheEntryFlags): string;
implementation
function NodeCacheEntryFlagsAsString(Flags: TNodeCacheEntryFlags): string;
var f: TNodeCacheEntryFlag;
begin
Result:='';
for f:=Low(TNodeCacheEntryFlag) to High(TNodeCacheEntryFlag) do begin
if f in Flags then begin
if Result<>'' then Result:=rEsult+', ';
Result:=Result+NodeCacheEntryFlagNames[f];
end;
end;
end;
{ TNodeCacheEntryMemManager }
procedure TNodeCacheEntryMemManager.DisposeEntry(Entry: PCodeTreeNodeCacheEntry);
begin
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
begin
// add Entry to Free list
Entry^.NextEntry:=PCodeTreeNodeCacheEntry(FFirstFree);
PCodeTreeNodeCacheEntry(FFirstFree):=Entry;
inc(FFreeCount);
end else begin
// free list full -> free the Entry
Dispose(Entry);
{$IFDEF DebugCTMemManager}
inc(FFreedCount);
{$ENDIF}
end;
dec(FCount);
end;
function TNodeCacheEntryMemManager.NewEntry: PCodeTreeNodeCacheEntry;
begin
if FFirstFree<>nil then begin
// take from free list
Result:=PCodeTreeNodeCacheEntry(FFirstFree);
PCodeTreeNodeCacheEntry(FFirstFree):=Result^.NextEntry;
Result^.NextEntry:=nil;
dec(FFreeCount);
end else begin
// free list empty -> create new Entry
New(Result);
{$IFDEF DebugCTMemManager}
inc(FAllocatedCount);
{$ENDIF}
end;
inc(FCount);
end;
procedure TNodeCacheEntryMemManager.FreeFirstItem;
var Entry: PCodeTreeNodeCacheEntry;
begin
Entry:=PCodeTreeNodeCacheEntry(FFirstFree);
PCodeTreeNodeCacheEntry(FFirstFree):=Entry^.NextEntry;
Dispose(Entry);
end;
{ TInterfaceIdentCacheEntryMemManager }
procedure TInterfaceIdentCacheEntryMemManager.DisposeEntry(
Entry: PInterfaceIdentCacheEntry);
begin
if Entry^.Overloaded<>nil then begin
DisposeEntry(Entry^.Overloaded);
Entry^.Overloaded:=nil;
end;
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
begin
// add Entry to Free list
Entry^.NextEntry:=PInterfaceIdentCacheEntry(FFirstFree);
PInterfaceIdentCacheEntry(FFirstFree):=Entry;
inc(FFreeCount);
end else begin
// free list full -> free the Entry
Dispose(Entry);
{$IFDEF DebugCTMemManager}
inc(FFreedCount);
{$ENDIF}
end;
dec(FCount);
end;
function TInterfaceIdentCacheEntryMemManager.NewEntry: PInterfaceIdentCacheEntry;
begin
if FFirstFree<>nil then begin
// take from free list
Result:=PInterfaceIdentCacheEntry(FFirstFree);
PInterfaceIdentCacheEntry(FFirstFree):=Result^.NextEntry;
Result^.NextEntry:=nil;
dec(FFreeCount);
end else begin
// free list empty -> create new Entry
New(Result);
{$IFDEF DebugCTMemManager}
inc(FAllocatedCount);
{$ENDIF}
end;
inc(FCount);
end;
procedure TInterfaceIdentCacheEntryMemManager.FreeFirstItem;
var Entry: PInterfaceIdentCacheEntry;
begin
Entry:=PInterfaceIdentCacheEntry(FFirstFree);
PInterfaceIdentCacheEntry(FFirstFree):=Entry^.NextEntry;
Dispose(Entry);
end;
{ TInterfaceIdentifierCache }
function CompareTInterfaceIdentCacheEntry(Data1, Data2: Pointer): integer;
begin
Result:=CompareIdentifiers(PInterfaceIdentCacheEntry(Data1)^.Identifier,
PInterfaceIdentCacheEntry(Data2)^.Identifier);
end;
procedure TInterfaceIdentifierCache.Clear;
var
Node: TAVLTreeNode;
Entry: PInterfaceIdentCacheEntry;
begin
if FItems<>nil then begin
Node:=FItems.FindLowest;
while Node<>nil do begin
Entry:=PInterfaceIdentCacheEntry(Node.Data);
InterfaceIdentCacheEntryMemManager.DisposeEntry(Entry);
Node:=FItems.FindSuccessor(Node);
end;
FItems.Clear;
end;
end;
procedure TInterfaceIdentifierCache.ClearMissingIdentifiers;
var
Node: TAVLTreeNode;
NextNode: TAVLTreeNode;
Entry: PInterfaceIdentCacheEntry;
begin
if FItems=nil then exit;
Node:=FItems.FindLowest;
while Node<>nil do begin
NextNode:=FItems.FindSuccessor(Node);
Entry:=PInterfaceIdentCacheEntry(Node.Data);
if Entry^.Node=nil then begin
FItems.Delete(Node);
InterfaceIdentCacheEntryMemManager.DisposeEntry(Entry);
end;
Node:=NextNode;
end;
end;
constructor TInterfaceIdentifierCache.Create(ATool: TPascalParserTool);
begin
inherited Create;
FTool:=ATool;
if ATool=nil then
raise Exception.Create('TInterfaceIdentifierCache.Create ATool=nil');
end;
destructor TInterfaceIdentifierCache.Destroy;
begin
Clear;
FreeAndNil(FItems);
inherited Destroy;
end;
procedure TInterfaceIdentifierCache.ConsistencyCheck;
var
Node: TAVLTreeNode;
Entry: PInterfaceIdentCacheEntry;
begin
if FItems<>nil then begin
FItems.ConsistencyCheck;
Node:=FItems.FindLowest;
while Node<>nil do begin
Entry:=PInterfaceIdentCacheEntry(Node.Data);
while Entry<>nil do begin
if (Entry^.Identifier=nil) or (Entry^.Identifier^=#0) then
RaiseCatchableException('');
if (Entry^.Node=nil) and Complete then
RaiseCatchableException('');
if (Entry^.Overloaded<>nil)
and (CompareIdentifiers(Entry^.Identifier,Entry^.Overloaded^.Identifier)<>0)
then begin
debugln(['TInterfaceIdentifierCache.ConsistencyCheck Entry=',GetIdentifier(Entry^.Identifier),'<>',GetIdentifier(Entry^.Overloaded^.Identifier)]);
RaiseCatchableException('');
end;
Entry:=Entry^.Overloaded;
end;
Node:=FItems.FindSuccessor(Node);
end;
end;
end;
function TInterfaceIdentifierCache.CalcMemSize: PtrUInt;
var
Node: TAVLTreeNode;
begin
Result:=PtrUInt(InstanceSize);
if FItems<>nil then begin
inc(Result,FItems.Count*SizeOf(TAVLTreeNode));
Node:=FItems.FindLowest;
while Node<>nil do begin
inc(Result,SizeOf(TInterfaceIdentCacheEntry));
Node:=FItems.FindSuccessor(Node);
end;
end;
end;
function TInterfaceIdentifierCache.FindAVLNode(Identifier: PChar): TAVLTreeNode;
var
Entry: PInterfaceIdentCacheEntry;
comp: integer;
begin
if FItems<>nil then begin
Result:=FItems.Root;
while Result<>nil do begin
Entry:=PInterfaceIdentCacheEntry(Result.Data);
comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
if comp<0 then
Result:=Result.Left
else if comp>0 then
Result:=Result.Right
else
exit;
end;
end else begin
Result:=nil;
end;
end;
procedure TInterfaceIdentifierCache.SetComplete(const AValue: boolean);
begin
if FComplete=AValue then exit;
FComplete:=AValue;
if FComplete then
ClearMissingIdentifiers;
end;
function TInterfaceIdentifierCache.FindIdentifier(Identifier: PChar
): PInterfaceIdentCacheEntry;
var Node: TAVLTreeNode;
begin
Node:=FindAVLNode(Identifier);
if Node<>nil then
Result:=PInterfaceIdentCacheEntry(Node.Data)
else
Result:=nil;
end;
procedure TInterfaceIdentifierCache.Add(Identifier: PChar; Node: TCodeTreeNode;
CleanPos: integer);
var
NewEntry: PInterfaceIdentCacheEntry;
OldNode: TAVLTreeNode;
begin
if (Identifier<>nil) and (Identifier^ = '&') then
Inc(Identifier);
if (GetIdentLen(Identifier)=0) then
RaiseCatchableException('TInterfaceIdentifierCache.Add: empty identifier');
if FItems=nil then
FItems:=TAVLTree.Create(@CompareTInterfaceIdentCacheEntry);
OldNode:=FindAVLNode(Identifier);
NewEntry:=InterfaceIdentCacheEntryMemManager.NewEntry;
NewEntry^.Identifier:=GlobalIdentifierTree.AddCopy(Identifier);
NewEntry^.Node:=Node;
NewEntry^.CleanPos:=CleanPos;
if OldNode<>nil then begin
NewEntry^.Overloaded:=PInterfaceIdentCacheEntry(OldNode.Data);
OldNode.Data:=NewEntry;
end else begin
NewEntry^.Overloaded:=nil;
FItems.Add(NewEntry);
end;
end;
{ TGlobalIdentifierTree }
procedure TGlobalIdentifierTree.Clear;
var
i: Integer;
begin
if FItems<>nil then
FItems.Clear;
if FFullDataBlocks<>nil then begin
for i:=0 to FFullDataBlocks.Count-1 do
FreeMem(FFullDataBlocks[i]);
FFullDataBlocks.Clear;
ReAllocMem(FDataBlock,0);
FDataBlockEnd:=0;
FDataBlockSize:=0;
end;
end;
constructor TGlobalIdentifierTree.Create;
begin
inherited Create;
FItems:=TAVLTree.Create(TListSortCompare(@CompareIdentifiers));
FFullDataBlocks:=TFPList.Create;
FDefaultDataBlockSize:=256*256*2;
end;
destructor TGlobalIdentifierTree.Destroy;
begin
Clear;
FItems.Free;
FFullDataBlocks.Free;
inherited Destroy;
end;
function TGlobalIdentifierTree.Count: integer;
begin
if FItems<>nil then
Result:=FItems.Count
else
Result:=0;
end;
function TGlobalIdentifierTree.CalcMemSize: PtrUInt;
begin
Result:=PtrUInt(InstanceSize)
+PtrUint(FItems.InstanceSize)
+PtrUInt(FItems.Count)*PtrUint(TAVLTreeNode.InstanceSize)
+PtrUInt(FFullDataBlocks.InstanceSize)
+PtrUInt(FFullDataBlocks.Capacity)*SizeOf(Pointer)
+PtrUInt(FFullDataBlocks.Count*FDefaultDataBlockSize)
+PtrUInt(FDataBlockSize);
end;
function TGlobalIdentifierTree.InternalGetMem(Size: integer): Pointer;
begin
if (FDataBlock=nil) or (FDataBlockEnd+Size>FDataBlockSize) then begin
// store old block
FFullDataBlocks.Add(FDataBlock);
// create a new
FDataBlockSize:=FDefaultDataBlockSize;
if FDataBlockSize<Size then
FDataBlockSize:=Size;
GetMem(FDataBlock,FDataBlockSize);
FDataBlockEnd:=0;
end;
Result:=FDataBlock+FDataBlockEnd;
inc(FDataBlockEnd,Size);
end;
function TGlobalIdentifierTree.AddCopy(Identifier: PChar): PChar;
var Len: integer;
begin
Result:=nil;
if (Identifier=nil) or (not IsIdentChar[Identifier[0]]) then exit;
Result:=Find(Identifier);
if Result<>nil then
exit;
Len:=0;
while IsIdentChar[Identifier[Len]] do inc(Len);
Result:=InternalGetMem(Len+1);
// GetMem(Result,Len+1);
Move(Identifier^,Result^,Len);
Result[Len]:=#0;
FItems.Add(Result);
end;
function TGlobalIdentifierTree.Find(Identifier: PChar): PChar;
var
comp: integer;
Node: TAVLTreeNode;
begin
if FItems<>nil then begin
Node:=FItems.Root;
while Node<>nil do begin
Result:=PChar(Node.Data);
comp:=CompareIdentifiers(Identifier,Result);
if comp<0 then
Node:=Node.Left
else if comp>0 then
Node:=Node.Right
else
exit;
end;
end;
Result:=nil;
end;
{ TCodeTreeNodeCache }
function CompareTCodeTreeNodeCacheEntry(Data1, Data2: Pointer): integer;
var Entry1, Entry2: PCodeTreeNodeCacheEntry;
begin
Entry1:=PCodeTreeNodeCacheEntry(Data1);
Entry2:=PCodeTreeNodeCacheEntry(Data2);
Result:=CompareIdentifiers(Entry1^.Identifier,Entry2^.Identifier);
if Result=0 then begin
if Entry1^.CleanStartPos>Entry2^.CleanStartPos then
Result:=-1
else if Entry1^.CleanStartPos<Entry2^.CleanStartPos then
Result:=1
else
Result:=0;
end;
end;
constructor TCodeTreeNodeCache.Create(AnOwner: TCodeTreeNode);
begin
inherited Create;
if AnOwner<>nil then BindToOwner(AnOwner);
end;
destructor TCodeTreeNodeCache.Destroy;
begin
Clear;
UnbindFromOwner;
FItems.Free;
inherited Destroy;
end;
function TCodeTreeNodeCache.FindLeftMostAVLNode(Identifier: PChar): TAVLTreeNode;
// find leftmost avl node with Identifier
var
Entry: PCodeTreeNodeCacheEntry;
Node: TAVLTreeNode;
comp: integer;
begin
if FItems<>nil then begin
Result:=FItems.Root;
while Result<>nil do begin
Entry:=PCodeTreeNodeCacheEntry(Result.Data);
comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
if comp<0 then
Result:=Result.Left
else if comp>0 then
Result:=Result.Right
else begin
repeat
Node:=FItems.FindPrecessor(Result);
if Node<>nil then begin
Entry:=PCodeTreeNodeCacheEntry(Node.Data);
if CompareIdentifiers(Identifier,Entry^.Identifier)=0 then
Result:=Node
else
break;
end else
break;
until false;
exit;
end;
end;
end else begin
Result:=nil;
end;
end;
procedure TCodeTreeNodeCache.Clear;
var
Node: TAVLTreeNode;
Entry: PCodeTreeNodeCacheEntry;
begin
if FItems<>nil then begin
Node:=FItems.FindLowest;
while Node<>nil do begin
Entry:=PCodeTreeNodeCacheEntry(Node.Data);
NodeCacheEntryMemManager.DisposeEntry(Entry);
Node:=FItems.FindSuccessor(Node);
end;
FItems.Clear;
end;
end;
procedure TCodeTreeNodeCache.Add(Identifier: PChar;
SrcTool: TPascalParserTool; CleanStartPos, CleanEndPos: integer;
NewNode: TCodeTreeNode; NewTool: TPascalParserTool; NewCleanPos: integer;
Flags: TNodeCacheEntryFlags);
procedure AddNewEntry;
var NewEntry: PCodeTreeNodeCacheEntry;
begin
NewEntry:=NodeCacheEntryMemManager.NewEntry;
NewEntry^.Identifier:=GlobalIdentifierTree.AddCopy(Identifier);
NewEntry^.CleanStartPos:=CleanStartPos;
NewEntry^.CleanEndPos:=CleanEndPos;
NewEntry^.NewNode:=NewNode;
NewEntry^.NewTool:=NewTool;
NewEntry^.NewCleanPos:=NewCleanPos;
NewEntry^.Flags:=Flags;
FItems.Add(NewEntry);
end;
var
OldEntry: PCodeTreeNodeCacheEntry;
OldNode: TAVLTreeNode;
NewSearchRangeFlags: TNodeCacheEntryFlags;
function P2S(CleanPos: integer): string;
begin
Result:=SrcTool.CleanPosToStr(CleanPos);
end;
function ParamsDebugReport: string;
var
s: string;
begin
s:=' Ident='+GetIdentifier(Identifier);
s:=s+' New: Range='+P2S(CleanStartPos)
+'-'+P2S(CleanEndPos);
if Owner<>nil then begin
s:=s+' Owner='+Owner.DescAsString;
s:=s+' OwnerPos='+P2S(Owner.StartPos);
end;
if OldEntry<>nil then begin
s:=s+' Old: Range='+P2S(OldEntry^.CleanStartPos)
+'-'+P2S(OldEntry^.CleanEndPos);
if OldEntry^.NewNode<>nil then begin
s:=s+' Node='+OldEntry^.NewNode.DescAsString
+' Pos='+OldEntry^.NewTool.CleanPosToStr(OldEntry^.NewNode.StartPos);
end else
s:=s+' Node=nil';
if OldEntry^.NewTool<>nil then begin
s:=s+' Tool='+ExtractFilename(OldEntry^.NewTool.MainFilename);
if OldEntry^.NewNode<>nil then
s:=s+' Src="'
+StringToPascalConst(
copy(OldEntry^.NewTool.Src,OldEntry^.NewNode.StartPos,50))+'"';
end;
end;
if NewNode<>nil then begin
s:=s+' Node='+NewNode.DescAsString
+' Pos='+NewTool.CleanPosToStr(NewNode.StartPos);
end else
s:=s+' Node=nil';
if NewTool<>nil then begin
s:=s+' Tool='+ExtractFileName(NewTool.MainFilename);
if NewNode<>nil then
s:=s+' Src="'
+StringToPascalConst(copy(NewTool.Src,NewNode.StartPos,50))+'"';
end;
Result:=s;
end;
procedure RaiseConflictException(const Msg: string);
var
s: string;
begin
s:='[TCodeTreeNodeCache.Add] internal error:'+Msg+ParamsDebugReport;
{$IFDEF HardExceptions}
DebugLn(s);
RaiseCatchableException('TCodeTreeNodeCache.Add A');
{$ELSE}
raise Exception.Create(s);
{$ENDIF}
end;
begin
OldEntry:=nil;
// consistency checks
if CleanStartPos>=CleanEndPos then
RaiseConflictException('CleanStartPos>=CleanEndPos');
if (NewNode<>nil) then begin
if NewTool=nil then
RaiseConflictException('NewNode<>nil and NewTool=nil');
if not NewTool.Tree.ContainsNode(NewNode) then
RaiseConflictException('NewNode is not a node of NewTool');
end;
{if CompareIdentifiers(Identifier,'FillRect')=0 then begin
DebugLn('[[[[======================================================');
DebugLn(['[TCodeTreeNodeCache.Add] Ident=',GetIdentifier(Identifier),
' CleanStartPos=',CleanStartPos,' CleanEndPos=',CleanEndPos,
' Flags=[',NodeCacheEntryFlagsAsString(Flags),']',
' NewNode=',NewNode<>nil
]);
DebugLn('======================================================]]]]');
CTDumpStack;
end;}
if FItems=nil then
FItems:=TAVLTree.Create(@CompareTCodeTreeNodeCacheEntry);
// if identifier already exists, try to combine them
OldNode:=FindAVLNodeInRange(Identifier,CleanStartPos,CleanEndPos);
if OldNode=nil then begin
// identifier was never searched in this range
AddNewEntry;
end else begin
// identifier was already searched in this range
OldEntry:=PCodeTreeNodeCacheEntry(OldNode.Data);
NewSearchRangeFlags:=(ncefAllSearchRanges * (OldEntry^.Flags+Flags));
if ((NewNode=OldEntry^.NewNode)
and (NewTool=OldEntry^.NewTool))
or ((OldEntry^.NewNode=nil) and (NewSearchRangeFlags<>[])) then
begin
// same FindContext or better FindContext with overlapping search ranges
// -> combine search ranges
if OldEntry^.CleanStartPos>CleanStartPos then
OldEntry^.CleanStartPos:=CleanStartPos;
if OldEntry^.CleanEndPos<CleanEndPos then
OldEntry^.CleanEndPos:=CleanEndPos;
OldEntry^.Flags:=NewSearchRangeFlags;
end else begin
// different FindContext with overlapping search ranges
RaiseConflictException('conflicting cache nodes');
end;
end;
end;
function TCodeTreeNodeCache.Find(Identifier: PChar): PCodeTreeNodeCacheEntry;
var Node: TAVLTreeNode;
begin
Node:=FindLeftMostAVLNode(Identifier);
if Node<>nil then begin
Result:=PCodeTreeNodeCacheEntry(Node.Data);
end else begin
Result:=nil;
end;
end;
function TCodeTreeNodeCache.FindAVLNode(Identifier: PChar; CleanPos: integer
): TAVLTreeNode;
begin
Result:=FindAVLNodeInRange(Identifier,CleanPos,CleanPos);
end;
function TCodeTreeNodeCache.FindRightMostAVLNode(Identifier: PChar
): TAVLTreeNode;
// find rightmost avl node with Identifier
var
Entry: PCodeTreeNodeCacheEntry;
Node: TAVLTreeNode;
comp: integer;
begin
if FItems<>nil then begin
Result:=FItems.Root;
while Result<>nil do begin
Entry:=PCodeTreeNodeCacheEntry(Result.Data);
comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
if comp<0 then
Result:=Result.Left
else if comp>0 then
Result:=Result.Right
else begin
repeat
Node:=FItems.FindSuccessor(Result);
if Node<>nil then begin
Entry:=PCodeTreeNodeCacheEntry(Node.Data);
if CompareIdentifiers(Identifier,Entry^.Identifier)=0 then
Result:=Node
else
break;
end else
break;
until false;
exit;
end;
end;
end else begin
Result:=nil;
end;
end;
function TCodeTreeNodeCache.FindAVLNodeInRange(Identifier: PChar;
CleanStartPos, CleanEndPos: integer): TAVLTreeNode;
var
Entry: PCodeTreeNodeCacheEntry;
begin
Result:=FindNearestAVLNode(Identifier,CleanStartPos,CleanEndPos,true);
if Result<>nil then begin
Entry:=PCodeTreeNodeCacheEntry(Result.Data);
if (CleanStartPos>=Entry^.CleanEndPos)
or (CleanEndPos<=Entry^.CleanStartPos) then begin
// node is not in range
Result:=nil;
end;
end;
end;
function TCodeTreeNodeCache.FindNearestAVLNode(Identifier: PChar;
CleanStartPos, CleanEndPos: integer; InFront: boolean): TAVLTreeNode;
var
Entry: PCodeTreeNodeCacheEntry;
comp: integer;
DirectionSucc: boolean;
NextNode: TAVLTreeNode;
begin
if CleanStartPos>CleanEndPos then begin
raise Exception.Create('[TCodeTreeNodeCache.FindNearestAVLNode]'
+' internal error: CleanStartPos>CleanEndPos');
end;
if (FItems<>nil) and (Identifier<>nil) then begin
Result:=FItems.Root;
while Result<>nil do begin
Entry:=PCodeTreeNodeCacheEntry(Result.Data);
comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
if comp<0 then
Result:=Result.Left
else if comp>0 then
Result:=Result.Right
else begin
// cached result with identifier found
// -> check range
if CleanStartPos>=Entry^.CleanEndPos then begin
NextNode:=FItems.FindSuccessor(Result);
DirectionSucc:=true;
end else if CleanEndPos<=Entry^.CleanStartPos then begin
NextNode:=FItems.FindPrecessor(Result);
DirectionSucc:=false;
end else begin
// cached result in range found
exit;
end;
while (NextNode<>nil) do begin
Entry:=PCodeTreeNodeCacheEntry(NextNode.Data);
if CompareIdentifiers(Identifier,Entry^.Identifier)<>0 then begin
exit;
end;
Result:=NextNode;
if (CleanStartPos<Entry^.CleanEndPos)
and (CleanEndPos>Entry^.CleanStartPos) then begin
// cached result in range found
exit;
end;
if DirectionSucc then
NextNode:=FItems.FindSuccessor(Result)
else
NextNode:=FItems.FindPrecessor(Result);
end;
exit;
end;
end;
end else begin
Result:=nil;
end;
end;
procedure TCodeTreeNodeCache.ConsistencyCheck;
begin
if (FItems<>nil) then
FItems.ConsistencyCheck;
if Owner<>nil then begin
if Owner.Cache<>Self then
raise Exception.Create('');
end;
end;
function TCodeTreeNodeCache.CalcMemSize: PtrUInt;
var
Node: TAVLTreeNode;
begin
Result:=PtrUInt(InstanceSize);
if FItems<>nil then begin
inc(Result,SizeOf(TAVLTreeNode)*FItems.Count);
Node:=FItems.FindLowest;
while Node<>nil do begin
inc(Result,SizeOf(TCodeTreeNodeCacheEntry));
Node:=FItems.FindSuccessor(Node);
end;
end;
end;
procedure TCodeTreeNodeCache.WriteDebugReport(const Prefix: string);
var Node: TAVLTreeNode;
Entry: PCodeTreeNodeCacheEntry;
begin
DebugLn(Prefix+'[TCodeTreeNodeCache.WriteDebugReport] Self='+DbgS(Self));
if FItems<>nil then begin
Node:=FItems.FindLowest;
while Node<>nil do begin
Entry:=PCodeTreeNodeCacheEntry(Node.Data);
write(Prefix,' Ident="',GetIdentifier(Entry^.Identifier),'"');
DbgOut(' Flags=[',NodeCacheEntryFlagsAsString(Entry^.Flags),']');
DbgOut(' Node=',DbgS(Entry^.NewNode<>nil));
DebugLn('');
Node:=FItems.FindSuccessor(Node);
end;
end;
ConsistencyCheck;
end;
procedure TCodeTreeNodeCache.UnbindFromOwner;
begin
if Owner<>nil then begin
if Owner.Cache<>Self then
raise Exception.Create('[TCodeTreeNodeCache.UnbindFromOwner] '
+' internal error: Owner.Cache<>Self');
Owner.Cache:=nil;
Owner:=nil;
end;
end;
procedure TCodeTreeNodeCache.BindToOwner(NewOwner: TCodeTreeNode);
begin
if NewOwner<>nil then begin
if NewOwner.Cache<>nil then
raise Exception.Create('[TCodeTreeNodeCache.BindToOwner] internal error:'
+' NewOwner.Cache<>nil');
NewOwner.Cache:=Self;
end;
Owner:=NewOwner;
end;
function TCodeTreeNodeCache.FindNearest(Identifier: PChar; CleanStartPos,
CleanEndPos: integer; InFront: boolean): PCodeTreeNodeCacheEntry;
var Node: TAVLTreeNode;
begin
Node:=FindNearestAVLNode(Identifier,CleanStartPos,CleanEndPos,InFront);
if Node<>nil then
Result:=PCodeTreeNodeCacheEntry(Node.Data)
else
Result:=nil;
end;
function TCodeTreeNodeCache.FindInRange(Identifier: PChar; CleanStartPos,
CleanEndPos: integer): PCodeTreeNodeCacheEntry;
var Node: TAVLTreeNode;
begin
Node:=FindAVLNodeInRange(Identifier,CleanStartPos,CleanEndPos);
if Node<>nil then
Result:=PCodeTreeNodeCacheEntry(Node.Data)
else
Result:=nil;
end;
{ TNodeCacheMemManager }
procedure TNodeCacheMemManager.DisposeNodeCache(NodeCache: TCodeTreeNodeCache);
begin
NodeCache.UnbindFromOwner;
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
begin
// add Entry to Free list
NodeCache.Next:=TCodeTreeNodeCache(FFirstFree);
TCodeTreeNodeCache(FFirstFree):=NodeCache;
inc(FFreeCount);
end else begin
// free list full -> free the NodeCache
NodeCache.Free;
{$IFDEF DebugCTMemManager}
inc(FFreedCount);
{$ENDIF}
end;
dec(FCount);
end;
procedure TNodeCacheMemManager.FreeFirstItem;
var NodeCache: TCodeTreeNodeCache;
begin
NodeCache:=TCodeTreeNodeCache(FFirstFree);
TCodeTreeNodeCache(FFirstFree):=NodeCache.Next;
NodeCache.Free;
end;
function TNodeCacheMemManager.NewNodeCache(
AnOwner: TCodeTreeNode): TCodeTreeNodeCache;
begin
if FFirstFree<>nil then begin
// take from free list
Result:=TCodeTreeNodeCache(FFirstFree);
TCodeTreeNodeCache(FFirstFree):=Result.Next;
Result.Clear;
Result.BindToOwner(AnOwner);
dec(FFreeCount);
end else begin
// free list empty -> create new NodeCache
Result:=TCodeTreeNodeCache.Create(AnOwner);
{$IFDEF DebugCTMemManager}
inc(FAllocatedCount);
{$ENDIF}
end;
inc(FCount);
end;
//------------------------------------------------------------------------------
procedure InitializeNodeStack(NodeStack: PCodeTreeNodeStack);
begin
NodeStack^.StackPtr:=-1;
NodeStack^.DynItems:=nil;
NodeStack^.Capacity:=0;
end;
function GetNodeStackEntry(NodeStack: PCodeTreeNodeStack;
Index: integer): PCodeTreeNodeStackEntry;
begin
if Index<CodeTreeNodeFixedItemCount then begin
Result:=@NodeStack^.FixedItems[Index];
end else begin
Result:=@NodeStack^.DynItems[Index-CodeTreeNodeFixedItemCount];
end;
end;
procedure AddNodeToStack(NodeStack: PCodeTreeNodeStack;
NewTool: TPascalParserTool; NewNode: TCodeTreeNode);
var
Entry: PCodeTreeNodeStackEntry;
i: Integer;
begin
inc(NodeStack^.StackPtr);
if NodeStack^.StackPtr<CodeTreeNodeFixedItemCount then begin
Entry:=@NodeStack^.FixedItems[NodeStack^.StackPtr];
end else begin
i:=NodeStack^.StackPtr-CodeTreeNodeFixedItemCount;
if NodeStack^.Capacity<=i then begin
inc(NodeStack^.Capacity,CodeTreeNodeFixedItemCount);
ReAllocMem(NodeStack^.DynItems,NodeStack^.Capacity*SizeOf(TCodeTreeNodeStackEntry));
end;
Entry:=@NodeStack^.DynItems[i];
end;
Entry^.Tool:=NewTool;
Entry^.Node:=NewNode;
end;
function NodeExistsInStack(NodeStack: PCodeTreeNodeStack;
Node: TCodeTreeNode): boolean;
var i: integer;
begin
Result:=true;
i:=0;
while i<=NodeStack^.StackPtr do begin
if i<CodeTreeNodeFixedItemCount then begin
if NodeStack^.FixedItems[i].Node=Node then exit;
end else begin
if NodeStack^.DynItems[i-CodeTreeNodeFixedItemCount].Node=Node then
exit;
end;
inc(i);
end;
Result:=false;
end;
procedure FinalizeNodeStack(NodeStack: PCodeTreeNodeStack);
begin
if NodeStack^.DynItems=nil then exit;
ReAllocMem(NodeStack^.DynItems,0);
end;
{ TBaseTypeCacheMemManager }
procedure TBaseTypeCacheMemManager.DisposeBaseTypeCache(
BaseTypeCache: TBaseTypeCache);
begin
BaseTypeCache.UnbindFromOwner;
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
begin
// add Entry to Free list
BaseTypeCache.NextCache:=TBaseTypeCache(FFirstFree);
TBaseTypeCache(FFirstFree):=BaseTypeCache;
inc(FFreeCount);
end else begin
// free list full -> free the BaseType
BaseTypeCache.Free;
{$IFDEF DebugCTMemManager}
inc(FFreedCount);
{$ENDIF}
end;
dec(FCount);
end;
procedure TBaseTypeCacheMemManager.FreeFirstItem;
var BaseTypeCache: TBaseTypeCache;
begin
BaseTypeCache:=TBaseTypeCache(FFirstFree);
TBaseTypeCache(FFirstFree):=BaseTypeCache.NextCache;
BaseTypeCache.Free;
end;
function TBaseTypeCacheMemManager.NewBaseTypeCache(
AnOwner: TCodeTreeNode): TBaseTypeCache;
begin
if FFirstFree<>nil then begin
// take from free list
Result:=TBaseTypeCache(FFirstFree);
TBaseTypeCache(FFirstFree):=Result.NextCache;
Result.BindToOwner(AnOwner);
dec(FFreeCount);
end else begin
// free list empty -> create new BaseType
Result:=TBaseTypeCache.Create(AnOwner);
{$IFDEF DebugCTMemManager}
inc(FAllocatedCount);
{$ENDIF}
end;
inc(FCount);
end;
{ TBaseTypeCache }
procedure TBaseTypeCache.BindToOwner(NewOwner: TCodeTreeNode);
begin
if NewOwner<>nil then begin
if NewOwner.Cache<>nil then
raise Exception.Create('[TBaseTypeCache.BindToOwner] internal error:'
+' NewOwner.Cache<>nil');
NewOwner.Cache:=Self;
end;
Owner:=NewOwner;
end;
constructor TBaseTypeCache.Create(AnOwner: TCodeTreeNode);
begin
inherited Create;
if AnOwner<>nil then BindToOwner(AnOwner);
end;
destructor TBaseTypeCache.Destroy;
begin
UnbindFromOwner;
inherited Destroy;
end;
function TBaseTypeCache.CalcMemSize: PtrUInt;
begin
Result:=PtrUInt(InstanceSize);
end;
procedure TBaseTypeCache.UnbindFromOwner;
begin
if Owner<>nil then begin
if Owner.Cache<>Self then
raise Exception.Create('[TBaseTypeCache.UnbindFromOwner] '
+' internal error: Owner.Cache<>Self');
Owner.Cache:=nil;
Owner:=nil;
end;
end;
//------------------------------------------------------------------------------
procedure InternalInit;
begin
GlobalIdentifierTree:=TGlobalIdentifierTree.Create;
InterfaceIdentCacheEntryMemManager:=TInterfaceIdentCacheEntryMemManager.Create;
NodeCacheEntryMemManager:=TNodeCacheEntryMemManager.Create;
NodeCacheMemManager:=TNodeCacheMemManager.Create;
BaseTypeCacheMemManager:=TBaseTypeCacheMemManager.Create;
end;
procedure InternalFinal;
begin
BaseTypeCacheMemManager.Free;
BaseTypeCacheMemManager:=nil;
NodeCacheMemManager.Free;
NodeCacheMemManager:=nil;
NodeCacheEntryMemManager.Free;
NodeCacheEntryMemManager:=nil;
InterfaceIdentCacheEntryMemManager.Free;
InterfaceIdentCacheEntryMemManager:=nil;
GlobalIdentifierTree.Free;
GlobalIdentifierTree:=nil;
end;
initialization
InternalInit;
finalization
InternalFinal;
end.
Reference in New Issue View Git Blame Copy Permalink