From adf1d0e50219ca4160f8a5d47423165f36f0f742 Mon Sep 17 00:00:00 2001 From: martin Date: Mon, 4 Nov 2013 23:42:06 +0000 Subject: [PATCH] FPDebug: refactor, break circle unit ref git-svn-id: trunk@43374 - --- .gitattributes | 1 + components/fpdebug/app/fpd/fpdcommand.pas | 2 +- components/fpdebug/app/fpd/fpdloop.pas | 2 +- components/fpdebug/app/fpd/fpdpeimage.pas | 2 +- components/fpdebug/fpdbgclasses.pp | 677 +---------------- components/fpdebug/fpdbgdisasx86.pp | 2 +- components/fpdebug/fpdbgdwarf.pas | 2 +- components/fpdebug/fpdbginfo.pas | 685 ++++++++++++++++++ components/fpdebug/fpdbgsymbols.pas | 2 +- components/fpdebug/fpdebug.lpk | 8 +- components/fpdebug/fpdebug.pas | 2 +- components/fpdebug/fppascalbuilder.pas | 2 +- components/fpdebug/fppascalparser.pas | 2 +- .../fpdebug/test/testapps/testprog1.pas | 177 ++++- components/fpdebug/test/testtypeinfo.pas | 127 +++- debugger/fpgdbmidebugger.pp | 26 +- 16 files changed, 1008 insertions(+), 711 deletions(-) create mode 100644 components/fpdebug/fpdbginfo.pas diff --git a/.gitattributes b/.gitattributes index f3d28acbf7..daf5a4bd0b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1227,6 +1227,7 @@ components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal components/fpdebug/fpdbgdisasx86.pp svneol=native#text/plain components/fpdebug/fpdbgdwarf.pas svneol=native#text/pascal components/fpdebug/fpdbgdwarfconst.pas svneol=native#text/pascal +components/fpdebug/fpdbginfo.pas svneol=native#text/pascal components/fpdebug/fpdbgloader.pp svneol=native#text/pascal components/fpdebug/fpdbgpetypes.pp svneol=native#text/pascal components/fpdebug/fpdbgsymbols.pas svneol=native#text/pascal diff --git a/components/fpdebug/app/fpd/fpdcommand.pas b/components/fpdebug/app/fpd/fpdcommand.pas index 4acf383834..b3cc143748 100644 --- a/components/fpdebug/app/fpd/fpdcommand.pas +++ b/components/fpdebug/app/fpd/fpdcommand.pas @@ -36,7 +36,7 @@ unit FPDCommand; interface uses - SysUtils, Classes, Windows, LCLProc, FpDbgWinExtra, FpDbgClasses; + SysUtils, Classes, Windows, LCLProc, FpDbgWinExtra, FpDbgInfo, FpDbgClasses; procedure HandleCommand(ACommand: String); diff --git a/components/fpdebug/app/fpd/fpdloop.pas b/components/fpdebug/app/fpd/fpdloop.pas index 5c2620ccc0..ea2dde0392 100644 --- a/components/fpdebug/app/fpd/fpdloop.pas +++ b/components/fpdebug/app/fpd/fpdloop.pas @@ -37,7 +37,7 @@ unit FPDLoop; interface uses - Windows, Classes, SysUtils, FileUtil, FpDbgClasses, FpDbgWinExtra, FpDbgDisasX86; + Windows, Classes, SysUtils, FileUtil, FpDbgInfo, FpDbgClasses, FpDbgWinExtra, FpDbgDisasX86; procedure DebugLoop; diff --git a/components/fpdebug/app/fpd/fpdpeimage.pas b/components/fpdebug/app/fpd/fpdpeimage.pas index 5d98e63fac..ea8dbd23f6 100644 --- a/components/fpdebug/app/fpd/fpdpeimage.pas +++ b/components/fpdebug/app/fpd/fpdpeimage.pas @@ -37,7 +37,7 @@ unit FPDPEImage; interface uses - Windows, SysUtils, FPDGLobal, FpDbgClasses, FpDbgPETypes; + Windows, SysUtils, FPDGLobal, FpDbgInfo, FpDbgClasses, FpDbgPETypes; procedure DumpPEImage(const AProcessHandle: THandle; const AAddress: TDbgPtr); diff --git a/components/fpdebug/fpdbgclasses.pp b/components/fpdebug/fpdbgclasses.pp index 3b528f03f7..1441250338 100644 --- a/components/fpdebug/fpdbgclasses.pp +++ b/components/fpdebug/fpdbgclasses.pp @@ -40,11 +40,9 @@ uses {$ifdef windows} Windows, {$endif} - Classes, SysUtils, Maps, FpDbgUtil, FpDbgWinExtra, FpDbgLoader, LazLoggerBase, LazClasses; + Classes, SysUtils, Maps, FpDbgDwarf, FpDbgUtil, FpDbgWinExtra, FpDbgLoader, FpDbgInfo, LazLoggerBase, LazClasses; type - TDbgPtr = QWord; // PtrUInt; - {$ifdef windows} TDbgProcess = class; {$endif} @@ -69,220 +67,6 @@ type end; {$endif} - TDbgSymbolType = ( - stNone, - stValue, // The symbol has a value (var, field, function, procedure (value is address of func/proc, so it can be called) - stType // The Symbol is a type (including proc/func declaration / without DW_AT_low_pc) - ); - - TDbgSymbolKind = ( - skNone, // undefined type -// skUser, // userdefined type, this sym refers to another sym defined elswhere - skInstance, // the main exe/dll, containing all other syms - skUnit, // contains syms defined in this unit - //-------------------------------------------------------------------------- - skRecord, // the address member is the relative location within the - skObject, // structure - skClass, - skInterface, - skProcedure, - skFunction, - //-------------------------------------------------------------------------- - skArray, - //-------------------------------------------------------------------------- - skPointer, - skInteger, // Basic types, these cannot have references or children - skCardinal, // only size matters ( char(1) = Char, char(2) = WideChar - skBoolean, // cardinal(1) = Byte etc. - skChar, - skFloat, - skString, - skAnsiString, - skCurrency, - skVariant, - skWideString, - skEnum, // Variable holding an enum / enum type - skEnumValue, // a single element from an enum - skSet, - //-------------------------------------------------------------------------- - skRegister // the Address member is the register number - //-------------------------------------------------------------------------- - ); - - TDbgSymbolMemberVisibility =( - svPrivate, - svProtected, - svPublic - ); - - TDbgSymbolFlag =( - sfSubRange, // This is a subrange, e.g 3..99 - sfDynArray, // skArray is known to be a dynamic array - sfStatArray, // skArray is known to be a static array - sfVirtual, // skProcedure,skFunction: virtual function (or overriden) - // unimplemented: - sfInternalRef, // TODO: (May not always be present) Internal ref/pointer e.g. var/constref parameters - sfConst, // The sym is a constant and cannot be modified - sfVar, - sfOut, - sfpropGet, - sfPropSet, - sfPropStored - ); - TDbgSymbolFlags = set of TDbgSymbolFlag; - - TDbgSymbolField = ( - sfiName, sfiKind, sfiSymType, sfiAddress, sfiSize, - sfiTypeInfo, sfiMemberVisibility, - sfiForwardToSymbol - ); - TDbgSymbolFields = set of TDbgSymbolField; - - { TDbgSymbol } - - TDbgSymbol = class(TRefCountedObject) - private - FEvaluatedFields: TDbgSymbolFields; - - // Cached fields - FName: String; - FKind: TDbgSymbolKind; - FSymbolType: TDbgSymbolType; - FAddress: TDbgPtr; - FSize: Integer; - FTypeInfo: TDbgSymbol; - FMemberVisibility: TDbgSymbolMemberVisibility; - - function GetSymbolType: TDbgSymbolType; //inline; - function GetKind: TDbgSymbolKind; //inline; - function GetName: String; - function GetSize: Integer; - function GetAddress: TDbgPtr; - function GetTypeInfo: TDbgSymbol; - function GetMemberVisibility: TDbgSymbolMemberVisibility; - protected - // NOT cached fields - function GetChild({%H-}AIndex: Integer): TDbgSymbol; virtual; - function GetColumn: Cardinal; virtual; - function GetCount: Integer; virtual; - function GetFile: String; virtual; - function GetFlags: TDbgSymbolFlags; virtual; - function GetLine: Cardinal; virtual; - function GetParent: TDbgSymbol; virtual; - function GetReference: TDbgSymbol; virtual; - - function GetHasOrdinalValue: Boolean; virtual; - function GetOrdinalValue: Int64; virtual; - - function GetHasBounds: Boolean; virtual; - function GetOrdHighBound: Int64; virtual; - function GetOrdLowBound: Int64; virtual; - - function GetMember({%H-}AIndex: Integer): TDbgSymbol; virtual; - function GetMemberByName({%H-}AIndex: String): TDbgSymbol; virtual; - function GetMemberCount: Integer; virtual; - protected - property EvaluatedFields: TDbgSymbolFields read FEvaluatedFields write FEvaluatedFields; - // Cached fields - procedure SetName(AValue: String); - procedure SetKind(AValue: TDbgSymbolKind); - procedure SetSymbolType(AValue: TDbgSymbolType); - procedure SetAddress(AValue: TDbgPtr); - procedure SetSize(AValue: Integer); - procedure SetTypeInfo(AValue: TDbgSymbol); - procedure SetMemberVisibility(AValue: TDbgSymbolMemberVisibility); - - procedure KindNeeded; virtual; - procedure NameNeeded; virtual; - procedure SymbolTypeNeeded; virtual; - procedure AddressNeeded; virtual; - procedure SizeNeeded; virtual; - procedure TypeInfoNeeded; virtual; - procedure MemberVisibilityNeeded; virtual; - //procedure Needed; virtual; - public - constructor Create(const AName: String); - constructor Create(const AName: String; AKind: TDbgSymbolKind; AAddress: TDbgPtr); - destructor Destroy; override; - // Basic info - property Name: String read GetName; - property SymbolType: TDbgSymbolType read GetSymbolType; - property Kind: TDbgSymbolKind read GetKind; - // Memory; Size is also part of type (byte vs word vs ...) - property Address: TDbgPtr read GetAddress; - property Size: Integer read GetSize; // In Bytes - // TypeInfo used by - // stValue (Variable): Type - // stType: Pointer: type pointed to / Array: Element Type / Func: Result / Class: itheritance - property TypeInfo: TDbgSymbol read GetTypeInfo; - property MemberVisibility: TDbgSymbolMemberVisibility read GetMemberVisibility; - // Location - property FileName: String read GetFile; - property Line: Cardinal read GetLine; - property Column: Cardinal read GetColumn; - // Methods for structures (record / class / enum) - // array: each member represents an index (enum or subrange) and has low/high bounds - property MemberCount: Integer read GetMemberCount; - property Member[AIndex: Integer]: TDbgSymbol read GetMember; - property MemberByName[AIndex: String]: TDbgSymbol read GetMemberByName; // Includes inheritance - // - property Flags: TDbgSymbolFlags read GetFlags; - property Count: Integer read GetCount; deprecated; - property Reference: TDbgSymbol read GetReference; deprecated; - property Parent: TDbgSymbol read GetParent; deprecated; - //property Children[AIndex: Integer]: TDbgSymbol read GetChild; - // VALUE - property HasOrdinalValue: Boolean read GetHasOrdinalValue; - property OrdinalValue: Int64 read GetOrdinalValue; // need typecast for QuadWord - // for Subranges - property HasBounds: Boolean read GetHasBounds; - property OrdLowBound: Int64 read GetOrdLowBound; // need typecast for QuadWord - property OrdHighBound: Int64 read GetOrdHighBound; // need typecast for QuadWord - end; - - { TDbgSymbolForwarder } - - TDbgSymbolForwarder = class(TDbgSymbol) - private - FForwardToSymbol: TDbgSymbol; // sfiForwardToSymbol - protected - procedure SetForwardToSymbol(AValue: TDbgSymbol); // inline - procedure ForwardToSymbolNeeded; virtual; - function GetForwardToSymbol: TDbgSymbol; //inline; - protected - procedure KindNeeded; override; - procedure NameNeeded; override; - procedure SymbolTypeNeeded; override; - procedure SizeNeeded; override; - procedure TypeInfoNeeded; override; - procedure MemberVisibilityNeeded; override; - - function GetFlags: TDbgSymbolFlags; override; - function GetHasOrdinalValue: Boolean; override; - function GetOrdinalValue: Int64; override; - function GetHasBounds: Boolean; override; - function GetOrdLowBound: Int64; override; - function GetOrdHighBound: Int64; override; - function GetMember(AIndex: Integer): TDbgSymbol; override; - function GetMemberByName(AIndex: String): TDbgSymbol; override; - function GetMemberCount: Integer; override; - end; - - { TDbgInfo } - - TDbgInfo = class(TObject) - private - FHasInfo: Boolean; - protected - procedure SetHasInfo; - public - constructor Create({%H-}ALoader: TDbgImageLoader); virtual; - function FindSymbol(const {%H-}AName: String): TDbgSymbol; virtual; - function FindSymbol({%H-}AAddress: TDbgPtr): TDbgSymbol; virtual; - property HasInfo: Boolean read FHasInfo; - function GetLineAddress(const {%H-}AFileName: String; {%H-}ALine: Cardinal): TDbgPtr; virtual; - end; - {$ifdef windows} TDbgBreakpoint = class; @@ -398,24 +182,13 @@ type end; {$endif} -function dbgs(ADbgSymbolKind: TDbgSymbolKind): String; overload; - implementation -uses - FpDbgDwarf; - procedure LogLastError; begin DebugLn('FpDbg-ERROR: ', GetLastErrorText); end; -function dbgs(ADbgSymbolKind: TDbgSymbolKind): String; -begin - Result := ''; - WriteStr(Result, ADbgSymbolKind); -end; - {$ifdef windows} { TDbgInstance } @@ -952,454 +725,6 @@ begin end; {$endif} -{ TDbgInfo } - -constructor TDbgInfo.Create(ALoader: TDbgImageLoader); -begin - inherited Create; -end; - -function TDbgInfo.FindSymbol(const AName: String): TDbgSymbol; -begin - Result := nil; -end; - -function TDbgInfo.FindSymbol(AAddress: TDbgPtr): TDbgSymbol; -begin - Result := nil; -end; - -function TDbgInfo.GetLineAddress(const AFileName: String; ALine: Cardinal): TDbgPtr; -begin - Result := 0; -end; - -procedure TDbgInfo.SetHasInfo; -begin - FHasInfo := True; -end; - - -{ TDbgSymbol } - -constructor TDbgSymbol.Create(const AName: String); -begin - inherited Create; - AddReference; - if AName <> '' then - SetName(AName); -end; - -constructor TDbgSymbol.Create(const AName: String; AKind: TDbgSymbolKind; AAddress: TDbgPtr); -begin - Create(AName); - SetKind(AKind); - FAddress := AAddress; -end; - -destructor TDbgSymbol.Destroy; -begin - inherited Destroy; - ReleaseRefAndNil(FTypeInfo); -end; - -function TDbgSymbol.GetAddress: TDbgPtr; -begin - if not(sfiAddress in FEvaluatedFields) then - AddressNeeded; - Result := FAddress; -end; - -function TDbgSymbol.GetTypeInfo: TDbgSymbol; -begin - if not(sfiTypeInfo in FEvaluatedFields) then - TypeInfoNeeded; - Result := FTypeInfo; -end; - -function TDbgSymbol.GetMemberVisibility: TDbgSymbolMemberVisibility; -begin - if not(sfiMemberVisibility in FEvaluatedFields) then - MemberVisibilityNeeded; - Result := FMemberVisibility; -end; - -function TDbgSymbol.GetKind: TDbgSymbolKind; -begin - if not(sfiKind in FEvaluatedFields) then - KindNeeded; - Result := FKind; -end; - -function TDbgSymbol.GetName: String; -begin - if not(sfiName in FEvaluatedFields) then - NameNeeded; - Result := FName; -end; - -function TDbgSymbol.GetSize: Integer; -begin - if not(sfiSize in FEvaluatedFields) then - SizeNeeded; - Result := FSize; -end; - -function TDbgSymbol.GetSymbolType: TDbgSymbolType; -begin - if not(sfiSymType in FEvaluatedFields) then - SymbolTypeNeeded; - Result := FSymbolType; -end; - -function TDbgSymbol.GetHasBounds: Boolean; -begin - Result := False; -end; - -function TDbgSymbol.GetOrdHighBound: Int64; -begin - Result := 0; -end; - -function TDbgSymbol.GetOrdLowBound: Int64; -begin - Result := 0; -end; - -function TDbgSymbol.GetHasOrdinalValue: Boolean; -begin - Result := False; -end; - -function TDbgSymbol.GetOrdinalValue: Int64; -begin - Result := 0; -end; - -function TDbgSymbol.GetMember(AIndex: Integer): TDbgSymbol; -begin - Result := nil; -end; - -function TDbgSymbol.GetMemberByName(AIndex: String): TDbgSymbol; -begin - Result := nil; -end; - -function TDbgSymbol.GetMemberCount: Integer; -begin - Result := 0; -end; - -procedure TDbgSymbol.SetAddress(AValue: TDbgPtr); -begin - FAddress := AValue; - Include(FEvaluatedFields, sfiAddress); -end; - -procedure TDbgSymbol.SetKind(AValue: TDbgSymbolKind); -begin - FKind := AValue; - Include(FEvaluatedFields, sfiKind); -end; - -procedure TDbgSymbol.SetSymbolType(AValue: TDbgSymbolType); -begin - FSymbolType := AValue; - Include(FEvaluatedFields, sfiSymType); -end; - -procedure TDbgSymbol.SetSize(AValue: Integer); -begin - FSize := AValue; - Include(FEvaluatedFields, sfiSize); -end; - -procedure TDbgSymbol.SetTypeInfo(AValue: TDbgSymbol); -begin - ReleaseRefAndNil(FTypeInfo); - FTypeInfo := AValue; - Include(FEvaluatedFields, sfiTypeInfo); - if FTypeInfo <> nil then - FTypeInfo.AddReference; -end; - -procedure TDbgSymbol.SetMemberVisibility(AValue: TDbgSymbolMemberVisibility); -begin - FMemberVisibility := AValue; - Include(FEvaluatedFields, sfiMemberVisibility); -end; - -procedure TDbgSymbol.SetName(AValue: String); -begin - FName := AValue; - Include(FEvaluatedFields, sfiName); -end; - -function TDbgSymbol.GetChild(AIndex: Integer): TDbgSymbol; -begin - result := nil; -end; - -function TDbgSymbol.GetColumn: Cardinal; -begin - Result := 0; -end; - -function TDbgSymbol.GetCount: Integer; -begin - Result := 0; -end; - -function TDbgSymbol.GetFile: String; -begin - Result := ''; -end; - -function TDbgSymbol.GetFlags: TDbgSymbolFlags; -begin - Result := []; -end; - -function TDbgSymbol.GetLine: Cardinal; -begin - Result := 0; -end; - -function TDbgSymbol.GetParent: TDbgSymbol; -begin - Result := nil; -end; - -function TDbgSymbol.GetReference: TDbgSymbol; -begin - Result := nil; -end; - -procedure TDbgSymbol.KindNeeded; -begin - SetKind(skNone); -end; - -procedure TDbgSymbol.NameNeeded; -begin - SetName(''); -end; - -procedure TDbgSymbol.SymbolTypeNeeded; -begin - SetSymbolType(stNone); -end; - -procedure TDbgSymbol.AddressNeeded; -begin - SetAddress(0); -end; - -procedure TDbgSymbol.SizeNeeded; -begin - SetSize(0); -end; - -procedure TDbgSymbol.TypeInfoNeeded; -begin - SetTypeInfo(nil); -end; - -procedure TDbgSymbol.MemberVisibilityNeeded; -begin - SetMemberVisibility(svPrivate); -end; - -{ TDbgSymbolForwarder } - -procedure TDbgSymbolForwarder.SetForwardToSymbol(AValue: TDbgSymbol); -begin - FForwardToSymbol := AValue; - EvaluatedFields := EvaluatedFields + [sfiForwardToSymbol]; -end; - -procedure TDbgSymbolForwarder.ForwardToSymbolNeeded; -begin - SetForwardToSymbol(nil); -end; - -function TDbgSymbolForwarder.GetForwardToSymbol: TDbgSymbol; -begin - if TMethod(@ForwardToSymbolNeeded).Code = Pointer(@TDbgSymbolForwarder.ForwardToSymbolNeeded) then - exit(nil); - - if not(sfiForwardToSymbol in EvaluatedFields) then - ForwardToSymbolNeeded; - Result := FForwardToSymbol; -end; - -procedure TDbgSymbolForwarder.KindNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetKind(p.Kind) - else - SetKind(skNone); // inherited KindNeeded; -end; - -procedure TDbgSymbolForwarder.NameNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetName(p.Name) - else - SetName(''); // inherited NameNeeded; -end; - -procedure TDbgSymbolForwarder.SymbolTypeNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetSymbolType(p.SymbolType) - else - SetSymbolType(stNone); // inherited SymbolTypeNeeded; -end; - -procedure TDbgSymbolForwarder.SizeNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetSize(p.Size) - else - SetSize(0); // inherited SizeNeeded; -end; - -procedure TDbgSymbolForwarder.TypeInfoNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetTypeInfo(p.TypeInfo) - else - SetTypeInfo(nil); // inherited TypeInfoNeeded; -end; - -procedure TDbgSymbolForwarder.MemberVisibilityNeeded; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - SetMemberVisibility(p.MemberVisibility) - else - SetMemberVisibility(svPrivate); // inherited MemberVisibilityNeeded; -end; - -function TDbgSymbolForwarder.GetFlags: TDbgSymbolFlags; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.Flags - else - Result := []; // Result := inherited GetFlags; -end; - -function TDbgSymbolForwarder.GetHasOrdinalValue: Boolean; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.HasOrdinalValue - else - Result := False; // Result := inherited GetHasOrdinalValue; -end; - -function TDbgSymbolForwarder.GetOrdinalValue: Int64; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.OrdinalValue - else - Result := 0; // Result := inherited GetOrdinalValue; -end; - -function TDbgSymbolForwarder.GetHasBounds: Boolean; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.HasBounds - else - Result := False; // Result := inherited GetHasBounds; -end; - -function TDbgSymbolForwarder.GetOrdLowBound: Int64; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.OrdLowBound - else - Result := 0; // Result := inherited GetOrdLowBound; -end; - -function TDbgSymbolForwarder.GetOrdHighBound: Int64; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.OrdHighBound - else - Result := 0; // Result := inherited GetOrdHighBound; -end; - -function TDbgSymbolForwarder.GetMember(AIndex: Integer): TDbgSymbol; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.Member[AIndex] - else - Result := nil; // Result := inherited GetMember(AIndex); -end; - -function TDbgSymbolForwarder.GetMemberByName(AIndex: String): TDbgSymbol; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.MemberByName[AIndex] - else - Result := nil; // Result := inherited GetMemberByName(AIndex); -end; - -function TDbgSymbolForwarder.GetMemberCount: Integer; -var - p: TDbgSymbol; -begin - p := GetForwardToSymbol; - if p <> nil then - Result := p.MemberCount - else - Result := 0; // Result := inherited GetMemberCount; -end; - {$ifdef windows} { TDbgBreak } diff --git a/components/fpdebug/fpdbgdisasx86.pp b/components/fpdebug/fpdbgdisasx86.pp index 37ae224e0c..350a15d58a 100644 --- a/components/fpdebug/fpdbgdisasx86.pp +++ b/components/fpdebug/fpdbgdisasx86.pp @@ -43,7 +43,7 @@ uses {$ifdef windows} Windows, {$endif} - FpDbgUtil, FpDbgClasses; + FpDbgUtil, FpDbgInfo; { The function Disassemble decodes the instruction at the given address. diff --git a/components/fpdebug/fpdbgdwarf.pas b/components/fpdebug/fpdbgdwarf.pas index 44fbd8aee5..eb71db2e13 100644 --- a/components/fpdebug/fpdbgdwarf.pas +++ b/components/fpdebug/fpdbgdwarf.pas @@ -41,7 +41,7 @@ unit FpDbgDwarf; interface uses - Classes, Types, SysUtils, FpDbgClasses, FpDbgDwarfConst, Maps, Math, + Classes, Types, SysUtils, FpDbgInfo, FpDbgDwarfConst, Maps, Math, FpDbgLoader, FpImgReaderBase, LazLoggerBase, LazClasses, contnrs; type diff --git a/components/fpdebug/fpdbginfo.pas b/components/fpdebug/fpdbginfo.pas new file mode 100644 index 0000000000..9ddf255177 --- /dev/null +++ b/components/fpdebug/fpdbginfo.pas @@ -0,0 +1,685 @@ +unit FpDbgInfo; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Maps, FpDbgUtil, FpDbgWinExtra, FpDbgLoader, LazLoggerBase, LazClasses; + +type + TDbgPtr = QWord; // PtrUInt; + + TDbgSymbolType = ( + stNone, + stValue, // The symbol has a value (var, field, function, procedure (value is address of func/proc, so it can be called) + stType // The Symbol is a type (including proc/func declaration / without DW_AT_low_pc) + ); + + TDbgSymbolKind = ( + skNone, // undefined type +// skUser, // userdefined type, this sym refers to another sym defined elswhere + skInstance, // the main exe/dll, containing all other syms + skUnit, // contains syms defined in this unit + //-------------------------------------------------------------------------- + skRecord, // the address member is the relative location within the + skObject, // structure + skClass, + skInterface, + skProcedure, + skFunction, + //-------------------------------------------------------------------------- + skArray, + //-------------------------------------------------------------------------- + skPointer, + skInteger, // Basic types, these cannot have references or children + skCardinal, // only size matters ( char(1) = Char, char(2) = WideChar + skBoolean, // cardinal(1) = Byte etc. + skChar, + skFloat, + skString, + skAnsiString, + skCurrency, + skVariant, + skWideString, + skEnum, // Variable holding an enum / enum type + skEnumValue, // a single element from an enum + skSet, + //-------------------------------------------------------------------------- + skRegister // the Address member is the register number + //-------------------------------------------------------------------------- + ); + + TDbgSymbolMemberVisibility =( + svPrivate, + svProtected, + svPublic + ); + + TDbgSymbolFlag =( + sfSubRange, // This is a subrange, e.g 3..99 + sfDynArray, // skArray is known to be a dynamic array + sfStatArray, // skArray is known to be a static array + sfVirtual, // skProcedure,skFunction: virtual function (or overriden) + // unimplemented: + sfInternalRef, // TODO: (May not always be present) Internal ref/pointer e.g. var/constref parameters + sfConst, // The sym is a constant and cannot be modified + sfVar, + sfOut, + sfpropGet, + sfPropSet, + sfPropStored + ); + TDbgSymbolFlags = set of TDbgSymbolFlag; + + TDbgSymbolField = ( + sfiName, sfiKind, sfiSymType, sfiAddress, sfiSize, + sfiTypeInfo, sfiMemberVisibility, + sfiForwardToSymbol + ); + TDbgSymbolFields = set of TDbgSymbolField; + + { TDbgSymbol } + + TDbgSymbol = class(TRefCountedObject) + private + FEvaluatedFields: TDbgSymbolFields; + + // Cached fields + FName: String; + FKind: TDbgSymbolKind; + FSymbolType: TDbgSymbolType; + FAddress: TDbgPtr; + FSize: Integer; + FTypeInfo: TDbgSymbol; + FMemberVisibility: TDbgSymbolMemberVisibility; + + function GetSymbolType: TDbgSymbolType; inline; + function GetKind: TDbgSymbolKind; inline; + function GetName: String; inline; + function GetSize: Integer; inline; + function GetAddress: TDbgPtr; inline; + function GetTypeInfo: TDbgSymbol; inline; + function GetMemberVisibility: TDbgSymbolMemberVisibility; inline; + protected + // NOT cached fields + function GetChild({%H-}AIndex: Integer): TDbgSymbol; virtual; + function GetColumn: Cardinal; virtual; + function GetCount: Integer; virtual; + function GetFile: String; virtual; + function GetFlags: TDbgSymbolFlags; virtual; + function GetLine: Cardinal; virtual; + function GetParent: TDbgSymbol; virtual; + function GetReference: TDbgSymbol; virtual; + + function GetHasOrdinalValue: Boolean; virtual; + function GetOrdinalValue: Int64; virtual; + + function GetHasBounds: Boolean; virtual; + function GetOrdHighBound: Int64; virtual; + function GetOrdLowBound: Int64; virtual; + + function GetMember({%H-}AIndex: Integer): TDbgSymbol; virtual; + function GetMemberByName({%H-}AIndex: String): TDbgSymbol; virtual; + function GetMemberCount: Integer; virtual; + protected + property EvaluatedFields: TDbgSymbolFields read FEvaluatedFields write FEvaluatedFields; + // Cached fields + procedure SetName(AValue: String); inline; + procedure SetKind(AValue: TDbgSymbolKind); inline; + procedure SetSymbolType(AValue: TDbgSymbolType); inline; + procedure SetAddress(AValue: TDbgPtr); inline; + procedure SetSize(AValue: Integer); inline; + procedure SetTypeInfo(AValue: TDbgSymbol); inline; + procedure SetMemberVisibility(AValue: TDbgSymbolMemberVisibility); inline; + + procedure KindNeeded; virtual; + procedure NameNeeded; virtual; + procedure SymbolTypeNeeded; virtual; + procedure AddressNeeded; virtual; + procedure SizeNeeded; virtual; + procedure TypeInfoNeeded; virtual; + procedure MemberVisibilityNeeded; virtual; + //procedure Needed; virtual; + public + constructor Create(const AName: String); + constructor Create(const AName: String; AKind: TDbgSymbolKind; AAddress: TDbgPtr); + destructor Destroy; override; + // Basic info + property Name: String read GetName; + property SymbolType: TDbgSymbolType read GetSymbolType; + property Kind: TDbgSymbolKind read GetKind; + // Memory; Size is also part of type (byte vs word vs ...) + property Address: TDbgPtr read GetAddress; + property Size: Integer read GetSize; // In Bytes + // TypeInfo used by + // stValue (Variable): Type + // stType: Pointer: type pointed to / Array: Element Type / Func: Result / Class: itheritance + property TypeInfo: TDbgSymbol read GetTypeInfo; + property MemberVisibility: TDbgSymbolMemberVisibility read GetMemberVisibility; + // Location + property FileName: String read GetFile; + property Line: Cardinal read GetLine; + property Column: Cardinal read GetColumn; + // Methods for structures (record / class / enum) + // array: each member represents an index (enum or subrange) and has low/high bounds + property MemberCount: Integer read GetMemberCount; + property Member[AIndex: Integer]: TDbgSymbol read GetMember; + property MemberByName[AIndex: String]: TDbgSymbol read GetMemberByName; // Includes inheritance + // + property Flags: TDbgSymbolFlags read GetFlags; + property Count: Integer read GetCount; deprecated; + property Reference: TDbgSymbol read GetReference; deprecated; + property Parent: TDbgSymbol read GetParent; deprecated; + //property Children[AIndex: Integer]: TDbgSymbol read GetChild; + // VALUE + property HasOrdinalValue: Boolean read GetHasOrdinalValue; + property OrdinalValue: Int64 read GetOrdinalValue; // need typecast for QuadWord + // for Subranges + property HasBounds: Boolean read GetHasBounds; + property OrdLowBound: Int64 read GetOrdLowBound; // need typecast for QuadWord + property OrdHighBound: Int64 read GetOrdHighBound; // need typecast for QuadWord + end; + + { TDbgSymbolForwarder } + + TDbgSymbolForwarder = class(TDbgSymbol) + private + FForwardToSymbol: TDbgSymbol; + protected + procedure SetForwardToSymbol(AValue: TDbgSymbol); inline; + procedure ForwardToSymbolNeeded; virtual; + function GetForwardToSymbol: TDbgSymbol; inline; + protected + procedure KindNeeded; override; + procedure NameNeeded; override; + procedure SymbolTypeNeeded; override; + procedure SizeNeeded; override; + procedure TypeInfoNeeded; override; + procedure MemberVisibilityNeeded; override; + + function GetFlags: TDbgSymbolFlags; override; + function GetHasOrdinalValue: Boolean; override; + function GetOrdinalValue: Int64; override; + function GetHasBounds: Boolean; override; + function GetOrdLowBound: Int64; override; + function GetOrdHighBound: Int64; override; + function GetMember(AIndex: Integer): TDbgSymbol; override; + function GetMemberByName(AIndex: String): TDbgSymbol; override; + function GetMemberCount: Integer; override; + end; + + { TDbgInfo } + + TDbgInfo = class(TObject) + private + FHasInfo: Boolean; + protected + procedure SetHasInfo; + public + constructor Create({%H-}ALoader: TDbgImageLoader); virtual; + function FindSymbol(const {%H-}AName: String): TDbgSymbol; virtual; + function FindSymbol({%H-}AAddress: TDbgPtr): TDbgSymbol; virtual; + property HasInfo: Boolean read FHasInfo; + function GetLineAddress(const {%H-}AFileName: String; {%H-}ALine: Cardinal): TDbgPtr; virtual; + end; + +function dbgs(ADbgSymbolKind: TDbgSymbolKind): String; overload; + +implementation + +function dbgs(ADbgSymbolKind: TDbgSymbolKind): String; +begin + Result := ''; + WriteStr(Result, ADbgSymbolKind); +end; + +{ TDbgSymbol } + +constructor TDbgSymbol.Create(const AName: String); +begin + inherited Create; + AddReference; + if AName <> '' then + SetName(AName); +end; + +constructor TDbgSymbol.Create(const AName: String; AKind: TDbgSymbolKind; AAddress: TDbgPtr); +begin + Create(AName); + SetKind(AKind); + FAddress := AAddress; +end; + +destructor TDbgSymbol.Destroy; +begin + inherited Destroy; + ReleaseRefAndNil(FTypeInfo); +end; + +function TDbgSymbol.GetAddress: TDbgPtr; +begin + if not(sfiAddress in FEvaluatedFields) then + AddressNeeded; + Result := FAddress; +end; + +function TDbgSymbol.GetTypeInfo: TDbgSymbol; +begin + if not(sfiTypeInfo in FEvaluatedFields) then + TypeInfoNeeded; + Result := FTypeInfo; +end; + +function TDbgSymbol.GetMemberVisibility: TDbgSymbolMemberVisibility; +begin + if not(sfiMemberVisibility in FEvaluatedFields) then + MemberVisibilityNeeded; + Result := FMemberVisibility; +end; + +function TDbgSymbol.GetKind: TDbgSymbolKind; +begin + if not(sfiKind in FEvaluatedFields) then + KindNeeded; + Result := FKind; +end; + +function TDbgSymbol.GetName: String; +begin + if not(sfiName in FEvaluatedFields) then + NameNeeded; + Result := FName; +end; + +function TDbgSymbol.GetSize: Integer; +begin + if not(sfiSize in FEvaluatedFields) then + SizeNeeded; + Result := FSize; +end; + +function TDbgSymbol.GetSymbolType: TDbgSymbolType; +begin + if not(sfiSymType in FEvaluatedFields) then + SymbolTypeNeeded; + Result := FSymbolType; +end; + +function TDbgSymbol.GetHasBounds: Boolean; +begin + Result := False; +end; + +function TDbgSymbol.GetOrdHighBound: Int64; +begin + Result := 0; +end; + +function TDbgSymbol.GetOrdLowBound: Int64; +begin + Result := 0; +end; + +function TDbgSymbol.GetHasOrdinalValue: Boolean; +begin + Result := False; +end; + +function TDbgSymbol.GetOrdinalValue: Int64; +begin + Result := 0; +end; + +function TDbgSymbol.GetMember(AIndex: Integer): TDbgSymbol; +begin + Result := nil; +end; + +function TDbgSymbol.GetMemberByName(AIndex: String): TDbgSymbol; +begin + Result := nil; +end; + +function TDbgSymbol.GetMemberCount: Integer; +begin + Result := 0; +end; + +procedure TDbgSymbol.SetAddress(AValue: TDbgPtr); +begin + FAddress := AValue; + Include(FEvaluatedFields, sfiAddress); +end; + +procedure TDbgSymbol.SetKind(AValue: TDbgSymbolKind); +begin + FKind := AValue; + Include(FEvaluatedFields, sfiKind); +end; + +procedure TDbgSymbol.SetSymbolType(AValue: TDbgSymbolType); +begin + FSymbolType := AValue; + Include(FEvaluatedFields, sfiSymType); +end; + +procedure TDbgSymbol.SetSize(AValue: Integer); +begin + FSize := AValue; + Include(FEvaluatedFields, sfiSize); +end; + +procedure TDbgSymbol.SetTypeInfo(AValue: TDbgSymbol); +begin + ReleaseRefAndNil(FTypeInfo); + FTypeInfo := AValue; + Include(FEvaluatedFields, sfiTypeInfo); + if FTypeInfo <> nil then + FTypeInfo.AddReference; +end; + +procedure TDbgSymbol.SetMemberVisibility(AValue: TDbgSymbolMemberVisibility); +begin + FMemberVisibility := AValue; + Include(FEvaluatedFields, sfiMemberVisibility); +end; + +procedure TDbgSymbol.SetName(AValue: String); +begin + FName := AValue; + Include(FEvaluatedFields, sfiName); +end; + +function TDbgSymbol.GetChild(AIndex: Integer): TDbgSymbol; +begin + result := nil; +end; + +function TDbgSymbol.GetColumn: Cardinal; +begin + Result := 0; +end; + +function TDbgSymbol.GetCount: Integer; +begin + Result := 0; +end; + +function TDbgSymbol.GetFile: String; +begin + Result := ''; +end; + +function TDbgSymbol.GetFlags: TDbgSymbolFlags; +begin + Result := []; +end; + +function TDbgSymbol.GetLine: Cardinal; +begin + Result := 0; +end; + +function TDbgSymbol.GetParent: TDbgSymbol; +begin + Result := nil; +end; + +function TDbgSymbol.GetReference: TDbgSymbol; +begin + Result := nil; +end; + +procedure TDbgSymbol.KindNeeded; +begin + SetKind(skNone); +end; + +procedure TDbgSymbol.NameNeeded; +begin + SetName(''); +end; + +procedure TDbgSymbol.SymbolTypeNeeded; +begin + SetSymbolType(stNone); +end; + +procedure TDbgSymbol.AddressNeeded; +begin + SetAddress(0); +end; + +procedure TDbgSymbol.SizeNeeded; +begin + SetSize(0); +end; + +procedure TDbgSymbol.TypeInfoNeeded; +begin + SetTypeInfo(nil); +end; + +procedure TDbgSymbol.MemberVisibilityNeeded; +begin + SetMemberVisibility(svPrivate); +end; + +{ TDbgSymbolForwarder } + +procedure TDbgSymbolForwarder.SetForwardToSymbol(AValue: TDbgSymbol); +begin + FForwardToSymbol := AValue; + EvaluatedFields := EvaluatedFields + [sfiForwardToSymbol]; +end; + +procedure TDbgSymbolForwarder.ForwardToSymbolNeeded; +begin + SetForwardToSymbol(nil); +end; + +function TDbgSymbolForwarder.GetForwardToSymbol: TDbgSymbol; +begin + if TMethod(@ForwardToSymbolNeeded).Code = Pointer(@TDbgSymbolForwarder.ForwardToSymbolNeeded) then + exit(nil); + + if not(sfiForwardToSymbol in EvaluatedFields) then + ForwardToSymbolNeeded; + Result := FForwardToSymbol; +end; + +procedure TDbgSymbolForwarder.KindNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetKind(p.Kind) + else + SetKind(skNone); // inherited KindNeeded; +end; + +procedure TDbgSymbolForwarder.NameNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetName(p.Name) + else + SetName(''); // inherited NameNeeded; +end; + +procedure TDbgSymbolForwarder.SymbolTypeNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetSymbolType(p.SymbolType) + else + SetSymbolType(stNone); // inherited SymbolTypeNeeded; +end; + +procedure TDbgSymbolForwarder.SizeNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetSize(p.Size) + else + SetSize(0); // inherited SizeNeeded; +end; + +procedure TDbgSymbolForwarder.TypeInfoNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetTypeInfo(p.TypeInfo) + else + SetTypeInfo(nil); // inherited TypeInfoNeeded; +end; + +procedure TDbgSymbolForwarder.MemberVisibilityNeeded; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + SetMemberVisibility(p.MemberVisibility) + else + SetMemberVisibility(svPrivate); // inherited MemberVisibilityNeeded; +end; + +function TDbgSymbolForwarder.GetFlags: TDbgSymbolFlags; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.Flags + else + Result := []; // Result := inherited GetFlags; +end; + +function TDbgSymbolForwarder.GetHasOrdinalValue: Boolean; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.HasOrdinalValue + else + Result := False; // Result := inherited GetHasOrdinalValue; +end; + +function TDbgSymbolForwarder.GetOrdinalValue: Int64; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.OrdinalValue + else + Result := 0; // Result := inherited GetOrdinalValue; +end; + +function TDbgSymbolForwarder.GetHasBounds: Boolean; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.HasBounds + else + Result := False; // Result := inherited GetHasBounds; +end; + +function TDbgSymbolForwarder.GetOrdLowBound: Int64; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.OrdLowBound + else + Result := 0; // Result := inherited GetOrdLowBound; +end; + +function TDbgSymbolForwarder.GetOrdHighBound: Int64; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.OrdHighBound + else + Result := 0; // Result := inherited GetOrdHighBound; +end; + +function TDbgSymbolForwarder.GetMember(AIndex: Integer): TDbgSymbol; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.Member[AIndex] + else + Result := nil; // Result := inherited GetMember(AIndex); +end; + +function TDbgSymbolForwarder.GetMemberByName(AIndex: String): TDbgSymbol; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.MemberByName[AIndex] + else + Result := nil; // Result := inherited GetMemberByName(AIndex); +end; + +function TDbgSymbolForwarder.GetMemberCount: Integer; +var + p: TDbgSymbol; +begin + p := GetForwardToSymbol; + if p <> nil then + Result := p.MemberCount + else + Result := 0; // Result := inherited GetMemberCount; +end; + +{ TDbgInfo } + +constructor TDbgInfo.Create(ALoader: TDbgImageLoader); +begin + inherited Create; +end; + +function TDbgInfo.FindSymbol(const AName: String): TDbgSymbol; +begin + Result := nil; +end; + +function TDbgInfo.FindSymbol(AAddress: TDbgPtr): TDbgSymbol; +begin + Result := nil; +end; + +function TDbgInfo.GetLineAddress(const AFileName: String; ALine: Cardinal): TDbgPtr; +begin + Result := 0; +end; + +procedure TDbgInfo.SetHasInfo; +begin + FHasInfo := True; +end; + +end. + diff --git a/components/fpdebug/fpdbgsymbols.pas b/components/fpdebug/fpdbgsymbols.pas index 123ec0f1dd..40df9adc2e 100644 --- a/components/fpdebug/fpdbgsymbols.pas +++ b/components/fpdebug/fpdbgsymbols.pas @@ -41,7 +41,7 @@ uses {$ifdef windows} Windows, {$endif} - Classes, SysUtils, FpDbgClasses, FpDbgWinExtra, FpDbgPETypes, FpDbgDwarf, FpDbgUtil; + Classes, SysUtils, FpDbgInfo, FpDbgWinExtra, FpDbgPETypes, FpDbgDwarf, FpDbgUtil; {$ifdef windows} diff --git a/components/fpdebug/fpdebug.lpk b/components/fpdebug/fpdebug.lpk index 23a230c758..75c0847509 100644 --- a/components/fpdebug/fpdebug.lpk +++ b/components/fpdebug/fpdebug.lpk @@ -34,7 +34,7 @@ File(s) with other licenses (see also header in file(s): (Any modifications/translations of this file are from duby) "/> - + @@ -105,8 +105,12 @@ File(s) with other licenses (see also header in file(s): - + + + + + diff --git a/components/fpdebug/fpdebug.pas b/components/fpdebug/fpdebug.pas index 1035974271..01d5af6357 100644 --- a/components/fpdebug/fpdebug.pas +++ b/components/fpdebug/fpdebug.pas @@ -10,7 +10,7 @@ uses FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, FpDbgPETypes, FpDbgSymbols, FpDbgUtil, FpDbgWinExtra, FpImgReaderWinPE, FpImgReaderElf, FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, FpImgReaderMachoFile, - FpImgReaderMacho, FpPascalBuilder, LazarusPackageIntf; + FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, LazarusPackageIntf; implementation diff --git a/components/fpdebug/fppascalbuilder.pas b/components/fpdebug/fppascalbuilder.pas index e51e7244d0..83a45282ba 100644 --- a/components/fpdebug/fppascalbuilder.pas +++ b/components/fpdebug/fppascalbuilder.pas @@ -5,7 +5,7 @@ unit FpPascalBuilder; interface uses - Classes, SysUtils, FpDbgClasses; + Classes, SysUtils, FpDbgInfo; type TTypeNameFlag = ( diff --git a/components/fpdebug/fppascalparser.pas b/components/fpdebug/fppascalparser.pas index 1fbf86c290..768922b2ed 100644 --- a/components/fpdebug/fppascalparser.pas +++ b/components/fpdebug/fppascalparser.pas @@ -29,7 +29,7 @@ unit FpPascalParser; interface uses - Classes, sysutils, math, FpDbgClasses, LazLoggerBase, LazClasses; + Classes, sysutils, math, FpDbgInfo, LazLoggerBase, LazClasses; type diff --git a/components/fpdebug/test/testapps/testprog1.pas b/components/fpdebug/test/testapps/testprog1.pas index f5e478234d..267cce665a 100644 --- a/components/fpdebug/test/testapps/testprog1.pas +++ b/components/fpdebug/test/testapps/testprog1.pas @@ -2,19 +2,95 @@ program Foo; {$mode objfpc}{$H+} type + + TStatArray = Array[3..7] of boolean; + TStatArray2 = Array[3..7, 2..4] of boolean; + TDynArray = Array of boolean; + TDynArray2 = Array of Array of boolean; + PDynArray = ^TDynArray; + + TString25 = String[25]; + + TEnum1 = (enum1a,enum1b,enum1c,enum1d); + PTEnum1 = ^TEnum1; + TSet1 = set of TEnum1; + PTSet1 = ^TSet1; + + TTestClass = class; + + { TTestRecord } + + TTestRecord = record + FWord: Word; + FBool: Boolean; + FTest: TTestClass; + end; + PTestRecord = ^TTestRecord; + + { TTestClass } + TTestClass = class + public + FWord: Word; + FBool: Boolean; + FTest: TTestClass; + procedure f0(a:integer); virtual; + end; + + { TTestClass2 } + + TTestClass2 = class(TTestClass) + public + FWord2: Word; + FBool2: Boolean; + FTest2: TTestClass; + a1: TStatArray; + a2: TDynArray; + a3: Array[3..7, 2..4] of boolean; + a4: Array of Array of boolean; + a5: array [1..2] of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end; + a6: array of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end; + a7: array [(a7e1,a7e2,a7e3)] of set of (a7s1,a7s2,a7s3); + r1: record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end; + r2: TTestRecord; + s1: string[25]; + s2: TString25; + enum1: (ee1,ee2,ee3); + set1: set of (se1,se2,se3); + enum4: ^TEnum1; + enum5: PTEnum1; + set4: TSet1; + set5: ^TSet1; + procedure f0(a:integer); override; + procedure f1(a:integer); + procedure f2(a:integer); virtual; + procedure f2a(a:integer); virtual; abstract; + procedure f3(a:integer); dynamic; + end; + PTestClass2 = ^TTestClass2; + + TTestObject = object public FWord: Word; FBool: Boolean; FTest: TTestClass; end; + TTestObject2 = object(TTestObject) + public + FWord2: Word; + FBool2: Boolean; + FTest2: TTestClass; + end; + PTestObject2 = ^TTestObject2; + + Pint = ^ integer; PPInt = ^Pint; PPPInt = ^PPint; //shortstring = record end; -procedure Bar; +procedure Bar(ArgClass: TTestClass; var VArgClass: TTestClass; pdarg: PDynArray); var int1, int2: Integer; pint1, pint2: ^Integer; @@ -22,7 +98,14 @@ var puint1, puint2: ^Cardinal; b1,b2: Byte; bool1,bool2: Boolean; - test: TTestClass; + + TestC: TTestClass; testC2: TTestClass2; + PtestC2: PTestClass2; PtestC2a: ^TTestClass2; + testO: TTestObject; testO2: TTestObject2; + PtestO2: PTestObject2; PtestO2a: ^TTestObject2; + TestR: TTestRecord; + PTestR: PTestRecord; PTestRa: ^TTestRecord; + ITestR: record FWord: Word; FBool: Boolean; end; s1: string[5]; s2: string[15]; @@ -33,6 +116,30 @@ var ppi: PPint; pppi: PPPint; + a1: TStatArray; + a2: TDynArray; + a1p: ^TStatArray; + a2p: ^TDynArray; + a1b: TStatArray2; + a2b: TDynArray2; + a3: Array[3..7, 2..4] of boolean; + a4: Array of Array of boolean; + + enum1: TEnum1; + enum2: enum1b..enum1d; + enum3: enum1a..enum1c; + enum4: ^TEnum1; + enum5: PTEnum1; + set1: set of byte; + set2: set of (enum1a,enum1d); + set3: set of 1..5; + set4: TSet1; + set5: ^TSet1; + set6: PTSet1; + subr: 1..9; + subr2: -11..-9; + subr3: #9..'m'; + begin int1 := int2; pint1 := pint2; @@ -43,10 +150,72 @@ begin s1:= 'aa'; st1:= 'bb'; pc1:= @st1[1]; - writeln(int1,uint1,b1,bool1, test.FWord); + SetLength(a2,9); + SetLength(a2b,9,3); + SetLength(a4,9,3); + testC2 := TTestClass2.Create; + a1[3]:= a1b[3,3]; + a1[3]:= a3[3,3]; + a1p := @a1; + a2p := @a2; + SetLength(testC2.a2,9); + SetLength(testC2.a4,9,3); + testC2.f1(1); + testC2.f2(1); + testC2.f3(1); + testC2.f0(1); + enum1 := enum1b; + enum2 := enum1b; + enum3 := enum1b; + enum4 := @enum1; + enum5 := @enum1; + set1 := []; + set2 := []; + set3 := []; + set4 := []; + set5 := @set4; + set6 := @set4; + subr := 1; + subr2 := -11; + subr3 := 'm'; + writeln(int1,uint1,b1,bool1, + testC.FWord, testC2.FWord, PtestC2^.FWord, PtestC2a^.FWord, + testO.FWord, testO2.FWord, PtestO2^.FWord, PtestO2a^.FWord, + testR.FWord, PtestR^.FWord, PtestRa^.FWord + ); WriteLn(s1,s2,s3,st1,st2,pc1,pc2, pi^,ppi^^,pppi^^^); end; +var + GlobClass: TTestClass; + +procedure TTestClass.f0(a: integer); begin - Bar; + // +end; + +{ TTestClass2 } + +procedure TTestClass2.f0(a: integer); +begin + inherited f0(a); +end; + +procedure TTestClass2.f1(a: integer); +begin + // +end; + +procedure TTestClass2.f2(a: integer); +begin +// +end; + +procedure TTestClass2.f3(a: integer); +begin + +end; + +begin + Bar(GlobClass, GlobClass, nil); end. diff --git a/components/fpdebug/test/testtypeinfo.pas b/components/fpdebug/test/testtypeinfo.pas index 5b6186c53e..a7d9660c3b 100644 --- a/components/fpdebug/test/testtypeinfo.pas +++ b/components/fpdebug/test/testtypeinfo.pas @@ -5,11 +5,11 @@ unit TestTypeInfo; interface uses - Classes, SysUtils, FpPascalParser, FpDbgDwarf, FpDbgClasses, FpDbgLoader, FileUtil, - LazLoggerBase, fpcunit, testutils, testregistry; + Classes, SysUtils, FpPascalParser, FpDbgDwarf, FpDbgInfo, FpDbgLoader, FpPascalBuilder, + FileUtil, LazLoggerBase, fpcunit, testutils, testregistry; const - TESTPROG1_FUNC_BAR_LINE = 35; + TESTPROG1_FUNC_BAR_LINE = 155; type @@ -114,6 +114,15 @@ debugln(['### ', TestText, ' ## ', dbgs(Expr.ResultType.Kind), ' # ',Expr.Result AssertEquals(TestText+' kind', dbgs(AKind), dbgs(Expr.ResultType.Kind)); end; + procedure TestTypeName(AExpName: String; AFlags: TTypeNameFlags = []); + var + s: String; + begin + AssertEquals(TestText + ' GetTypeName bool ', AExpName <> '', GetTypeName(s, Expr.ResultType, AFlags)); + if AExpName <> '' then + AssertEquals(TestText + ' GetTypeName result ', LowerCase(AExpName), LowerCase(s)); + end; + procedure DoTestInvalid(AExprText: String); begin FreeAndNil(Expr); @@ -124,18 +133,22 @@ debugln(['### ', TestText, ' ## ', dbgs(Expr.ResultType.Kind), ' # ',Expr.Result end; procedure DoRun; + var + s: String; begin LineInfo := FDwarfInfo.GetLineAddressMap('testprog1.pas'); Location := LineInfo^.GetAddressForLine(TESTPROG1_FUNC_BAR_LINE); DoTest('int1', skInteger); DoTest('b1', skCardinal); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); DoTest('pint1', skPointer); DoTest(Expr.ResultType.TypeInfo, skInteger); DoTest('@int1', skPointer); DoTest(Expr.ResultType.TypeInfo, skInteger); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); DoTest('pint1^', skInteger); DoTest('@int1^', skInteger); @@ -146,10 +159,10 @@ debugln(['### ', TestText, ' ## ', dbgs(Expr.ResultType.Kind), ' # ',Expr.Result DoTest('bool1', skBoolean); - DoTest('test.FWord', skCardinal); - DoTest('test.FBool', skBoolean); - DoTest('test.FTest.FWord', skCardinal); - DoTest('test.FTest.FBool', skBoolean); + DoTest('testC.FWord', skCardinal); + DoTest('testC.FBool', skBoolean); + DoTest('testC.FTest.FWord', skCardinal); + DoTest('testC.FTest.FBool', skBoolean); DoTest('longint(bool1)', skInteger); @@ -159,6 +172,106 @@ debugln(['### ', TestText, ' ## ', dbgs(Expr.ResultType.Kind), ' # ',Expr.Result DoTestInvalid('^int1'); DoTestInvalid('^int1(int2)'); + DoTest('ppi', skPointer, 'ppint'); + TestTypeName('^pint', [tnfIncludeOneRef]); + + DoTest('@int1', skPointer, ''); + TestTypeName('^longint', []); + TestTypeName('^longint', [tnfIncludeOneRef]); + TestTypeName('', [tnfOnlyDeclared]); + + DoTest('testC', skClass); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + DoTest('testC2', skClass); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('enum1', skEnum); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('subr', skCardinal); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + DoTest('subr2', skInteger); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + DoTest('subr3', skChar); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('set1', skSet); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + DoTest('set2', skSet); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + DoTest('set3', skSet); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + + DoTest('a1', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a2', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a1b', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a2b', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a1p', skPointer); + //AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a2p', skPointer); + //AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('pdarg', skPointer); + //AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a3', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('a4', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + + + + DoTest('testc2.a1', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a2', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a3', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a4', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a5', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a6', skArray); + AssertTrue(TestText + ' Flag: ', sfDynArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + DoTest('testc2.a7', skArray); + AssertTrue(TestText + ' Flag: ', sfStatArray in Expr.ResultType.Flags); +GetTypeAsDeclaration(s, Expr.ResultType); DebugLn(s); + + + FreeAndNil(expr); end; diff --git a/debugger/fpgdbmidebugger.pp b/debugger/fpgdbmidebugger.pp index c4b5ed1d28..e3de9ce64a 100644 --- a/debugger/fpgdbmidebugger.pp +++ b/debugger/fpgdbmidebugger.pp @@ -5,7 +5,7 @@ unit FpGdbmiDebugger; interface uses - Classes, sysutils, math, FpDbgClasses, GDBMIDebugger, BaseDebugManager, Debugger, + Classes, sysutils, math, FpDbgInfo, FpDbgClasses, GDBMIDebugger, BaseDebugManager, Debugger, GDBMIMiscClasses, GDBTypeInfo, maps, LCLProc, FpDbgLoader, FpDbgDwarf, FpDbgDwarfConst, LazLoggerBase, LazLoggerProfiling, FpPascalParser, FpPascalBuilder; @@ -162,7 +162,7 @@ const ADeRefTypeName := ''; ABaseTypeName := ABaseType.Name; - while (ABaseType.Kind = FpDbgClasses.skPointer) and (ABaseType.TypeInfo <> nil) do begin + while (ABaseType.Kind = FpDbgInfo.skPointer) and (ABaseType.TypeInfo <> nil) do begin ABaseType := ABaseType.TypeInfo; inc(APointerLevel); @@ -206,7 +206,7 @@ const begin //todo: functions / virtual / array ... s2 := ''; - if AMember.Kind = FpDbgClasses.skProcedure then begin + if AMember.Kind = FpDbgInfo.skProcedure then begin if sfVirtual in AMember.Flags then s2 := ' virtual;'; AText := AText + ' procedure ' + AMember.Name + ' ();' + s2 + LineEnding; exit @@ -219,23 +219,23 @@ const end; s := ti.Name; if s = '' then begin - if (AMember.Kind = FpDbgClasses.skSet) or (AMember.Kind = FpDbgClasses.skEnum) or - (AMember.Kind = FpDbgClasses.skArray) + if (AMember.Kind = FpDbgInfo.skSet) or (AMember.Kind = FpDbgInfo.skEnum) or + (AMember.Kind = FpDbgInfo.skArray) then if not GetTypeAsDeclaration(s, ti, [tdfSkipClassBody, tdfSkipRecordBody]) then s := ''; end; - if (s = '') and not (AMember.Kind = FpDbgClasses.skRecord) then begin + if (s = '') and not (AMember.Kind = FpDbgInfo.skRecord) then begin Result := False; exit; end; - if AMember.Kind = FpDbgClasses.skFunction then begin + if AMember.Kind = FpDbgInfo.skFunction then begin if sfVirtual in AMember.Flags then s2 := ' virtual;'; AText := AText + ' function ' + AMember.Name + ' () : '+s+';' + s2 + LineEnding; end else - if AMember.Kind = FpDbgClasses.skRecord then begin + if AMember.Kind = FpDbgInfo.skRecord then begin AText := AText + ' ' + AMember.Name + ' : '+s+' = record ;' + LineEnding; end else @@ -532,23 +532,23 @@ const AddBaseType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType); - FpDbgClasses.skClass: + FpDbgInfo.skClass: AddClassType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType); - FpDbgClasses.skRecord: + FpDbgInfo.skRecord: AddRecordType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType); - FpDbgClasses.skEnum: + FpDbgInfo.skEnum: AddEnumType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType); - FpDbgClasses.skSet: + FpDbgInfo.skSet: AddSetType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType); - FpDbgClasses.skArray: + FpDbgInfo.skArray: AddArrayType(ASourceExpr, PointerLevel, SrcTypeName, DeRefTypeName, BaseTypeName, ATypeIdent, BaseType);