paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-12 10:09:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ objects support

Browse Source
This commit is contained in:
peter 1999-04-08 10:17:42 +00:00
parent 8751ac02ca
commit e4db3c0e10
1 changed files with 345 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

379
compiler/browcol.pas
View File

@ -34,6 +34,10 @@ const
RecordTypes : set of tsymtyp = RecordTypes : set of tsymtyp =
([typesym,unitsym,programsym]); ([typesym,unitsym,programsym]);
sfRecord = $00000001;
sfObject = $00000002;
sfClass = $00000004;
type type
TStoreCollection = object(TStringCollection) TStoreCollection = object(TStringCollection)
function Add(const S: string): PString; function Add(const S: string): PString;
@ -60,6 +64,14 @@ type
destructor Done; virtual; destructor Done; virtual;
end; end;
PSymbolMemInfo = ^TSymbolMemInfo;
TSymbolMemInfo = record
Addr : longint;
LocalAddr : longint;
Size : longint;
PushSize : longint;
end;
PSymbol = ^TSymbol; PSymbol = ^TSymbol;
TSymbol = object(TObject) TSymbol = object(TObject)
Name : PString; Name : PString;
@ -69,10 +81,13 @@ type
Items : PSymbolCollection; Items : PSymbolCollection;
DType : PString; DType : PString;
VType : PString; VType : PString;
Ancestor : PString; ObjectID : longint;
IsRecord : boolean; AncestorID : longint;
IsClass : boolean; Ancestor : PSymbol;
constructor Init(const AName: string; ATyp: tsymtyp; AParams: string); Flags : longint;
MemInfo : PSymbolMemInfo;
constructor Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo);
procedure SetMemInfo(const AMemInfo: TSymbolMemInfo);
function GetReferenceCount: Sw_integer; function GetReferenceCount: Sw_integer;
function GetReference(Index: Sw_integer): PReference; function GetReference(Index: Sw_integer): PReference;
function GetItemCount: Sw_integer; function GetItemCount: Sw_integer;
@ -83,6 +98,25 @@ type
destructor Done; virtual; destructor Done; virtual;
end; end;
PObjectSymbolCollection = ^TObjectSymbolCollection;
PObjectSymbol = ^TObjectSymbol;
TObjectSymbol = object(TObject)
Parent : PObjectSymbol;
Symbol : PSymbol;
Expanded : boolean;
constructor Init(AParent: PObjectSymbol; ASymbol: PSymbol);
constructor InitName(const AName: string);
function GetName: string;
function GetDescendantCount: sw_integer;
function GetDescendant(Index: sw_integer): PObjectSymbol;
procedure AddDescendant(P: PObjectSymbol);
destructor Done; virtual;
private
Name: PString;
Descendants: PObjectSymbolCollection;
end;
TSymbolCollection = object(TSortedCollection) TSymbolCollection = object(TSortedCollection)
function At(Index: Sw_Integer): PSymbol; function At(Index: Sw_Integer): PSymbol;
procedure Insert(Item: Pointer); virtual; procedure Insert(Item: Pointer); virtual;
@ -95,6 +129,19 @@ type
function LookUp(const S: string; var Idx: sw_integer): string; virtual; function LookUp(const S: string; var Idx: sw_integer): string; virtual;
end; end;
PIDSortedSymbolCollection = ^TIDSortedSymbolCollection;
TIDSortedSymbolCollection = object(TSymbolCollection)
function Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
procedure Insert(Item: Pointer); virtual;
function SearchSymbolByID(AID: longint): PSymbol;
end;
TObjectSymbolCollection = object(TSortedCollection)
function Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
function LookUp(const S: string; var Idx: sw_integer): string; virtual;
function At(Index: Sw_Integer): PObjectSymbol;
end;
TReferenceCollection = object(TCollection) TReferenceCollection = object(TCollection)
function At(Index: Sw_Integer): PReference; function At(Index: Sw_Integer): PReference;
end; end;
@ -103,6 +150,7 @@ const
Modules : PSymbolCollection = nil; Modules : PSymbolCollection = nil;
ModuleNames : PModuleNameCollection = nil; ModuleNames : PModuleNameCollection = nil;
TypeNames : PTypeNameCollection = nil; TypeNames : PTypeNameCollection = nil;
ObjectTree : PObjectSymbol = nil;
procedure DisposeBrowserCol; procedure DisposeBrowserCol;
@ -111,12 +159,15 @@ procedure CreateBrowserCol;
procedure InitBrowserCol; procedure InitBrowserCol;
procedure DoneBrowserCol; procedure DoneBrowserCol;
procedure BuildObjectInfo;
function SearchObjectForSymbol(O: PSymbol): PObjectSymbol;
implementation implementation
uses uses
Drivers,Views,App, Drivers,Views,App,
aasm,globtype,globals,files; aasm,globtype,globals,files,comphook;
{**************************************************************************** {****************************************************************************
Helpers Helpers
@ -267,6 +318,96 @@ begin
LookUp:=FoundS; LookUp:=FoundS;
end; end;
{****************************************************************************
TIDSortedSymbolCollection
****************************************************************************}
function TIDSortedSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
var K1: PSymbol absolute Key1;
K2: PSymbol absolute Key2;
R: Sw_integer;
begin
if K1^.ObjectID<K2^.ObjectID then R:=-1 else
if K1^.ObjectID>K2^.ObjectID then R:=1 else
R:=0;
Compare:=R;
end;
procedure TIDSortedSymbolCollection.Insert(Item: Pointer);
begin
TSortedCollection.Insert(Item);
end;
function TIDSortedSymbolCollection.SearchSymbolByID(AID: longint): PSymbol;
var S: TSymbol;
Index: sw_integer;
P: PSymbol;
begin
S.ObjectID:=AID;
if Search(@S,Index)=false then P:=nil else
P:=At(Index);
SearchSymbolByID:=P;
end;
{****************************************************************************
TObjectSymbolCollection
****************************************************************************}
function TObjectSymbolCollection.At(Index: Sw_Integer): PObjectSymbol;
begin
At:=inherited At(Index);
end;
function TObjectSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
var K1: PObjectSymbol absolute Key1;
K2: PObjectSymbol absolute Key2;
R: Sw_integer;
S1,S2: string;
begin
S1:=Upper(K1^.GetName);
S2:=Upper(K2^.GetName);
if S1<S2 then R:=-1 else
if S1>S2 then R:=1 else
R:=0;
Compare:=R;
end;
function TObjectSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string;
var OLI,ORI,Left,Right,Mid: integer;
LeftP,RightP,MidP: PObjectSymbol;
RL: integer;
LeftS,MidS,RightS: string;
FoundS: string;
UpS : string;
begin
Idx:=-1; FoundS:='';
Left:=0; Right:=Count-1;
UpS:=Upper(S);
if Left<Right then
begin
while (Left<Right) do
begin
OLI:=Left; ORI:=Right;
Mid:=Left+(Right-Left) div 2;
LeftP:=At(Left); RightP:=At(Right); MidP:=At(Mid);
LeftS:=Upper(LeftP^.GetName); MidS:=Upper(MidP^.GetName);
RightS:=Upper(RightP^.GetName);
if copy(MidS,1,length(UpS))=UpS then
begin
Idx:=Mid; FoundS:=copy(MidS,1,length(S));
end;
{ else}
if UpS<MidS then
Right:=Mid
else
Left:=Mid;
if (OLI=Left) and (ORI=Right) then
Break;
end;
end;
LookUp:=FoundS;
end;
{**************************************************************************** {****************************************************************************
TReference TReference
****************************************************************************} ****************************************************************************}
@ -294,10 +435,12 @@ end;
TSymbol TSymbol
****************************************************************************} ****************************************************************************}
constructor TSymbol.Init(const AName: string; ATyp: tsymtyp; AParams: string); constructor TSymbol.Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo);
begin begin
inherited Init; inherited Init;
Name:=NewStr(AName); Typ:=ATyp; Name:=NewStr(AName); Typ:=ATyp;
if AMemInfo<>nil then
SetMemInfo(AMemInfo^);
New(References, Init(20,50)); New(References, Init(20,50));
if ATyp in RecordTypes then if ATyp in RecordTypes then
begin begin
@ -305,6 +448,12 @@ begin
end; end;
end; end;
procedure TSymbol.SetMemInfo(const AMemInfo: TSymbolMemInfo);
begin
if MemInfo=nil then New(MemInfo);
Move(AMemInfo,MemInfo^,SizeOf(MemInfo^));
end;
function TSymbol.GetReferenceCount: Sw_integer; function TSymbol.GetReferenceCount: Sw_integer;
var Count: Sw_integer; var Count: Sw_integer;
begin begin
@ -349,18 +498,18 @@ begin
S:=S+' '; S:=S+' ';
end; end;
S:=S+' '+GetName; S:=S+' '+GetName;
if IsRecord then if (Flags and sfRecord)<>0 then
S:=S+' = record' S:=S+' = record'
else else
if Ancestor<>nil then if (Flags and sfObject)<>0 then
begin begin
S:=S+' = '; S:=S+' = ';
if IsClass then if (Flags and sfClass)<>0 then
S:=S+'class' S:=S+'class'
else else
S:=S+'object'; S:=S+'object';
if Ancestor^<>'.' then if Ancestor<>nil then
S:=S+'('+Ancestor^+')'; S:=S+'('+Ancestor^.GetName+')';
end end
else else
begin begin
@ -405,6 +554,8 @@ end;
destructor TSymbol.Done; destructor TSymbol.Done;
begin begin
inherited Done; inherited Done;
if assigned(MemInfo) then
Dispose(MemInfo);
if assigned(References) then if assigned(References) then
Dispose(References, Done); Dispose(References, Done);
if assigned(Items) then if assigned(Items) then
@ -422,6 +573,54 @@ begin
end; end;
constructor TObjectSymbol.Init(AParent: PObjectSymbol; ASymbol: PSymbol);
begin
inherited Init;
Parent:=AParent;
Symbol:=ASymbol;
end;
constructor TObjectSymbol.InitName(const AName: string);
begin
inherited Init;
Name:=NewStr(AName);
end;
function TObjectSymbol.GetName: string;
begin
if Name<>nil then
GetName:=Name^
else
GetName:=Symbol^.GetName;
end;
function TObjectSymbol.GetDescendantCount: sw_integer;
var Count: sw_integer;
begin
if Descendants=nil then Count:=0 else
Count:=Descendants^.Count;
GetDescendantCount:=Count;
end;
function TObjectSymbol.GetDescendant(Index: sw_integer): PObjectSymbol;
begin
GetDescendant:=Descendants^.At(Index);
end;
procedure TObjectSymbol.AddDescendant(P: PObjectSymbol);
begin
if Descendants=nil then
New(Descendants, Init(50,10));
Descendants^.Insert(P);
end;
destructor TObjectSymbol.Done;
begin
if Assigned(Name) then DisposeStr(Name); Name:=nil;
if Assigned(Descendants) then Dispose(Descendants, Done); Descendants:=nil;
inherited Done;
end;
{***************************************************************************** {*****************************************************************************
Main Routines Main Routines
*****************************************************************************} *****************************************************************************}
@ -443,6 +642,11 @@ begin
dispose(TypeNames,Done); dispose(TypeNames,Done);
TypeNames:=nil; TypeNames:=nil;
end; end;
if assigned(ObjectTree) then
begin
Dispose(ObjectTree, Done);
ObjectTree:=nil;
end;
end; end;
@ -714,7 +918,8 @@ procedure CreateBrowserCol;
end; end;
end; end;
end; end;
var MemInfo: TSymbolMemInfo;
ObjDef: pobjectdef;
begin begin
if not Assigned(Table) then if not Assigned(Table) then
Exit; Exit;
@ -728,11 +933,10 @@ procedure CreateBrowserCol;
end;} end;}
for I:=1 to symcount do for I:=1 to symcount do
begin begin
Symbol:=nil;
Sym:=Table^.GetsymNr(I); Sym:=Table^.GetsymNr(I);
if Sym=nil then Continue; if Sym=nil then Continue;
ParamCount:=0; ParamCount:=0;
New(Symbol, Init(Sym^.Name,Sym^.Typ,'')); New(Symbol, Init(Sym^.Name,Sym^.Typ,'',nil));
case Sym^.Typ of case Sym^.Typ of
varsym : varsym :
with pvarsym(sym)^ do with pvarsym(sym)^ do
@ -743,6 +947,11 @@ procedure CreateBrowserCol;
else else
SetVType(Symbol,GetDefinitionStr(definition)); SetVType(Symbol,GetDefinitionStr(definition));
ProcessDefIfStruct(definition); ProcessDefIfStruct(definition);
MemInfo.Addr:=address;
MemInfo.LocalAddr:=localaddress;
MemInfo.Size:=getsize;
MemInfo.PushSize:=getpushsize;
Symbol^.SetMemInfo(MemInfo);
end; end;
constsym : constsym :
SetDType(Symbol,GetConstValueName(pconstsym(sym))); SetDType(Symbol,GetConstValueName(pconstsym(sym)));
@ -802,17 +1011,18 @@ procedure CreateBrowserCol;
objectdef : objectdef :
with pobjectdef(definition)^ do with pobjectdef(definition)^ do
begin begin
if childof=nil then ObjDef:=childof;
S:='.' Symbol^.ObjectID:=longint(definition);
else if ObjDef<>nil then
S:=childof^.name^; Symbol^.AncestorID:=longint(ObjDef);{TypeNames^.Add(S);}
Symbol^.Ancestor:=TypeNames^.Add(S); Symbol^.Flags:=(Symbol^.Flags or sfObject);
Symbol^.IsClass:=(options and oo_is_class)<>0; if (options and oo_is_class)<>0 then
Symbol^.Flags:=(Symbol^.Flags or sfClass);
ProcessSymTable(Symbol,Symbol^.Items,pobjectdef(definition)^.publicsyms); ProcessSymTable(Symbol,Symbol^.Items,pobjectdef(definition)^.publicsyms);
end; end;
recorddef : recorddef :
begin begin
Symbol^.IsRecord:=true; Symbol^.Flags:=(Symbol^.Flags or sfRecord);
ProcessSymTable(Symbol,Symbol^.Items,precdef(definition)^.symtable); ProcessSymTable(Symbol,Symbol^.Items,precdef(definition)^.symtable);
end; end;
filedef : filedef :
@ -823,11 +1033,8 @@ procedure CreateBrowserCol;
end; end;
end; end;
Ref:=Sym^.defref; Ref:=Sym^.defref;
If assigned(Symbol) then while Assigned(Symbol) and assigned(Ref) do
begin begin
Owner^.Insert(Symbol);
while Assigned(Symbol) and assigned(Ref) do
begin
inputfile:=get_source_file(ref^.moduleindex,ref^.posinfo.fileindex); inputfile:=get_source_file(ref^.moduleindex,ref^.posinfo.fileindex);
if Assigned(inputfile) and Assigned(inputfile^.name) then if Assigned(inputfile) and Assigned(inputfile^.name) then
begin begin
@ -836,8 +1043,9 @@ procedure CreateBrowserCol;
Symbol^.References^.Insert(Reference); Symbol^.References^.Insert(Reference);
end; end;
Ref:=Ref^.nextref; Ref:=Ref^.nextref;
end; end;
end; if Assigned(Symbol) then
Owner^.Insert(Symbol);
end; end;
end; end;
@ -854,7 +1062,7 @@ begin
t:=psymtable(hp^.globalsymtable); t:=psymtable(hp^.globalsymtable);
if assigned(t) then if assigned(t) then
begin begin
New(UnitS, Init(T^.Name^,unitsym,'')); New(UnitS, Init(T^.Name^,unitsym,'',nil));
Modules^.Insert(UnitS); Modules^.Insert(UnitS);
ProcessSymTable(UnitS,UnitS^.Items,T); ProcessSymTable(UnitS,UnitS^.Items,T);
if cs_local_browser in aktmoduleswitches then if cs_local_browser in aktmoduleswitches then
@ -866,7 +1074,113 @@ begin
end; end;
hp:=pmodule(hp^.next); hp:=pmodule(hp^.next);
end; end;
BuildObjectInfo;
end;
procedure BuildObjectInfo;
var C: PIDSortedSymbolCollection;
ObjectC: PObjectSymbolCollection;
ObjectsSymbol: PObjectSymbol;
procedure InsertSymbolCollection(Symbols: PSymbolCollection);
var I: sw_integer;
P: PSymbol;
begin
for I:=0 to Symbols^.Count-1 do
begin
P:=Symbols^.At(I);
if (P^.Flags and sfObject)<>0 then
C^.Insert(P);
if P^.Items<>nil then
InsertSymbolCollection(P^.Items);
end;
end;
function SearchObjectForSymbol(O: PSymbol): PObjectSymbol;
var I,Idx: sw_integer;
OS,P: PObjectSymbol;
begin
P:=nil;
for I:=0 to ObjectC^.Count-1 do
begin
OS:=ObjectC^.At(I);
if OS^.Symbol=O then
begin P:=OS; Break; end;
end;
SearchObjectForSymbol:=P;
end;
procedure BuildTree;
var I: sw_integer;
Symbol: PSymbol;
Parent,OS: PObjectSymbol;
begin
I:=0;
while (I<C^.Count) do
begin
Symbol:=C^.At(I);
if Symbol^.Ancestor=nil then
Parent:=ObjectsSymbol
else
Parent:=SearchObjectForSymbol(Symbol^.Ancestor);
if Parent<>nil then
begin
New(OS, Init(Parent, Symbol));
Parent^.AddDescendant(OS);
ObjectC^.Insert(OS);
C^.AtDelete(I);
end
else
Inc(I);
end;
end;
var Pass: integer;
I: sw_integer;
P: PSymbol;
begin
New(C, Init(1000,5000));
InsertSymbolCollection(Modules);
{ --- Resolve ancestor<->descendant references --- }
for I:=0 to C^.Count-1 do
begin
P:=C^.At(I);
if P^.AncestorID<>0 then
P^.Ancestor:=C^.SearchSymbolByID(P^.AncestorID);
end;
{ --- Build object tree --- }
if assigned(ObjectTree) then Dispose(ObjectTree, Done);
New(ObjectsSymbol, InitName('Objects'));
ObjectTree:=ObjectsSymbol;
New(ObjectC, Init(C^.Count,100));
Pass:=0;
if C^.Count>0 then
repeat
BuildTree;
Inc(Pass);
until (C^.Count=0) or (Pass>20); { more than 20 levels ? - then there must be a bug }
ObjectC^.DeleteAll; Dispose(ObjectC, Done);
C^.DeleteAll; Dispose(C, Done);
end;
function SearchObjectForSymbol(O: PSymbol): PObjectSymbol;
var I,Idx: sw_integer;
OS,P: PObjectSymbol;
ObjectC: PObjectSymbolCollection;
begin
P:=nil;
if ObjectTree<>nil then
begin
ObjectC:=ObjectTree^.Descendants;
for I:=0 to ObjectC^.Count-1 do
begin
OS:=ObjectC^.At(I);
if OS^.Symbol=O then
begin P:=OS; Break; end;
end;
end;
SearchObjectForSymbol:=P;
end; end;
@ -903,11 +1217,8 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.10 1999-03-26 11:39:25 pierre Revision 1.11 1999-04-08 10:17:42 peter
* avoid empty symbols + objects support
Revision 1.9 1999/03/24 23:16:44 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.8 1999/03/03 01:38:11 pierre Revision 1.8 1999/03/03 01:38:11 pierre
* avoid infinite recursion in ProcessDefIfStruct * avoid infinite recursion in ProcessDefIfStruct