paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-04 15:32:00 +01:00
Code Issues Packages Projects Releases Wiki Activity
f22350e1c5
lazarus/components/codetools/codetree.pas
mattias 2ee19afd56 codetools: fixed forward defined class-of 
git-svn-id: trunk@52855 -
2016-08-21 19:29:50 +00:00

1123 lines
34 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
A TCodeTree is the product of a code tool. Every TCodeTreeNode describes a
logical block in the code (e.g. a class, a procedure or an identifier).
This unit defines also all valid CodeTree-Node-Descriptors, constants for
TCodeTreeNode types.
}
unit CodeTree;
{$ifdef FPC}{$mode objfpc}{$endif}{$H+}
interface
{$I codetools.inc}
{$IMPLICITEXCEPTIONS OFF} // no automatic try..finally (exceptions in all functions are fatal)
uses
{$IFDEF MEM_CHECK}
MemCheck,
{$ENDIF}
Classes, SysUtils, FileProcs, CodeToolsStructs, BasicCodeTools,
AVL_Tree, LazDbgLog;
//-----------------------------------------------------------------------------
type
TCodeTreeNodeDesc = word;
TCodeTreeNodeSubDesc = word;
const
// CodeTreeNodeDescriptors
ctnNone = 0;
ctnProgram = 1;
ctnPackage = 2;
ctnLibrary = 3;
ctnUnit = 4;
ctnInterface = 5;
ctnImplementation = 6;
ctnInitialization = 7;
ctnFinalization = 8;
ctnEndPoint = 9;
ctnTypeSection = 10;
ctnVarSection = 11;
ctnConstSection = 12;
ctnResStrSection = 13;
ctnLabelSection = 14;
ctnPropertySection = 15;
ctnUsesSection = 16; // child nodes are ctnUseUnit
ctnRequiresSection = 17;
ctnContainsSection = 18; // child nodes are ctnUseUnit
ctnExportsSection = 19;
ctnTypeDefinition = 20;
ctnVarDefinition = 21;
ctnConstDefinition = 22;
ctnGlobalProperty = 23;
ctnUseUnit = 24; // StartPos=unit, EndPos=unitname+inFilename, children ctnUseUnitNamespace, ctnUseUnitClearName
ctnVarArgs = 25;
ctnUseUnitNamespace = 26; // <namespace>.clearname.pas
ctnUseUnitClearName = 27; // namespace.<clearname>.pas
ctnClass = 30;
ctnClassInterface = 31;
ctnDispinterface = 32;
ctnObject = 33;
ctnObjCClass = 34;
ctnObjCCategory = 35;
ctnObjCProtocol = 36;
ctnCPPClass = 37;
ctnTypeHelper = 38;//"type helper", parent/child similar to ctnClass
ctnRecordHelper = 39;//"record helper", parent/child similar to ctnClass
ctnClassAbstract = 40;
ctnClassSealed = 41;
ctnClassExternal = 42; // parent: jvm: ctnClass, ObjCClass, ObjCProtocol
ctnClassHelper = 43;//"class helper", parent/child similar to ctnClass
ctnClassInheritance = 44;
ctnHelperFor = 45;//class/record/type helper for, only child is ctnIdentifier
ctnClassGUID = 46;
ctnClassClassVar = 47; // child of visibility section
ctnClassPrivate = 48; // child of AllClassObjects
ctnClassProtected = 49;
ctnClassPublic = 50;
ctnClassPublished = 51;
ctnClassRequired = 52; // parent: ObjCProtocol
ctnClassOptional = 53; // parent: ObjCProtocol
ctnProperty = 54; // child of visibility section or AllClassInterfaces
ctnMethodMap = 55; // child of visibility section or AllClassInterfaces
ctnProcedure = 60; // children: ctnProcedureHead, sections, ctnBeginBlock/ctnAsmBlock
ctnProcedureHead = 61; // children: ctnParameterList, operator: ctnVarDefinition, operator/function: ctnIdentifier
ctnParameterList = 62; // children: ctnVarDefinition
ctnIdentifier = 70;
ctnRangedArrayType = 71;
ctnOpenArrayType = 72;
ctnOfConstType = 73;
ctnRecordType = 74;
ctnRecordCase = 75; // children: ctnVarDefinition plus 0..n ctnRecordVariant
ctnRecordVariant = 76; // children: 0..n ctnVarDefinition plus may be a ctnRecordCase
ctnProcedureType = 77;
ctnSetType = 78;
ctnRangeType = 79;
ctnEnumerationType = 80;
ctnEnumIdentifier = 81;
ctnLabel = 82;
ctnTypeType = 83;
ctnFileType = 84;
ctnPointerType = 85;
ctnClassOfType = 86; // 1st child = ctnIdentifier
ctnVariantType = 87;
ctnSpecialize = 88; // 1st child = ctnSpecializeType, 2nd child = ctnSpecializeParams
ctnSpecializeType = 89; // parent = ctnSpecialize
ctnSpecializeParams = 90; // list of ctnSpecializeParam, parent = ctnSpecialize
ctnSpecializeParam = 91; // parent = ctnSpecializeParams
ctnGenericType = 92;// 1st child = ctnGenericName, 2nd child = ctnGenericParams, 3th child = type
ctnGenericName = 93; // parent = ctnGenericType
ctnGenericParams = 94; // parent = ctnGenericType, children = ctnGenericParameter
ctnGenericParameter = 95; // can has a child ctnGenericConstraint
ctnGenericConstraint = 96; // parent = ctnGenericParameter
ctnReferenceTo = 97; // 1st child = ctnProcedure
ctnConstant = 98;
ctnHintModifier = 99; // deprecated, platform, unimplemented, library, experimental
ctnBeginBlock =100;
ctnAsmBlock =101;
ctnWithVariable =110;
ctnWithStatement =111;
ctnOnBlock =112;// childs: ctnOnIdentifier+ctnOnStatement, or ctnVarDefinition(with child ctnIdentifier)+ctnOnStatement
ctnOnIdentifier =113;// e.g. 'on Exception', Note: on E:Exception creates a ctnVarDefinition
ctnOnStatement =114;
// combined values
AllSourceTypes =
[ctnProgram,ctnPackage,ctnLibrary,ctnUnit];
AllUsableSourceTypes =
[ctnUnit];
AllCodeSections = AllSourceTypes
+ [ctnInterface, ctnImplementation, ctnInitialization, ctnFinalization];
AllClassBaseSections =
[ctnClassPublic,ctnClassPublished,ctnClassPrivate,ctnClassProtected,
ctnClassRequired,ctnClassOptional];
AllClassSubSections =
[ctnConstSection, ctnTypeSection, ctnVarSection, ctnClassClassVar];
AllClassSections =
AllClassBaseSections+AllClassSubSections;
AllClassInterfaces = [ctnClassInterface,ctnDispinterface,ctnObjCProtocol];
AllClassObjects = [ctnClass,ctnObject,ctnRecordType,
ctnObjCClass,ctnObjCCategory,ctnCPPClass,
ctnClassHelper,ctnRecordHelper,ctnTypeHelper];
AllClasses = AllClassObjects+AllClassInterfaces;
AllClassModifiers = [ctnClassAbstract, ctnClassSealed, ctnClassExternal];
AllDefinitionSections =
[ctnTypeSection,ctnVarSection,ctnConstSection,ctnResStrSection,
ctnLabelSection,ctnPropertySection];
AllSimpleIdentifierDefinitions =
[ctnTypeDefinition,ctnVarDefinition,ctnConstDefinition];
AllIdentifierDefinitions = AllSimpleIdentifierDefinitions
+[ctnGenericType,ctnGlobalProperty];
AllPascalTypes =
AllClasses+
[ctnGenericType,ctnSpecialize,
ctnIdentifier,ctnOpenArrayType,ctnRangedArrayType,
ctnRecordCase,ctnRecordVariant,
ctnProcedureType,ctnSetType,ctnRangeType,ctnEnumerationType,
ctnEnumIdentifier,ctnLabel,ctnTypeType,ctnFileType,ctnPointerType,
ctnClassOfType,ctnVariantType,ctnConstant];
AllPascalStatements = [ctnBeginBlock,ctnWithStatement,ctnWithVariable,
ctnOnBlock,ctnOnIdentifier,ctnOnStatement,
ctnInitialization,ctnFinalization];
AllFindContextDescs = AllIdentifierDefinitions + AllCodeSections + AllClasses +
[ctnProcedure];
AllPointContexts = AllClasses+AllSourceTypes+
[ctnEnumerationType,ctnInterface,ctnImplementation,ctnTypeType,
ctnUseUnitNamespace,ctnUseUnitClearName,ctnRangedArrayType,ctnOpenArrayType];
// CodeTreeNodeSubDescriptors
ctnsNone = 0;
ctnsNeedJITParsing = 1 shl 1;
ctnsHasParseError = 1 shl 2;
ctnsForwardDeclaration = 1 shl 3;
ctnsHasDefaultValue = 1 shl 4;
ClassSectionNodeType: array[TPascalClassSection] of TCodeTreeNodeDesc = (
ctnClassPrivate,
ctnClassProtected,
ctnClassPublic,
ctnClassPublished
);
type
// Procedure Specifiers
TProcedureSpecifier = (
psSTDCALL, psREGISTER, psPOPSTACK, psVIRTUAL, psABSTRACT, psDYNAMIC,
psOVERLOAD, psOVERRIDE, psREINTRODUCE, psCDECL, psINLINE, psMESSAGE,
psEXTERNAL, psFORWARD, psPASCAL, psASSEMBLER, psSAVEREGISTERS,
psFAR, psNEAR, psFINAL, psSTATIC, psMWPASCAL, psNOSTACKFRAME,
psDEPRECATED, psDISPID, psPLATFORM, psSAFECALL, psUNIMPLEMENTED,
psEXPERIMENTAL, psLIBRARY, psENUMERATOR, psVARARGS,
psEdgedBracket);
TAllProcedureSpecifiers = set of TProcedureSpecifier;
const
ProcedureSpecifierNames: array[TProcedureSpecifier] of shortstring = (
'STDCALL', 'REGISTER', 'POPSTACK', 'VIRTUAL', 'ABSTRACT', 'DYNAMIC',
'OVERLOAD', 'OVERRIDE', 'REINTRODUCE', 'CDECL', 'INLINE', 'MESSAGE',
'EXTERNAL', 'FORWARD', 'PASCAL', 'ASSEMBLER', 'SAVEREGISTERS',
'FAR', 'NEAR', 'FINAL', 'STATIC', 'MWPASCAL', 'NOSTACKFRAME',
'DEPRECATED', 'DISPID', 'PLATFORM', 'SAFECALL', 'UNIMPLEMENTED',
'EXPERIMENTAL', 'LIBRARY', 'ENUMERATOR', 'VARARGS',
'['
);
type
{ TCodeTreeNode }
TCodeTreeNode = packed class
public
Parent, NextBrother, PriorBrother, FirstChild, LastChild: TCodeTreeNode;
Cache: TObject;
StartPos, EndPos: integer;
Desc: TCodeTreeNodeDesc;
SubDesc: TCodeTreeNodeSubDesc;
function Next: TCodeTreeNode;
function NextSkipChilds: TCodeTreeNode;
function Prior: TCodeTreeNode;
function GetNodeInFrontOfPos(p: integer): TCodeTreeNode;
function GetRoot: TCodeTreeNode;
function ChildCount: integer;
function HasAsParent(Node: TCodeTreeNode): boolean;
function HasAsChild(Node: TCodeTreeNode): boolean;
function HasParentOfType(ParentDesc: TCodeTreeNodeDesc): boolean;
function HasAsRoot(RootNode: TCodeTreeNode): boolean;
function GetNodeOfType(ADesc: TCodeTreeNodeDesc): TCodeTreeNode;
function GetNodeOfTypes(Descriptors: array of TCodeTreeNodeDesc): TCodeTreeNode;
function GetTopMostNodeOfType(ADesc: TCodeTreeNodeDesc): TCodeTreeNode;
function GetFindContextParent: TCodeTreeNode;
function GetLevel: integer;
function GetLastNode: TCodeTreeNode;
function DescAsString: string;
function FindOwner: TObject;
procedure Clear;
constructor Create;
procedure ConsistencyCheck;
procedure WriteDebugReport(const Prefix: string; WithChilds: boolean);
end;
{ TCodeTree }
TCodeTree = class
private
FNodeCount: integer;
public
Root: TCodeTreeNode;
property NodeCount: integer read FNodeCount;
procedure DeleteNode(ANode: TCodeTreeNode);
procedure AddNodeAsLastChild(ParentNode, ANode: TCodeTreeNode);
procedure AddNodeInFrontOf(NextBrotherNode, ANode: TCodeTreeNode);
function FindFirstPosition: integer;
function FindLastPosition: integer;
function ContainsNode(ANode: TCodeTreeNode): boolean;
function FindRootNode(Desc: TCodeTreeNodeDesc): TCodeTreeNode;
function GetLastNode: TCodeTreeNode;
procedure Clear;
constructor Create;
destructor Destroy; override;
procedure ConsistencyCheck;
procedure WriteDebugReport(WithChildren: boolean);
end;
{ TCodeTreeNodeExtension }
TCodeTreeNodeExtension = class
public
Node: TCodeTreeNode;
Txt: string;
ExtTxt1, ExtTxt2, ExtTxt3, ExtTxt4: string;
Position: integer;
Data: Pointer;
Flags: cardinal;
Next: TCodeTreeNodeExtension;
procedure Clear;
constructor Create;
function ConsistencyCheck: integer; // 0 = ok
procedure WriteDebugReport;
function CalcMemSize: PtrUInt;
end;
//-----------------------------------------------------------------------------
// useful functions
function NodeDescriptionAsString(Desc: TCodeTreeNodeDesc): string;
procedure WriteNodeExtTree(Tree: TAVLTree);
function FindCodeTreeNodeExt(Tree: TAVLTree; const Txt: string
): TCodeTreeNodeExtension;
function FindCodeTreeNodeExtAVLNode(Tree: TAVLTree; const Txt: string
): TAVLTreeNode;
function FindCodeTreeNodeExtWithIdentifier(Tree: TAVLTree; Identifier: PChar
): TCodeTreeNodeExtension;
function FindCodeTreeNodeExtAVLNodeWithIdentifier(Tree: TAVLTree;
Identifier: PChar): TAVLTreeNode;
procedure AddNodeExtToTree(var TreeOfNodeExt: TAVLTree;
DefNodeExt: TCodeTreeNodeExtension);
procedure ClearNodeExtData(TreeOfNodeExt: TAVLTree);
procedure DisposeAVLTree(var Tree: TAVLTree);
function CompareTxtWithCodeTreeNodeExt(p: Pointer;
NodeData: pointer): integer;
function CompareIdentifierWithCodeTreeNodeExt(p: Pointer;
NodeData: pointer): integer;
function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer; // Txt
function CompareCodeTreeNodeExtWithPos(NodeData1, NodeData2: pointer): integer; // Position
function CompareCodeTreeNodeExtWithNodeStartPos(
NodeData1, NodeData2: pointer): integer; // Node.StartPos
function CompareCodeTreeNodeExtTxtAndPos(NodeData1, NodeData2: pointer): integer; // Txt, then Position
function CompareCodeTreeNodeExtWithNode(NodeData1, NodeData2: pointer): integer;
function ComparePointerWithCodeTreeNodeExtNode(p: Pointer;
NodeExt: pointer): integer;
type
TOnFindOwnerOfCodeTreeNode = function (ANode: TCodeTreeNode): TObject;
var
OnFindOwnerOfCodeTreeNode: TOnFindOwnerOfCodeTreeNode;
function FindOwnerOfCodeTreeNode(ANode: TCodeTreeNode): TObject;
implementation
function NodeDescriptionAsString(Desc: TCodeTreeNodeDesc): string;
begin
case Desc of
ctnNone: Result:='None';
ctnClass: Result:='Class';
ctnClassInterface: Result:='Class Interface';
ctnDispinterface: Result:='Dispinterface';
ctnObject: Result:='Object';
ctnObjCClass: Result:='ObjCClass';
ctnObjCCategory: Result:='ObjCCategory';
ctnObjCProtocol: Result:='ObjCProtocol';
ctnCPPClass: Result:='CPPClass';
ctnTypeHelper: Result:='Type Helper';
ctnRecordHelper: Result:='Record Helper';
ctnClassInheritance: Result:='Class inheritance';
ctnClassGUID: Result:='GUID';
ctnClassPrivate: Result:='Private';
ctnClassProtected: Result:='Protected';
ctnClassPublic: Result:='Public';
ctnClassPublished: Result:='Published';
ctnClassRequired: Result:='Required section';
ctnClassOptional: Result:='Optional section';
ctnClassClassVar: Result:='Class Var';
ctnClassAbstract: Result:='abstract';
ctnClassSealed: Result:='sealed';
ctnClassExternal: Result:='external';
ctnClassHelper: Result:='Class Helper';
ctnHelperFor: Result:='(helper) for';
ctnProcedure: Result:='Procedure';
ctnProcedureHead: Result:='ProcedureHead';
ctnParameterList: Result:='ParameterList';
ctnBeginBlock: Result:='BeginBlock';
ctnAsmBlock: Result:='AsmBlock';
ctnProgram: Result:='Program';
ctnPackage: Result:='Package';
ctnLibrary: Result:='Library';
ctnUnit: Result:='Unit';
ctnUseUnitNamespace: Result:='Namespace';
ctnUseUnitClearName: Result:='Unit name without namespace';
ctnInterface: Result:='Interface Section';
ctnImplementation: Result:='Implementation';
ctnInitialization: Result:='Initialization';
ctnFinalization: Result:='Finalization';
ctnEndPoint: Result:='End.';
ctnTypeSection: Result:='Type Section';
ctnVarSection: Result:='Var Section';
ctnConstSection: Result:='Const Section';
ctnResStrSection: Result:='Resource String Section';
ctnPropertySection: Result:='Property Section';
ctnUsesSection: Result:='Uses Section';
ctnRequiresSection: Result:='Requires Section';
ctnContainsSection: Result:='Contains Section';
ctnExportsSection: Result:='Exports Section';
ctnTypeDefinition: Result:='Type';
ctnVarDefinition: Result:='Var';
ctnConstDefinition: Result:='Const';
ctnGlobalProperty: Result:='Global Property';
ctnUseUnit: Result:='use unit';
ctnVarArgs: Result:='VarArgs';
ctnProperty: Result:='Property'; // can start with 'class property'
ctnMethodMap: Result:='Method Map';
ctnIdentifier: Result:='Identifier';
ctnOpenArrayType: Result:='Open Array Type';
ctnOfConstType: Result:='Of Const';
ctnRangedArrayType: Result:='Ranged Array Type';
ctnRecordType: Result:='Record Type';
ctnRecordCase: Result:='Record Case';
ctnRecordVariant: Result:='Record Variant';
ctnProcedureType: Result:='Procedure Type';
ctnSetType: Result:='Set Type';
ctnRangeType: Result:='Subrange Type';
ctnEnumerationType: Result:='Enumeration Type';
ctnEnumIdentifier: Result:='Enumeration Identifier';
ctnLabel: Result:='Label Identifier';
ctnTypeType: Result:='''Type'' Type';
ctnFileType: Result:='File Type';
ctnPointerType: Result:='Pointer ^ Type';
ctnClassOfType: Result:='Class Of Type';
ctnVariantType: Result:='Variant Type';
ctnSpecialize: Result:='Specialize Type';
ctnSpecializeType: Result:='Specialize Typename';
ctnSpecializeParams: Result:='Specialize Parameterlist';
ctnSpecializeParam: Result:='Specialize Parameter';
ctnGenericType: Result:='Generic Type';
ctnGenericName: Result:='Generic Type Name';
ctnGenericParams: Result:='Generic Type Params';
ctnGenericParameter: Result:='Generic Type Parameter';
ctnGenericConstraint: Result:='Generic Type Parameter Constraint';
ctnReferenceTo: Result:='Reference To';
ctnConstant: Result:='Constant';
ctnHintModifier: Result:='Hint Modifier';
ctnWithVariable: Result:='With Variable';
ctnWithStatement: Result:='With Statement';
ctnOnBlock: Result:='On Block';
ctnOnIdentifier: Result:='On Identifier';
ctnOnStatement: Result:='On Statement';
else
Result:='invalid descriptor ('+IntToStr(Desc)+')';
end;
end;
procedure WriteNodeExtTree(Tree: TAVLTree);
var
Node: TAVLTreeNode;
NodeExt: TCodeTreeNodeExtension;
begin
if Tree=nil then begin
DebugLn(['WriteNodeExtTree Tree=nil']);
exit;
end;
DebugLn(['WriteNodeExtTree ']);
Node:=Tree.FindLowest;
while Node<>nil do begin
NodeExt:=TCodeTreeNodeExtension(Node.Data);
if NodeExt=nil then
DebugLn([' NodeExt=nil'])
else
NodeExt.WriteDebugReport;
Node:=Tree.FindSuccessor(Node);
end;
end;
function FindCodeTreeNodeExt(Tree: TAVLTree; const Txt: string
): TCodeTreeNodeExtension;
var
AVLNode: TAVLTreeNode;
begin
AVLNode:=FindCodeTreeNodeExtAVLNode(Tree,Txt);
if AVLNode<>nil then
Result:=TCodeTreeNodeExtension(AVLNode.Data)
else
Result:=nil;
end;
function FindCodeTreeNodeExtAVLNode(Tree: TAVLTree; const Txt: string
): TAVLTreeNode;
begin
Result:=Tree.FindKey(Pointer(Txt),@CompareTxtWithCodeTreeNodeExt);
end;
function FindCodeTreeNodeExtWithIdentifier(Tree: TAVLTree; Identifier: PChar
): TCodeTreeNodeExtension;
var
AVLNode: TAVLTreeNode;
begin
AVLNode:=FindCodeTreeNodeExtAVLNodeWithIdentifier(Tree,Identifier);
if AVLNode<>nil then
Result:=TCodeTreeNodeExtension(AVLNode.Data)
else
Result:=nil;
end;
function FindCodeTreeNodeExtAVLNodeWithIdentifier(Tree: TAVLTree;
Identifier: PChar): TAVLTreeNode;
begin
Result:=Tree.FindKey(Identifier,@CompareIdentifierWithCodeTreeNodeExt);
end;
procedure AddNodeExtToTree(var TreeOfNodeExt: TAVLTree;
DefNodeExt: TCodeTreeNodeExtension);
begin
if TreeOfNodeExt=nil then
TreeOfNodeExt:=TAVLTree.Create(@CompareCodeTreeNodeExt);
TreeOfNodeExt.Add(DefNodeExt);
end;
procedure ClearNodeExtData(TreeOfNodeExt: TAVLTree);
var
AVLNode: TAVLTreeNode;
begin
if TreeOfNodeExt=nil then exit;
AVLNode:=TreeOfNodeExt.FindLowest;
while AVLNode<>nil do begin
TCodeTreeNodeExtension(AVLNode.Data).Data:=nil;
AVLNode:=TreeOfNodeExt.FindSuccessor(AVLNode);
end;
end;
procedure DisposeAVLTree(var Tree: TAVLTree);
begin
if Tree=nil then exit;
Tree.FreeAndClear;
Tree.Free;
Tree:=nil;
end;
function CompareTxtWithCodeTreeNodeExt(p: Pointer; NodeData: pointer
): integer;
var
NodeExt: TCodeTreeNodeExtension absolute NodeData;
begin
Result:=CompareTextIgnoringSpace(Ansistring(p),NodeExt.Txt,false);
end;
function CompareIdentifierWithCodeTreeNodeExt(p: Pointer; NodeData: pointer
): integer;
var
NodeExt: TCodeTreeNodeExtension absolute NodeData;
begin
NodeExt:=TCodeTreeNodeExtension(NodeData);
Result:=CompareIdentifierPtrs(p,Pointer(NodeExt.Txt));
end;
function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer;
var
NodeExt1: TCodeTreeNodeExtension absolute NodeData1;
NodeExt2: TCodeTreeNodeExtension absolute NodeData2;
begin
Result:=CompareTextIgnoringSpace(NodeExt1.Txt,NodeExt2.Txt,false);
end;
function CompareCodeTreeNodeExtWithPos(NodeData1, NodeData2: pointer): integer;
var NodeExt1Pos, NodeExt2Pos: integer;
begin
NodeExt1Pos:=TCodeTreeNodeExtension(NodeData1).Position;
NodeExt2Pos:=TCodeTreeNodeExtension(NodeData2).Position;
if NodeExt1Pos<NodeExt2Pos then
Result:=1
else if NodeExt1Pos>NodeExt2Pos then
Result:=-1
else
Result:=0;
end;
function CompareCodeTreeNodeExtWithNodeStartPos(
NodeData1, NodeData2: pointer): integer;
var NodeExt1Pos, NodeExt2Pos: integer;
begin
NodeExt1Pos:=TCodeTreeNodeExtension(NodeData1).Node.StartPos;
NodeExt2Pos:=TCodeTreeNodeExtension(NodeData2).Node.StartPos;
if NodeExt1Pos<NodeExt2Pos then
Result:=1
else if NodeExt1Pos>NodeExt2Pos then
Result:=-1
else
Result:=0;
end;
function CompareCodeTreeNodeExtTxtAndPos(NodeData1, NodeData2: pointer
): integer;
var
NodeExt1: TCodeTreeNodeExtension absolute NodeData1;
NodeExt2: TCodeTreeNodeExtension absolute NodeData2;
begin
Result:=CompareTextIgnoringSpace(NodeExt1.Txt,NodeExt2.Txt,false);
if Result<>0 then exit;
if NodeExt1.Position<NodeExt2.Position then
Result:=1
else if NodeExt1.Position>NodeExt2.Position then
Result:=-1
else
Result:=0;
end;
function CompareCodeTreeNodeExtWithNode(NodeData1, NodeData2: pointer): integer;
var
Node1: TCodeTreeNode;
Node2: TCodeTreeNode;
begin
Node1:=TCodeTreeNodeExtension(NodeData1).Node;
Node2:=TCodeTreeNodeExtension(NodeData2).Node;
if Pointer(Node1)>Pointer(Node2) then
Result:=1
else if Pointer(Node1)<Pointer(Node2) then
Result:=-1
else
Result:=0;
end;
function ComparePointerWithCodeTreeNodeExtNode(p: Pointer; NodeExt: pointer
): integer;
var
Node: TCodeTreeNode;
begin
Node:=TCodeTreeNodeExtension(NodeExt).Node;
if p>Pointer(Node) then
Result:=1
else if p<Pointer(Node) then
Result:=-1
else
Result:=0;
end;
function FindOwnerOfCodeTreeNode(ANode: TCodeTreeNode): TObject;
begin
if Assigned(OnFindOwnerOfCodeTreeNode) then
Result:=OnFindOwnerOfCodeTreeNode(ANode)
else
Result:=nil;
end;
{ TCodeTreeNode }
constructor TCodeTreeNode.Create;
begin
StartPos:=-1;
EndPos:=-1;
end;
procedure TCodeTreeNode.Clear;
begin
Desc:=ctnNone;
SubDesc:=ctnsNone;
Parent:=nil;
NextBrother:=nil;
PriorBrother:=nil;
FirstChild:=nil;
LastChild:=nil;
StartPos:=-1;
EndPos:=-1;
Cache:=nil;
end;
function TCodeTreeNode.Next: TCodeTreeNode;
begin
if FirstChild<>nil then begin
Result:=FirstChild;
end else begin
Result:=Self;
while (Result<>nil) and (Result.NextBrother=nil) do
Result:=Result.Parent;
if Result<>nil then Result:=Result.NextBrother;
end;
end;
function TCodeTreeNode.NextSkipChilds: TCodeTreeNode;
begin
Result:=Self;
while (Result<>nil) and (Result.NextBrother=nil) do
Result:=Result.Parent;
if Result<>nil then Result:=Result.NextBrother;
end;
function TCodeTreeNode.Prior: TCodeTreeNode;
begin
if PriorBrother<>nil then begin
Result:=PriorBrother;
while Result.LastChild<>nil do
Result:=Result.LastChild;
end else
Result:=Parent;
end;
function TCodeTreeNode.GetNodeInFrontOfPos(p: integer): TCodeTreeNode;
// if p<=StartPos then next node with Node.StartPos<=p
// else returns the next child node with Node.EndPos<=p
begin
if p<=StartPos then begin
if (Parent<>nil) and (p<Parent.StartPos) then begin
// p is in front of parent
Result:=Parent;
while (Result<>nil) and (p<Result.StartPos) do
Result:=Result.Parent;
end else begin
// p is in parent and in front of node => prior brothers
Result:=PriorBrother;
while (Result<>nil) and (p<Result.StartPos) do
Result:=Result.PriorBrother;
end;
if Result=nil then exit;
// p is in Result => search in children
Result:=Result.GetNodeInFrontOfPos(p);
end else begin
Result:=LastChild;
while (Result<>nil) and (Result.EndPos>p) do
Result:=Result.PriorBrother;
if Result=nil then exit;
while (Result.LastChild<>nil) and (Result.LastChild.EndPos=Result.EndPos) do
Result:=Result.LastChild;
end;
end;
procedure TCodeTreeNode.ConsistencyCheck;
begin
if (EndPos>0) and (StartPos>EndPos) then
raise Exception.Create('');
if (Parent<>nil) then begin
if (PriorBrother=nil) and (Parent.FirstChild<>Self) then
raise Exception.Create('');
if (NextBrother=nil) and (Parent.LastChild<>Self) then
raise Exception.Create('');
end;
if (NextBrother<>nil) and (NextBrother.Parent<>Parent) then
raise Exception.Create('');
if (PriorBrother<>nil) and (PriorBrother.Parent<>Parent) then
raise Exception.Create('');
if (FirstChild<>nil) and (FirstChild.Parent<>Self) then
raise Exception.Create('');
if (FirstChild=nil) <> (LastChild=nil) then
raise Exception.Create('');
if (NextBrother<>nil) and (NextBrother.PriorBrother<>Self) then
raise Exception.Create('');
if (PriorBrother<>nil) and (PriorBrother.NextBrother<>Self) then
raise Exception.Create('');
if (FirstChild<>nil) then
FirstChild.ConsistencyCheck;
if NextBrother<>nil then
NextBrother.ConsistencyCheck;
end;
procedure TCodeTreeNode.WriteDebugReport(const Prefix: string;
WithChilds: boolean);
var
Node: TCodeTreeNode;
begin
DebugLn([Prefix,DescAsString,' Range=',StartPos,'..',EndPos,' Cache=',DbgSName(Cache)]);
if WithChilds then begin
Node:=FirstChild;
while Node<>nil do begin
Node.WriteDebugReport(Prefix+' ',true);
Node:=Node.NextBrother;
end;
end;
end;
function TCodeTreeNode.HasAsParent(Node: TCodeTreeNode): boolean;
var CurNode: TCodeTreeNode;
begin
Result:=false;
if Node=nil then exit;
CurNode:=Parent;
while (CurNode<>nil) do begin
if CurNode=Node then begin
Result:=true;
exit;
end;
CurNode:=CurNode.Parent;
end;
end;
function TCodeTreeNode.HasAsChild(Node: TCodeTreeNode): boolean;
begin
Result:=false;
if Node=nil then exit;
Result:=Node.HasAsParent(Self);
end;
function TCodeTreeNode.HasParentOfType(ParentDesc: TCodeTreeNodeDesc): boolean;
var ANode: TCodeTreeNode;
begin
ANode:=Parent;
while (ANode<>nil) and (ANode.Desc<>ParentDesc) do
ANode:=ANode.Parent;
Result:=ANode<>nil;
end;
function TCodeTreeNode.HasAsRoot(RootNode: TCodeTreeNode): boolean;
begin
Result:=(RootNode<>nil) and (RootNode=GetRoot);
end;
function TCodeTreeNode.GetNodeOfType(ADesc: TCodeTreeNodeDesc
): TCodeTreeNode;
begin
Result:=Self;
while (Result<>nil) and (Result.Desc<>ADesc) do
Result:=Result.Parent;
end;
function TCodeTreeNode.GetNodeOfTypes(Descriptors: array of TCodeTreeNodeDesc
): TCodeTreeNode;
var
i: Integer;
begin
Result:=Self;
while (Result<>nil) do begin
for i:=Low(Descriptors) to High(Descriptors) do
if Result.Desc=Descriptors[i] then exit;
Result:=Result.Parent;
end;
end;
function TCodeTreeNode.GetTopMostNodeOfType(ADesc: TCodeTreeNodeDesc
): TCodeTreeNode;
var
Node: TCodeTreeNode;
begin
Result:=nil;
Node:=Self;
while Node<>nil do begin
if Node.Desc=ADesc then
Result:=Node;
Node:=Node.Parent;
end;
end;
function TCodeTreeNode.GetFindContextParent: TCodeTreeNode;
begin
Result:=Parent;
while (Result<>nil) and (not (Result.Desc in AllFindContextDescs)) do
Result:=Result.Parent;
end;
function TCodeTreeNode.GetLevel: integer;
var ANode: TCodeTreeNode;
begin
Result:=0;
ANode:=Parent;
while ANode<>nil do begin
inc(Result);
ANode:=ANode.Parent;
end;
end;
function TCodeTreeNode.GetLastNode: TCodeTreeNode;
begin
Result:=Self;
while Result.LastChild<>nil do
Result:=Result.LastChild;
end;
function TCodeTreeNode.DescAsString: string;
begin
if Self=nil then
Result:='nil'
else
Result:=NodeDescriptionAsString(Desc);
end;
function TCodeTreeNode.GetRoot: TCodeTreeNode;
begin
Result:=Self;
while (Result.Parent<>nil) do Result:=Result.Parent;
while (Result.PriorBrother<>nil) do Result:=Result.PriorBrother;
end;
function TCodeTreeNode.ChildCount: integer;
var
Node: TCodeTreeNode;
begin
Result:=0;
Node:=FirstChild;
while Node<>nil do begin
inc(Result);
Node:=Node.NextBrother;
end;
end;
function TCodeTreeNode.FindOwner: TObject;
begin
Result:=FindOwnerOfCodeTreeNode(Self);
end;
{ TCodeTree }
constructor TCodeTree.Create;
begin
Root:=nil;
FNodeCount:=0;
end;
destructor TCodeTree.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TCodeTree.Clear;
begin
while Root<>nil do
DeleteNode(Root);
end;
procedure TCodeTree.DeleteNode(ANode: TCodeTreeNode);
begin
if ANode=nil then exit;
if ANode=Root then Root:=ANode.NextBrother;
while (ANode.FirstChild<>nil) do DeleteNode(ANode.FirstChild);
with ANode do begin
if (Parent<>nil) then begin
if (Parent.FirstChild=ANode) then
Parent.FirstChild:=NextBrother;
if (Parent.LastChild=ANode) then
Parent.LastChild:=PriorBrother;
Parent:=nil;
end;
if NextBrother<>nil then NextBrother.PriorBrother:=PriorBrother;
if PriorBrother<>nil then PriorBrother.NextBrother:=NextBrother;
NextBrother:=nil;
PriorBrother:=nil;
end;
dec(FNodeCount);
ANode.Clear; // clear to spot dangling pointers early
ANode.Free;
end;
procedure TCodeTree.AddNodeAsLastChild(ParentNode, ANode: TCodeTreeNode);
var TopNode: TCodeTreeNode;
begin
ANode.Parent:=ParentNode;
if Root=nil then begin
// set as root
Root:=ANode;
while Root.Parent<>nil do Root:=Root.Parent;
end else if ParentNode<>nil then begin
if ParentNode.FirstChild=nil then begin
// add as first child
ParentNode.FirstChild:=ANode;
ParentNode.LastChild:=ANode;
end else begin
// add as last child
ANode.PriorBrother:=ParentNode.LastChild;
ParentNode.LastChild:=ANode;
if ANode.PriorBrother<>nil then ANode.PriorBrother.NextBrother:=ANode;
end;
end else begin
// add as last brother of top nodes
TopNode:=Root;
while (TopNode.NextBrother<>nil) do TopNode:=TopNode.NextBrother;
ANode.PriorBrother:=TopNode;
ANode.PriorBrother.NextBrother:=ANode;
end;
inc(FNodeCount);
end;
procedure TCodeTree.AddNodeInFrontOf(NextBrotherNode, ANode: TCodeTreeNode);
begin
ANode.Parent:=NextBrotherNode.Parent;
ANode.NextBrother:=NextBrotherNode;
ANode.PriorBrother:=NextBrotherNode.PriorBrother;
NextBrotherNode.PriorBrother:=ANode;
if ANode.PriorBrother<>nil then
ANode.PriorBrother.NextBrother:=ANode;
end;
function TCodeTree.FindFirstPosition: integer;
begin
Result:=-1;
if Root=nil then exit;
Result:=Root.StartPos;
end;
function TCodeTree.FindLastPosition: integer;
var
ANode: TCodeTreeNode;
begin
Result:=-1;
if Root=nil then exit;
ANode:=Root;
while (ANode.NextBrother<>nil) do ANode:=ANode.NextBrother;
//debugln('TCodeTree.FindLastPosition A ',Anode.DescAsString,' ANode.StartPos=',dbgs(ANode.StartPos),' ANode.EndPos=',dbgs(ANode.EndPos));
Result:=ANode.EndPos;
end;
function TCodeTree.ContainsNode(ANode: TCodeTreeNode): boolean;
begin
if ANode=nil then exit(false);
while ANode.Parent<>nil do ANode:=ANode.Parent;
while ANode.PriorBrother<>nil do ANode:=ANode.PriorBrother;
Result:=ANode=Root;
end;
function TCodeTree.FindRootNode(Desc: TCodeTreeNodeDesc): TCodeTreeNode;
begin
Result:=Root;
while (Result<>nil) and (Result.Desc<>Desc) do
Result:=Result.NextBrother;
end;
function TCodeTree.GetLastNode: TCodeTreeNode;
begin
Result:=Root;
if Result=nil then exit;
while Result.NextBrother<>nil do
Result:=Result.NextBrother;
Result:=Result.GetLastNode;
end;
procedure TCodeTree.ConsistencyCheck;
var RealNodeCount: integer;
procedure CountNodes(ANode: TCodeTreeNode);
begin
if ANode=nil then exit;
inc(RealNodeCount);
CountNodes(ANode.FirstChild);
CountNodes(ANode.NextBrother);
end;
begin
if Root<>nil then begin
if Root.Parent<>nil then
raise Exception.Create('');
Root.ConsistencyCheck;
end;
RealNodeCount:=0;
CountNodes(Root);
if RealNodeCount<>FNodeCount then
raise Exception.Create('');
end;
procedure TCodeTree.WriteDebugReport(WithChildren: boolean);
begin
DebugLn('[TCodeTree.WriteDebugReport] Root=',dbgs(Root<>nil));
if Root<>nil then
Root.WriteDebugReport(' ',WithChildren);
end;
{ TCodeTreeNodeExtension }
procedure TCodeTreeNodeExtension.Clear;
begin
Next:=nil;
Txt:='';
ExtTxt1:='';
ExtTxt2:='';
ExtTxt3:='';
ExtTxt4:='';
Node:=nil;
Position:=-1;
Data:=nil;
Flags:=0;
end;
constructor TCodeTreeNodeExtension.Create;
begin
Position:=-1;
end;
function TCodeTreeNodeExtension.ConsistencyCheck: integer;
// 0 = ok
begin
Result:=0;
end;
procedure TCodeTreeNodeExtension.WriteDebugReport;
begin
// nothing special
DbgOut(' ');
if Node<>nil then
DbgOut('Node=',NodeDescriptionAsString(Node.Desc))
else
DbgOut('Node=nil');
DbgOut(' Position=',dbgs(Position),' Txt="'+Txt+'" ExtTxt1="'+ExtTxt1+'" ExtTxt2="'+ExtTxt2+'" ExtTxt3="'+ExtTxt3+'" ExtTxt4="'+ExtTxt4+'"');
debugln;
end;
function TCodeTreeNodeExtension.CalcMemSize: PtrUInt;
begin
Result:=PtrUInt(InstanceSize)
+MemSizeString(Txt)
+MemSizeString(ExtTxt1)
+MemSizeString(ExtTxt2)
+MemSizeString(ExtTxt3)
+MemSizeString(ExtTxt4);
end;
end.
Reference in New Issue View Git Blame Copy Permalink