Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
Repository URL to install this package:
|
Version:
1.6 ▾
|
{
---------------------------------------------------------------------------
fpdbgdwarf.pas - Native Freepascal debugger - Dwarf symbol processing
---------------------------------------------------------------------------
This unit contains helper classes for handling and evaluating of debuggee data
described by DWARF debug symbols
---------------------------------------------------------------------------
@created(Mon Aug 1st WET 2006)
@lastmod($Date: 2015-05-20 23:00:18 +0200 (Mi, 20 Mai 2015) $)
@author(Marc Weustink <marc@@dommelstein.nl>)
@author(Martin Friebe)
***************************************************************************
* *
* 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. *
* *
***************************************************************************
}
unit FpDbgDwarf;
{$mode objfpc}{$H+}
{off $INLINE OFF}
(* Notes:
* FpDbgDwarfValues and Context
The Values do not add a reference to the Context. Yet they require the Context.
It is the users responsibility to keep the context, as long as any value exists.
*)
interface
uses
Classes, SysUtils, types, math, FpDbgInfo, FpDbgDwarfDataClasses, FpdMemoryTools, FpErrorMessages,
FpDbgUtil, FpDbgDwarfConst, DbgIntfBaseTypes, LazUTF8, LazLoggerBase, LazClasses;
type
TFpDwarfInfo = FpDbgDwarfDataClasses.TFpDwarfInfo;
{ TFpDwarfDefaultSymbolClassMap }
TFpDwarfDefaultSymbolClassMap = class(TFpDwarfSymbolClassMap)
public
class function HandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
class function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
class function CreateContext(AThreadId, AStackFrame: Integer; AnAddress:
TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override;
end;
{ TFpDwarfInfoAddressContext }
TFpDwarfInfoAddressContext = class(TFpDbgInfoContext)
private
FSymbol: TFpDbgSymbol;
FAddress: TDBGPtr;
FThreadId, FStackFrame: Integer;
FDwarf: TFpDwarfInfo;
FlastResult: TFpDbgValue;
protected
function GetSymbolAtAddress: TFpDbgSymbol; override;
function GetProcedureAtAddress: TFpDbgValue; override;
function GetAddress: TDbgPtr; override;
function GetThreadId: Integer; override;
function GetStackFrame: Integer; override;
function GetSizeOfAddress: Integer; override;
function GetMemManager: TFpDbgMemManager; override;
property Symbol: TFpDbgSymbol read FSymbol;
property Dwarf: TFpDwarfInfo read FDwarf;
property Address: TDBGPtr read FAddress write FAddress;
property ThreadId: Integer read FThreadId write FThreadId;
property StackFrame: Integer read FStackFrame write FStackFrame;
function ApplyContext(AVal: TFpDbgValue): TFpDbgValue; inline;
function SymbolToValue(ASym: TFpDbgSymbol): TFpDbgValue; inline;
procedure AddRefToVal(AVal: TFpDbgValue); inline;
function GetSelfParameter: TFpDbgValue; virtual;
function FindExportedSymbolInUnits(const AName: String; PNameUpper, PNameLower: PChar;
SkipCompUnit: TDwarfCompilationUnit; out ADbgValue: TFpDbgValue): Boolean; inline;
function FindSymbolInStructure(const AName: String; PNameUpper, PNameLower: PChar;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean; inline;
// FindLocalSymbol: for the subroutine itself
function FindLocalSymbol(const AName: String; PNameUpper, PNameLower: PChar;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean; virtual;
public
constructor Create(AThreadId, AStackFrame: Integer; AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo);
destructor Destroy; override;
function FindSymbol(const AName: String): TFpDbgValue; override;
end;
TFpDwarfSymbol = class;
TFpDwarfSymbolType = class;
TFpDwarfSymbolValue = class;
TFpDwarfSymbolValueClass = class of TFpDwarfSymbolValue;
TFpDwarfSymbolTypeClass = class of TFpDwarfSymbolType;
{%region Value objects }
{ TFpDwarfValueBase }
TFpDwarfValueBase = class(TFpDbgValue)
private
FContext: TFpDbgInfoContext;
public
property Context: TFpDbgInfoContext read FContext;
end;
{ TFpDwarfValueTypeDefinition }
TFpDwarfValueTypeDefinition = class(TFpDwarfValueBase)
private
FSymbol: TFpDbgSymbol; // stType
protected
function GetKind: TDbgSymbolKind; override;
function GetDbgSymbol: TFpDbgSymbol; override;
public
constructor Create(ASymbol: TFpDbgSymbol); // Only for stType
destructor Destroy; override;
function GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue; override;
end;
{ TFpDwarfValue }
TFpDwarfValue = class(TFpDwarfValueBase)
private
FOwner: TFpDwarfSymbolType; // the creator, usually the type
FValueSymbol: TFpDwarfSymbolValue;
FTypeCastTargetType: TFpDwarfSymbolType;
FTypeCastSourceValue: TFpDbgValue;
FDataAddressCache: array of TFpDbgMemLocation;
FStructureValue: TFpDwarfValue;
FLastMember: TFpDwarfValue;
FLastError: TFpError;
function GetDataAddressCache(AIndex: Integer): TFpDbgMemLocation;
function MemManager: TFpDbgMemManager; inline;
function AddressSize: Byte; inline;
procedure SetDataAddressCache(AIndex: Integer; AValue: TFpDbgMemLocation);
procedure SetStructureValue(AValue: TFpDwarfValue);
protected
procedure DoReferenceAdded; override;
procedure DoReferenceReleased; override;
procedure CircleBackRefActiveChanged(NewActive: Boolean); override;
procedure SetLastMember(ALastMember: TFpDwarfValue);
function GetLastError: TFpError; override;
// Address of the symbol (not followed any type deref, or location)
function GetAddress: TFpDbgMemLocation; override;
function OrdOrAddress: TFpDbgMemLocation;
// Address of the data (followed type deref, location, ...)
function DataAddr: TFpDbgMemLocation;
function OrdOrDataAddr: TFpDbgMemLocation;
function GetDwarfDataAddress(out AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType = nil): Boolean;
function GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType = nil): Boolean;
function HasDwarfDataAddress: Boolean; // TODO: is this just HasAddress?
procedure Reset; virtual; // keeps lastmember and structureninfo
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function HasTypeCastInfo: Boolean;
function IsValidTypeCast: Boolean; virtual;
function GetKind: TDbgSymbolKind; override;
function GetMemberCount: Integer; override;
function GetMemberByName(AIndex: String): TFpDbgValue; override;
function GetMember(AIndex: Int64): TFpDbgValue; override;
function GetDbgSymbol: TFpDbgSymbol; override;
function GetTypeInfo: TFpDbgSymbol; override;
function GetContextTypeInfo: TFpDbgSymbol; override;
public
constructor Create(AOwner: TFpDwarfSymbolType);
destructor Destroy; override;
procedure SetValueSymbol(AValueSymbol: TFpDwarfSymbolValue);
function SetTypeCastInfo(AStructure: TFpDwarfSymbolType;
ASource: TFpDbgValue): Boolean; // Used for Typecast
// StructureValue: Any Value returned via GetMember points to its structure
property StructureValue: TFpDwarfValue read FStructureValue write SetStructureValue;
// DataAddressCache[0]: ValueAddress // DataAddressCache[1..n]: DataAddress
property DataAddressCache[AIndex: Integer]: TFpDbgMemLocation read GetDataAddressCache write SetDataAddressCache;
end;
{ TFpDwarfValueSized }
TFpDwarfValueSized = class(TFpDwarfValue)
private
FSize: Integer;
protected
function CanUseTypeCastAddress: Boolean;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetSize: Integer; override;
public
constructor Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
end;
{ TFpDwarfValueNumeric }
TFpDwarfValueNumeric = class(TFpDwarfValueSized)
protected
FEvaluated: set of (doneUInt, doneInt, doneAddr, doneFloat);
protected
procedure Reset; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override; // svfOrdinal
function IsValidTypeCast: Boolean; override;
public
constructor Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
end;
{ TFpDwarfValueInteger }
TFpDwarfValueInteger = class(TFpDwarfValueNumeric)
private
FIntValue: Int64;
protected
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsCardinal: QWord; override;
function GetAsInteger: Int64; override;
end;
{ TFpDwarfValueCardinal }
TFpDwarfValueCardinal = class(TFpDwarfValueNumeric)
private
FValue: QWord;
protected
function GetAsCardinal: QWord; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
end;
{ TFpDwarfValueFloat }
TFpDwarfValueFloat = class(TFpDwarfValueNumeric) // TDbgDwarfSymbolValue
// TODO: typecasts to int should convert
private
FValue: Extended;
protected
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsFloat: Extended; override;
end;
{ TFpDwarfValueBoolean }
TFpDwarfValueBoolean = class(TFpDwarfValueCardinal)
protected
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsBool: Boolean; override;
end;
{ TFpDwarfValueChar }
TFpDwarfValueChar = class(TFpDwarfValueCardinal)
protected
// returns single char(byte) / widechar
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsString: AnsiString; override;
function GetAsWideString: WideString; override;
end;
{ TFpDwarfValuePointer }
TFpDwarfValuePointer = class(TFpDwarfValueNumeric)
private
FLastAddrMember: TFpDbgValue;
FPointetToAddr: TFpDbgMemLocation;
protected
function GetAsCardinal: QWord; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetAsString: AnsiString; override;
function GetMember(AIndex: Int64): TFpDbgValue; override;
public
destructor Destroy; override;
end;
{ TFpDwarfValueEnum }
TFpDwarfValueEnum = class(TFpDwarfValueNumeric)
private
FValue: QWord;
FMemberIndex: Integer;
FMemberValueDone: Boolean;
procedure InitMemberIndex;
protected
procedure Reset; override;
//function IsValidTypeCast: Boolean; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsCardinal: QWord; override;
function GetAsString: AnsiString; override;
// Has exactly 0 (if the ordinal value is out of range) or 1 member (the current value's enum)
function GetMemberCount: Integer; override;
function GetMember({%H-}AIndex: Int64): TFpDbgValue; override;
end;
{ TFpDwarfValueEnumMember }
TFpDwarfValueEnumMember = class(TFpDwarfValue)
private
FOwnerVal: TFpDwarfSymbolValue;
protected
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsCardinal: QWord; override;
function GetAsString: AnsiString; override;
function IsValidTypeCast: Boolean; override;
public
constructor Create(AOwner: TFpDwarfSymbolValue);
end;
{ TFpDwarfValueConstNumber }
TFpDwarfValueConstNumber = class(TFpDbgValueConstNumber)
protected
procedure Update(AValue: QWord; ASigned: Boolean);
end;
{ TFpDwarfValueSet }
TFpDwarfValueSet = class(TFpDwarfValueSized)
private
FMem: array of Byte;
FMemberCount: Integer;
FMemberMap: array of Integer;
FNumValue: TFpDwarfValueConstNumber;
FTypedNumValue: TFpDbgValue;
procedure InitMap;
protected
procedure Reset; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetMemberCount: Integer; override;
function GetMember(AIndex: Int64): TFpDbgValue; override;
function GetAsCardinal: QWord; override; // only up to qmord
function IsValidTypeCast: Boolean; override;
public
destructor Destroy; override;
end;
{ TFpDwarfValueStruct }
TFpDwarfValueStruct = class(TFpDwarfValue)
private
FDataAddress: TFpDbgMemLocation;
FDataAddressDone: Boolean;
protected
procedure Reset; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetAsCardinal: QWord; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetDataSize: Integer; override;
function GetSize: Integer; override;
end;
{ TFpDwarfValueStructTypeCast }
TFpDwarfValueStructTypeCast = class(TFpDwarfValue)
private
FMembers: TFpDbgCircularRefCntObjList;
FDataAddress: TFpDbgMemLocation;
FDataAddressDone: Boolean;
protected
procedure Reset; override;
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetKind: TDbgSymbolKind; override;
function GetAsCardinal: QWord; override;
function GetSize: Integer; override;
function GetDataSize: Integer; override;
function GetDataAddress: TFpDbgMemLocation; override;
function IsValidTypeCast: Boolean; override;
public
destructor Destroy; override;
function GetMemberByName(AIndex: String): TFpDbgValue; override;
function GetMember(AIndex: Int64): TFpDbgValue; override;
function GetMemberCount: Integer; override;
end;
{ TFpDwarfValueConstAddress }
TFpDwarfValueConstAddress = class(TFpDbgValueConstAddress)
protected
procedure Update(AnAddress: TFpDbgMemLocation);
end;
{ TFpDwarfValueArray }
TFpDwarfValueArray = class(TFpDwarfValue)
private
FAddrObj: TFpDwarfValueConstAddress;
protected
function GetFieldFlags: TFpDbgValueFieldFlags; override;
function GetKind: TDbgSymbolKind; override;
function GetAsCardinal: QWord; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetMember(AIndex: Int64): TFpDbgValue; override;
function GetMemberEx(AIndex: array of Int64): TFpDbgValue; override;
function GetMemberCount: Integer; override;
function GetMemberCountEx(AIndex: array of Int64): Integer; override;
function GetIndexType(AIndex: Integer): TFpDbgSymbol; override;
function GetIndexTypeCount: Integer; override;
function IsValidTypeCast: Boolean; override;
public
destructor Destroy; override;
end;
{%endregion Value objects }
{%region Symbol objects }
TInitLocParserData = record
(* DW_AT_data_member_location: Is always pushed on stack
DW_AT_data_location: Is avalibale for DW_OP_push_object_address
*)
ObjectDataAddress: TFpDbgMemLocation;
ObjectDataAddrPush: Boolean; // always push ObjectDataAddress on stack: DW_AT_data_member_location
end;
PInitLocParserData = ^TInitLocParserData;
{ TDbgDwarfIdentifier }
{ TFpDwarfSymbol }
TFpDwarfSymbol = class(TDbgDwarfSymbolBase)
private
FNestedTypeInfo: TFpDwarfSymbolType;
FParentTypeInfo: TFpDwarfSymbol;
FDwarfReadFlags: set of (didtNameRead, didtTypeRead, didtArtificialRead, didtIsArtifical);
function GetNestedTypeInfo: TFpDwarfSymbolType;
protected
(* There will be a circular reference between parenttype and self
"self" will only set its reference to parenttype, if self has other references. *)
procedure DoReferenceAdded; override;
procedure DoReferenceReleased; override;
procedure CircleBackRefActiveChanged(ANewActive: Boolean); override;
procedure SetParentTypeInfo(AValue: TFpDwarfSymbol); virtual;
function DoGetNestedTypeInfo: TFpDwarfSymbolType; virtual;
function ReadMemberVisibility(out AMemberVisibility: TDbgSymbolMemberVisibility): Boolean;
function IsArtificial: Boolean; // usud by formal param and subprogram
procedure NameNeeded; override;
procedure TypeInfoNeeded; override;
property NestedTypeInfo: TFpDwarfSymbolType read GetNestedTypeInfo;
// OwnerTypeInfo: reverse of "NestedTypeInfo" (variable that is of this type)
// property OwnerTypeInfo: TDbgDwarfIdentifier read FOwnerTypeInfo; // write SetOwnerTypeInfo;
// ParentTypeInfo: funtion for local var / class for member
property ParentTypeInfo: TFpDwarfSymbol read FParentTypeInfo write SetParentTypeInfo;
function DataSize: Integer; virtual;
protected
function InitLocationParser(const {%H-}ALocationParser: TDwarfLocationExpression;
AnInitLocParserData: PInitLocParserData = nil): Boolean; virtual;
function LocationFromTag(ATag: Cardinal; AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; // kept, if tag does not exist
AnInitLocParserData: PInitLocParserData = nil;
AnInformationEntry: TDwarfInformationEntry = nil;
ASucessOnMissingTag: Boolean = False
): Boolean;
// GetDataAddress: data of a class, or string
function GetDataAddress(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean;
function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; virtual;
function HasAddress: Boolean; virtual;
procedure Init; override;
public
class function CreateSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbol;
destructor Destroy; override;
function StartScope: TDbgPtr; // return 0, if none. 0 includes all anyway
end;
{ TFpDwarfSymbolValue }
TFpDwarfSymbolValue = class(TFpDwarfSymbol) // var, const, member, ...
protected
FValueObject: TFpDwarfValue;
FMembers: TFpDbgCircularRefCntObjList;
function GetValueAddress({%H-}AValueObj: TFpDwarfValue;{%H-} out AnAddress: TFpDbgMemLocation): Boolean; virtual;
function GetValueDataAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType = nil): Boolean;
procedure KindNeeded; override;
procedure MemberVisibilityNeeded; override;
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
procedure Init; override;
public
destructor Destroy; override;
class function CreateValueSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolValue;
end;
{ TFpDwarfSymbolValueWithLocation }
TFpDwarfSymbolValueWithLocation = class(TFpDwarfSymbolValue)
private
procedure FrameBaseNeeded(ASender: TObject); // Sender = TDwarfLocationExpression
protected
function GetValueObject: TFpDbgValue; override;
function InitLocationParser(const ALocationParser: TDwarfLocationExpression;
AnInitLocParserData: PInitLocParserData): Boolean; override;
end;
{ TFpDwarfSymbolType }
(* Types and allowed tags in dwarf 2
DW_TAG_enumeration_type, DW_TAG_subroutine_type, DW_TAG_union_type,
DW_TAG_ptr_to_member_type, DW_TAG_set_type, DW_TAG_subrange_type, DW_TAG_file_type,
DW_TAG_thrown_type
DW_TAG_base_type
DW_AT_encoding Y
DW_AT_bit_offset Y
DW_AT_bit_size Y
DW_TAG_base_type
| DW_TAG_typedef
| | DW_TAG_string_type
| | | DW_TAG_array_type
| | | |
| | | | DW_TAG_class_type
| | | | | DW_TAG_structure_type
| | | | | |
| | | | | | DW_TAG_enumeration_type
| | | | | | | DW_TAG_set_type
| | | | | | | | DW_TAG_enumerator
| | | | | | | | | DW_TAG_subrange_type
DW_AT_name Y Y Y Y Y Y Y Y Y Y
DW_AT_sibling Y Y Y Y Y Y Y Y Y Y
DECL Y Y Y Y Y Y Y Y Y
DW_AT_byte_size Y Y Y Y Y Y Y Y
DW_AT_abstract_origin Y Y Y Y Y Y Y Y
DW_AT_accessibility Y Y Y Y Y Y Y Y
DW_AT_declaration Y Y Y Y Y Y Y Y
DW_AT_start_scope Y Y Y Y Y Y Y
DW_AT_visibility Y Y Y Y Y Y Y Y
DW_AT_type Y Y Y Y
DW_AT_segment Y DW_TAG_string_type
DW_AT_string_length Y
DW_AT_ordering Y DW_TAG_array_type
DW_AT_stride_size Y
DW_AT_const_value Y DW_TAG_enumerator
DW_AT_count Y DW_TAG_subrange_type
DW_AT_lower_bound Y
DW_AT_upper_bound Y
DW_TAG_pointer_type
| DW_TAG_reference_type
| | DW_TAG_packed_type
| | | DW_TAG_const_type
| | | | DW_TAG_volatile_type
DW_AT_address_class Y Y
DW_AT_sibling Y Y Y Y Y
DW_AT_type Y Y Y Y Y
DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
*)
TFpDwarfSymbolType = class(TFpDwarfSymbol)
protected
procedure Init; override;
procedure MemberVisibilityNeeded; override;
procedure SizeNeeded; override;
function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; virtual; // returns refcount=1 for caller, no cached copy kept
public
class function CreateTypeSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolType;
function TypeCastValue(AValue: TFpDbgValue): TFpDbgValue; override;
// TODO: flag bounds as cardinal if needed
function GetValueBounds({%H-}AValueObj: TFpDwarfValue; out ALowBound, AHighBound: Int64): Boolean; virtual;
end;
{ TFpDwarfSymbolTypeBasic }
TFpDwarfSymbolTypeBasic = class(TFpDwarfSymbolType)
//function DoGetNestedTypeInfo: TFpDwarfSymbolType; // return nil
protected
procedure KindNeeded; override;
procedure TypeInfoNeeded; override;
function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
function GetHasBounds: Boolean; override;
function GetOrdHighBound: Int64; override;
function GetOrdLowBound: Int64; override;
end;
{ TFpDwarfSymbolTypeModifier }
TFpDwarfSymbolTypeModifier = class(TFpDwarfSymbolType)
protected
procedure TypeInfoNeeded; override;
procedure ForwardToSymbolNeeded; override;
function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
end;
{ TFpDwarfSymbolTypeRef }
TFpDwarfSymbolTypeRef = class(TFpDwarfSymbolTypeModifier)
protected
function GetFlags: TDbgSymbolFlags; override;
function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
end;
{ TFpDwarfSymbolTypeDeclaration }
TFpDwarfSymbolTypeDeclaration = class(TFpDwarfSymbolTypeModifier)
protected
// fpc encodes classes as pointer, not ref (so Obj1 = obj2 compares the pointers)
// typedef > pointer > srtuct
// while a pointer to class/object: pointer > typedef > ....
function DoGetNestedTypeInfo: TFpDwarfSymbolType; override;
end;
{ TFpDwarfSymbolTypeSubRange }
TFpDwarfSubRangeBoundReadState = (rfNotRead, rfNotFound, rfConst, rfValue);
TFpDwarfSymbolTypeSubRange = class(TFpDwarfSymbolTypeModifier)
// TODO not a modifier, maybe have a forwarder base class
private
FLowBoundConst: Int64;
FLowBoundValue: TFpDwarfSymbolValue;
FLowBoundState: TFpDwarfSubRangeBoundReadState;
FHighBoundConst: Int64;
FHighBoundValue: TFpDwarfSymbolValue;
FHighBoundState: TFpDwarfSubRangeBoundReadState;
FCountConst: Int64;
FCountValue: TFpDwarfSymbolValue;
FCountState: TFpDwarfSubRangeBoundReadState;
FLowEnumIdx, FHighEnumIdx: Integer;
FEnumIdxValid: Boolean;
procedure InitEnumIdx;
procedure ReadBounds(AValueObj: TFpDwarfValue);
protected
function DoGetNestedTypeInfo: TFpDwarfSymbolType;override;
function GetHasBounds: Boolean; override;
function GetOrdHighBound: Int64; override;
function GetOrdLowBound: Int64; override;
procedure NameNeeded; override;
procedure KindNeeded; override;
procedure SizeNeeded; override;
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
function GetFlags: TDbgSymbolFlags; override;
procedure Init; override;
public
function GetValueBounds(AValueObj: TFpDwarfValue; out ALowBound,
AHighBound: Int64): Boolean; override;
end;
{ TFpDwarfSymbolTypePointer }
TFpDwarfSymbolTypePointer = class(TFpDwarfSymbolType)
private
FIsInternalPointer: Boolean;
function GetIsInternalPointer: Boolean; inline;
function IsInternalDynArrayPointer: Boolean; inline;
protected
procedure TypeInfoNeeded; override;
procedure KindNeeded; override;
procedure SizeNeeded; override;
procedure ForwardToSymbolNeeded; override;
function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
function DataSize: Integer; override;
public
property IsInternalPointer: Boolean read GetIsInternalPointer write FIsInternalPointer; // Class (also DynArray, but DynArray is handled without this)
end;
{ TFpDwarfSymbolValueEnumMember }
TFpDwarfSymbolValueEnumMember = class(TFpDwarfSymbolValue)
FOrdinalValue: Int64;
FOrdinalValueRead, FHasOrdinalValue: Boolean;
procedure ReadOrdinalValue;
protected
procedure KindNeeded; override;
function GetHasOrdinalValue: Boolean; override;
function GetOrdinalValue: Int64; override;
procedure Init; override;
function GetValueObject: TFpDbgValue; override;
end;
{ TFpDwarfSymbolTypeEnum }
TFpDwarfSymbolTypeEnum = class(TFpDwarfSymbolType)
private
FMembers: TFpDbgCircularRefCntObjList;
procedure CreateMembers;
protected
function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
procedure KindNeeded; override;
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
function GetHasBounds: Boolean; override;
function GetOrdHighBound: Int64; override;
function GetOrdLowBound: Int64; override;
public
destructor Destroy; override;
end;
{ TFpDwarfSymbolTypeSet }
TFpDwarfSymbolTypeSet = class(TFpDwarfSymbolType)
protected
procedure KindNeeded; override;
function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
function GetMemberCount: Integer; override;
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
end;
(*
If not specified
.NestedTypeInfo --> copy of TypeInfo
.ParentTypeInfo --> nil
ParentTypeInfo: has a weak RefCount (only AddRef, if self has other refs)
AnObject = TFpDwarfSymbolValueVariable
|-- .TypeInfo --> TBar = TFpDwarfSymbolTypeStructure [*1]
|-- .ParentTypeInfo --> may point to subroutine, if param or local var // TODO
TBar = TFpDwarfSymbolTypeStructure
|-- .TypeInfo --> TBarBase = TFpDwarfSymbolTypeStructure
TBarBase = TFpDwarfSymbolTypeStructure
|-- .TypeInfo --> TOBject = TFpDwarfSymbolTypeStructure
TObject = TFpDwarfSymbolTypeStructure
|-- .TypeInfo --> nil
FField = TFpDwarfSymbolValueMember (declared in TBarBase)
|-- .TypeInfo --> Integer = TFpDwarfSymbolTypeBasic [*1]
|-- .ParentTypeInfo --> TBarBase
[*1] May have TFpDwarfSymbolTypeDeclaration or others
*)
{ TFpDwarfSymbolValueMember }
TFpDwarfSymbolValueMember = class(TFpDwarfSymbolValueWithLocation)
protected
function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
function HasAddress: Boolean; override;
end;
{ TFpDwarfSymbolTypeStructure }
TFpDwarfSymbolTypeStructure = class(TFpDwarfSymbolType)
// record or class
private
FMembers: TFpDbgCircularRefCntObjList;
FLastChildByName: TFpDwarfSymbol;
FInheritanceInfo: TDwarfInformationEntry;
procedure CreateMembers;
procedure InitInheritanceInfo; inline;
protected
function DoGetNestedTypeInfo: TFpDwarfSymbolType; override;
procedure KindNeeded; override;
function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
// GetMember, if AIndex > Count then parent
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
public
destructor Destroy; override;
end;
{ TFpDwarfSymbolTypeArray }
TFpDwarfSymbolTypeArray = class(TFpDwarfSymbolType)
private
FMembers: TFpDbgCircularRefCntObjList;
FRowMajor: Boolean;
FStrideInBits: Int64;
FDwarfArrayReadFlags: set of (didtStrideRead, didtOrdering);
procedure CreateMembers;
procedure ReadStride;
procedure ReadOrdering;
protected
procedure KindNeeded; override;
function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
function GetFlags: TDbgSymbolFlags; override;
// GetMember: returns the TYPE/range of each index. NOT the data
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberByName({%H-}AIndex: String): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
function GetMemberAddress(AValObject: TFpDwarfValue; AIndex: Array of Int64): TFpDbgMemLocation;
public
destructor Destroy; override;
end;
{ TFpDwarfSymbolValueProc }
TFpDwarfSymbolValueProc = class(TFpDwarfSymbolValue)
private
//FCU: TDwarfCompilationUnit;
FProcMembers: TRefCntObjList; // Locals
FLastMember: TFpDbgSymbol;
FAddress: TDbgPtr;
FAddressInfo: PDwarfAddressInfo;
FStateMachine: TDwarfLineInfoStateMachine;
FFrameBaseParser: TDwarfLocationExpression;
FSelfParameter: TFpDwarfValue;
function StateMachineValid: Boolean;
function ReadVirtuality(out AFlags: TDbgSymbolFlags): Boolean;
procedure CreateMembers;
protected
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
function GetMemberCount: Integer; override;
function GetFrameBase(ASender: TDwarfLocationExpression): TDbgPtr;
procedure KindNeeded; override;
procedure SizeNeeded; override;
function GetFlags: TDbgSymbolFlags; override;
function GetColumn: Cardinal; override;
function GetFile: String; override;
// function GetFlags: TDbgSymbolFlags; override;
function GetLine: Cardinal; override;
function GetValueObject: TFpDbgValue; override;
public
constructor Create(ACompilationUnit: TDwarfCompilationUnit; AInfo: PDwarfAddressInfo; AAddress: TDbgPtr); overload;
destructor Destroy; override;
// TODO members = locals ?
function GetSelfParameter(AnAddress: TDbgPtr = 0): TFpDwarfValue;
end;
{ TFpDwarfSymbolValueVariable }
TFpDwarfSymbolValueVariable = class(TFpDwarfSymbolValueWithLocation)
protected
function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
function HasAddress: Boolean; override;
public
end;
{ TFpDwarfSymbolValueParameter }
TFpDwarfSymbolValueParameter = class(TFpDwarfSymbolValueWithLocation)
protected
function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
function HasAddress: Boolean; override;
function GetFlags: TDbgSymbolFlags; override;
public
end;
{ TFpDwarfSymbolUnit }
TFpDwarfSymbolUnit = class(TFpDwarfSymbol)
private
FLastChildByName: TFpDbgSymbol;
protected
procedure Init; override;
function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
public
destructor Destroy; override;
end;
{%endregion Symbol objects }
implementation
var
FPDBG_DWARF_VERBOSE, FPDBG_DWARF_ERRORS, FPDBG_DWARF_WARNINGS, FPDBG_DWARF_SEARCH, FPDBG_DWARF_DATA_WARNINGS: PLazLoggerLogGroup;
{ TFpDwarfDefaultSymbolClassMap }
class function TFpDwarfDefaultSymbolClassMap.HandleCompUnit(ACU: TDwarfCompilationUnit): Boolean;
begin
Result := True;
end;
class function TFpDwarfDefaultSymbolClassMap.GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
case ATag of
// TODO:
DW_TAG_constant:
Result := TFpDwarfSymbolValue;
DW_TAG_string_type,
DW_TAG_union_type, DW_TAG_ptr_to_member_type,
DW_TAG_file_type,
DW_TAG_thrown_type, DW_TAG_subroutine_type:
Result := TFpDwarfSymbolType;
// Type types
DW_TAG_packed_type,
DW_TAG_const_type,
DW_TAG_volatile_type: Result := TFpDwarfSymbolTypeModifier;
DW_TAG_reference_type: Result := TFpDwarfSymbolTypeRef;
DW_TAG_typedef: Result := TFpDwarfSymbolTypeDeclaration;
DW_TAG_pointer_type: Result := TFpDwarfSymbolTypePointer;
DW_TAG_base_type: Result := TFpDwarfSymbolTypeBasic;
DW_TAG_subrange_type: Result := TFpDwarfSymbolTypeSubRange;
DW_TAG_enumeration_type: Result := TFpDwarfSymbolTypeEnum;
DW_TAG_enumerator: Result := TFpDwarfSymbolValueEnumMember;
DW_TAG_set_type: Result := TFpDwarfSymbolTypeSet;
DW_TAG_structure_type,
DW_TAG_class_type: Result := TFpDwarfSymbolTypeStructure;
DW_TAG_array_type: Result := TFpDwarfSymbolTypeArray;
// Value types
DW_TAG_variable: Result := TFpDwarfSymbolValueVariable;
DW_TAG_formal_parameter: Result := TFpDwarfSymbolValueParameter;
DW_TAG_member: Result := TFpDwarfSymbolValueMember;
DW_TAG_subprogram: Result := TFpDwarfSymbolValueProc;
//
DW_TAG_compile_unit: Result := TFpDwarfSymbolUnit;
else
Result := TFpDwarfSymbol;
end;
end;
class function TFpDwarfDefaultSymbolClassMap.CreateContext(AThreadId, AStackFrame: Integer;
AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext;
begin
Result := TFpDwarfInfoAddressContext.Create(AThreadId, AStackFrame, AnAddress, ASymbol, ADwarf);
end;
class function TFpDwarfDefaultSymbolClassMap.CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase;
begin
Result := TFpDwarfSymbolValueProc.Create(ACompilationUnit, AInfo, AAddress);
end;
{ TDbgDwarfInfoAddressContext }
function TFpDwarfInfoAddressContext.GetSymbolAtAddress: TFpDbgSymbol;
begin
Result := FSymbol;
end;
function TFpDwarfInfoAddressContext.GetProcedureAtAddress: TFpDbgValue;
begin
Result := inherited GetProcedureAtAddress;
ApplyContext(Result);
end;
function TFpDwarfInfoAddressContext.GetAddress: TDbgPtr;
begin
Result := FAddress;
end;
function TFpDwarfInfoAddressContext.GetThreadId: Integer;
begin
Result := FThreadId;
end;
function TFpDwarfInfoAddressContext.GetStackFrame: Integer;
begin
Result := FStackFrame;
end;
function TFpDwarfInfoAddressContext.GetSizeOfAddress: Integer;
begin
assert(FSymbol is TFpDwarfSymbol, 'TDbgDwarfInfoAddressContext.GetSizeOfAddress');
Result := TFpDwarfSymbol(FSymbol).CompilationUnit.AddressSize;
end;
function TFpDwarfInfoAddressContext.GetMemManager: TFpDbgMemManager;
begin
Result := FDwarf.MemManager;
end;
function TFpDwarfInfoAddressContext.ApplyContext(AVal: TFpDbgValue): TFpDbgValue;
begin
if (AVal <> nil) and (TFpDwarfValueBase(AVal).FContext = nil) then
TFpDwarfValueBase(AVal).FContext := Self;
end;
function TFpDwarfInfoAddressContext.SymbolToValue(ASym: TFpDbgSymbol): TFpDbgValue;
begin
if ASym = nil then begin
Result := nil;
exit;
end;
if ASym.SymbolType = stValue then begin
Result := ASym.Value;
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
end
else begin
Result := TFpDwarfValueTypeDefinition.Create(ASym);
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(@FlastResult, 'FindSymbol'){$ENDIF};
end;
ASym.ReleaseReference;
end;
procedure TFpDwarfInfoAddressContext.AddRefToVal(AVal: TFpDbgValue);
begin
AVal.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
end;
function TFpDwarfInfoAddressContext.GetSelfParameter: TFpDbgValue;
begin
Result := TFpDwarfSymbolValueProc(FSymbol).GetSelfParameter(FAddress);
if (Result <> nil) and (TFpDwarfValueBase(Result).FContext = nil) then
TFpDwarfValueBase(Result).FContext := Self;
end;
function TFpDwarfInfoAddressContext.FindExportedSymbolInUnits(const AName: String; PNameUpper,
PNameLower: PChar; SkipCompUnit: TDwarfCompilationUnit; out ADbgValue: TFpDbgValue): Boolean;
var
i, ExtVal: Integer;
CU: TDwarfCompilationUnit;
InfoEntry, FoundInfoEntry: TDwarfInformationEntry;
s: String;
begin
Result := False;
ADbgValue := nil;
InfoEntry := nil;
FoundInfoEntry := nil;
i := FDwarf.CompilationUnitsCount;
while i > 0 do begin
dec(i);
CU := FDwarf.CompilationUnits[i];
if CU = SkipCompUnit then
continue;
//DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier search UNIT Name=', CU.FileName]);
InfoEntry.ReleaseReference;
InfoEntry := TDwarfInformationEntry.Create(CU, nil);
InfoEntry.ScopeIndex := CU.FirstScope.Index;
if not InfoEntry.AbbrevTag = DW_TAG_compile_unit then
continue;
// compile_unit can not have startscope
s := CU.UnitName;
if (s <> '') and (CompareUtf8BothCase(PNameUpper, PNameLower, @s[1])) then begin
ReleaseRefAndNil(FoundInfoEntry);
ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
break;
end;
CU.ScanAllEntries;
if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
if InfoEntry.IsAddressInStartScope(FAddress) then begin
// only variables are marked "external", but types not / so we may need all top level
FoundInfoEntry.ReleaseReference;
FoundInfoEntry := InfoEntry.Clone;
//DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier MAYBE FOUND Name=', CU.FileName]);
// DW_AT_visibility ?
if InfoEntry.ReadValue(DW_AT_external, ExtVal) then
if ExtVal <> 0 then
break;
// Search for better ADbgValue
end;
end;
end;
if FoundInfoEntry <> nil then begin;
ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, FoundInfoEntry));
FoundInfoEntry.ReleaseReference;
end;
InfoEntry.ReleaseReference;
Result := ADbgValue <> nil;
end;
function TFpDwarfInfoAddressContext.FindSymbolInStructure(const AName: String; PNameUpper,
PNameLower: PChar; InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean;
var
InfoEntryInheritance: TDwarfInformationEntry;
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
SelfParam: TFpDbgValue;
begin
Result := False;
ADbgValue := nil;
InfoEntry.AddReference;
while True do begin
if not InfoEntry.IsAddressInStartScope(FAddress) then
break;
InfoEntryInheritance := InfoEntry.FindChildByTag(DW_TAG_inheritance);
if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
if InfoEntry.IsAddressInStartScope(FAddress) then begin
SelfParam := GetSelfParameter;
if (SelfParam <> nil) then begin
// TODO: only valid, as long as context is valid, because if context is freed, then self is lost too
ADbgValue := SelfParam.MemberByName[AName];
assert(ADbgValue <> nil, 'FindSymbol: SelfParam.MemberByName[AName]');
if ADbgValue <> nil then
ADbgValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
end
else debugln(['TDbgDwarfInfoAddressContext.FindSymbol XXXXXXXXXXXXX no self']);
;
if ADbgValue = nil then begin // Todo: abort the searh /SetError
ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
end;
InfoEntry.ReleaseReference;
InfoEntryInheritance.ReleaseReference;
Result := True;
exit;
end;
end;
if not( (InfoEntryInheritance <> nil) and
(InfoEntryInheritance.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint)) )
then
break;
InfoEntry.ReleaseReference;
InfoEntry := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
InfoEntryInheritance.ReleaseReference;
DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier PARENT ', dbgs(InfoEntry, FwdCompUint) ]);
end;
InfoEntry.ReleaseReference;
Result := ADbgValue <> nil;
end;
function TFpDwarfInfoAddressContext.FindLocalSymbol(const AName: String; PNameUpper,
PNameLower: PChar; InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean;
begin
Result := False;
ADbgValue := nil;
if not InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then
exit;
if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
TFpDwarfSymbol(ADbgValue.DbgSymbol).ParentTypeInfo := TFpDwarfSymbolValueProc(FSymbol);
end;
Result := ADbgValue <> nil;
end;
constructor TFpDwarfInfoAddressContext.Create(AThreadId, AStackFrame: Integer;
AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo);
begin
inherited Create;
AddReference;
FAddress := AnAddress;
FThreadId := AThreadId;
FStackFrame := AStackFrame;
FDwarf := ADwarf;
FSymbol := ASymbol;
FSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'Context to Symbol'){$ENDIF};
end;
destructor TFpDwarfInfoAddressContext.Destroy;
begin
FlastResult.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
FSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'Context to Symbol'){$ENDIF};
inherited Destroy;
end;
function TFpDwarfInfoAddressContext.FindSymbol(const AName: String): TFpDbgValue;
var
SubRoutine: TFpDwarfSymbolValueProc; // TDbgSymbol;
CU: TDwarfCompilationUnit;
//Scope,
StartScopeIdx: Integer;
InfoEntry: TDwarfInformationEntry;
NameUpper, NameLower: String;
InfoName: PChar;
tg: Cardinal;
PNameUpper, PNameLower: PChar;
begin
Result := nil;
if (FSymbol = nil) or not(FSymbol is TFpDwarfSymbolValueProc) or (AName = '') then
exit;
SubRoutine := TFpDwarfSymbolValueProc(FSymbol);
NameUpper := UTF8UpperCase(AName);
NameLower := UTF8LowerCase(AName);
PNameUpper := @NameUpper[1];
PNameLower := @NameLower[1];
try
CU := SubRoutine.CompilationUnit;
InfoEntry := SubRoutine.InformationEntry.Clone;
while InfoEntry.HasValidScope do begin
//debugln(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier Searching ', dbgs(InfoEntry.FScope, CU)]);
StartScopeIdx := InfoEntry.ScopeIndex;
//if InfoEntry.Abbrev = nil then
// exit;
if not InfoEntry.IsAddressInStartScope(FAddress) // StartScope = first valid address
then begin
// CONTINUE: Search parent(s)
//InfoEntry.ScopeIndex := StartScopeIdx;
InfoEntry.GoParent;
Continue;
end;
if InfoEntry.ReadName(InfoName) and not InfoEntry.IsArtificial
then begin
if (CompareUtf8BothCase(PNameUpper, PNameLower, InfoName)) then begin
// TODO: this is a pascal sperific search order? Or not?
// If this is a type with a pointer or ref, need to find the pointer or ref.
InfoEntry.GoParent;
if InfoEntry.HasValidScope and
InfoEntry.GoNamedChildEx(PNameUpper, PNameLower)
then begin
if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
exit;
end;
end;
InfoEntry.ScopeIndex := StartScopeIdx;
Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
exit;
end;
end;
tg := InfoEntry.AbbrevTag;
if (tg = DW_TAG_class_type) or (tg = DW_TAG_structure_type) then begin
if FindSymbolInStructure(AName,PNameUpper, PNameLower, InfoEntry, Result) then
exit; // TODO: check error
//InfoEntry.ScopeIndex := StartScopeIdx;
end
else
if (StartScopeIdx = SubRoutine.InformationEntry.ScopeIndex) then begin // searching in subroutine
if FindLocalSymbol(AName,PNameUpper, PNameLower, InfoEntry, Result) then
exit; // TODO: check error
//InfoEntry.ScopeIndex := StartScopeIdx;
end
// TODO: nested subroutine
else
if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
exit;
end;
end;
// Search parent(s)
InfoEntry.ScopeIndex := StartScopeIdx;
InfoEntry.GoParent;
end;
FindExportedSymbolInUnits(AName, PNameUpper, PNameLower, CU, Result);
finally
if (Result = nil) or (InfoEntry = nil)
then DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier NOT found Name=', AName])
else DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier(',AName,') found Scope=', TFpDwarfSymbol(Result.DbgSymbol).InformationEntry.ScopeDebugText, ' ResultSymbol=', DbgSName(Result.DbgSymbol), ' ', Result.DbgSymbol.Name, ' in ', TFpDwarfSymbol(Result.DbgSymbol).CompilationUnit.FileName]);
ReleaseRefAndNil(InfoEntry);
FlastResult.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
FlastResult := Result;
assert((Result = nil) or (Result is TFpDwarfValueBase), 'TDbgDwarfInfoAddressContext.FindSymbol: (Result = nil) or (Result is TFpDwarfValueBase)');
ApplyContext(Result);
end;
end;
{ TFpDwarfValueTypeDefinition }
function TFpDwarfValueTypeDefinition.GetKind: TDbgSymbolKind;
begin
Result := skNone;
end;
function TFpDwarfValueTypeDefinition.GetDbgSymbol: TFpDbgSymbol;
begin
Result := FSymbol;
end;
constructor TFpDwarfValueTypeDefinition.Create(ASymbol: TFpDbgSymbol);
begin
inherited Create;
FSymbol := ASymbol;
FSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'TFpDwarfValueTypeDefinition'){$ENDIF};
end;
destructor TFpDwarfValueTypeDefinition.Destroy;
begin
inherited Destroy;
FSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'TFpDwarfValueTypeDefinition'){$ENDIF};
end;
function TFpDwarfValueTypeDefinition.GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue;
begin
Result := FSymbol.TypeCastValue(ADataVal);
assert((Result = nil) or (Result is TFpDwarfValue), 'TFpDwarfValueTypeDefinition.GetTypeCastedValue: (Result = nil) or (Result is TFpDwarfValue)');
if (Result <> nil) and (TFpDwarfValue(Result).FContext = nil) then
TFpDwarfValue(Result).FContext := FContext;
end;
{ TFpDwarfValue }
function TFpDwarfValue.MemManager: TFpDbgMemManager;
begin
Result := nil;
if FContext <> nil then
Result := FContext.MemManager;
if Result = nil then begin
// Either a typecast, or a member gotten from a typecast,...
assert((FOwner <> nil) and (FOwner.CompilationUnit <> nil) and (FOwner.CompilationUnit.Owner <> nil), 'TDbgDwarfSymbolValue.MemManager');
Result := FOwner.CompilationUnit.Owner.MemManager;
end;
end;
function TFpDwarfValue.GetDataAddressCache(AIndex: Integer): TFpDbgMemLocation;
begin
if AIndex < Length(FDataAddressCache) then
Result := FDataAddressCache[AIndex]
else
Result := UnInitializedLoc;
end;
function TFpDwarfValue.AddressSize: Byte;
begin
assert((FOwner <> nil) and (FOwner.CompilationUnit <> nil), 'TDbgDwarfSymbolValue.AddressSize');
Result := FOwner.CompilationUnit.AddressSize;
end;
procedure TFpDwarfValue.SetDataAddressCache(AIndex: Integer; AValue: TFpDbgMemLocation);
var
i, j: Integer;
begin
i := length(FDataAddressCache);
if AIndex >= i then begin
SetLength(FDataAddressCache, AIndex + 1 + 8);
// todo: Fillbyte 0
for j := i to Length(FDataAddressCache) - 1 do
FDataAddressCache[j] := UnInitializedLoc;
end;
FDataAddressCache[AIndex] := AValue;
end;
procedure TFpDwarfValue.SetStructureValue(AValue: TFpDwarfValue);
begin
if FStructureValue <> nil then
Reset;
if FStructureValue = AValue then
exit;
if CircleBackRefsActive and (FStructureValue <> nil) then
FStructureValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
FStructureValue := AValue;
if CircleBackRefsActive and (FStructureValue <> nil) then
FStructureValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
end;
function TFpDwarfValue.GetLastError: TFpError;
begin
Result := FLastError;
end;
function TFpDwarfValue.DataAddr: TFpDbgMemLocation;
begin
// GetDwarfDataAddress(???); What about FTypeCastSourceValue.AsCardinal ?
if FValueSymbol <> nil then begin
//FValueSymbol.GetValueAddress(Self, Result);
FValueSymbol.GetValueDataAddress(Self, Result, FOwner);
if IsError(FValueSymbol.LastError) then
FLastError := FValueSymbol.LastError;
end
else
if HasTypeCastInfo then begin
Result := FTypeCastSourceValue.Address;
if IsError(FTypeCastSourceValue.LastError) then
FLastError := FTypeCastSourceValue.LastError;
if IsReadableLoc(Result) then begin
if not FTypeCastTargetType.GetDataAddress(Self, Result, FOwner, 1) then
Result := InvalidLoc;
if IsError(FTypeCastTargetType.LastError) then
FLastError := FTypeCastTargetType.LastError;
end;
end
else
Result := InvalidLoc;
end;
function TFpDwarfValue.OrdOrDataAddr: TFpDbgMemLocation;
begin
if HasTypeCastInfo and (svfOrdinal in FTypeCastSourceValue.FieldFlags) then
Result := ConstLoc(FTypeCastSourceValue.AsCardinal)
else
Result := DataAddr;
end;
function TFpDwarfValue.GetDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType): Boolean;
var
fields: TFpDbgValueFieldFlags;
begin
if FValueSymbol <> nil then begin
Assert(FValueSymbol is TFpDwarfSymbolValue, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol');
Assert(TypeInfo is TFpDwarfSymbolType, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo');
Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo');
Result := FValueSymbol.GetValueDataAddress(Self, AnAddress, ATargetType);
if IsError(FValueSymbol.LastError) then
FLastError := FValueSymbol.LastError;
end
else
begin
// TODO: cache own address
// try typecast
Result := HasTypeCastInfo;
if not Result then
exit;
fields := FTypeCastSourceValue.FieldFlags;
AnAddress := InvalidLoc;
if svfOrdinal in fields then
AnAddress := ConstLoc(FTypeCastSourceValue.AsCardinal)
else
if svfAddress in fields then
AnAddress := FTypeCastSourceValue.Address;
Result := IsReadableLoc(AnAddress);
if not Result then
exit;
Result := FTypeCastTargetType.GetDataAddress(Self, AnAddress, ATargetType, 1);
if IsError(FTypeCastTargetType.LastError) then
FLastError := FTypeCastTargetType.LastError;
end;
end;
function TFpDwarfValue.GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
ATargetType: TFpDwarfSymbolType): Boolean;
begin
AnAddress := InvalidLoc;
Result := StructureValue <> nil;
if Result then
Result := StructureValue.GetDwarfDataAddress(AnAddress, ATargetType);
end;
function TFpDwarfValue.HasDwarfDataAddress: Boolean;
begin
if FValueSymbol <> nil then begin
Assert(FValueSymbol is TFpDwarfSymbolValue, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol');
Assert(TypeInfo is TFpDwarfSymbolType, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo');
Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo');
Result := FValueSymbol.HasAddress;
end
else
begin
// try typecast
Result := HasTypeCastInfo;
if not Result then
exit;
Result := FTypeCastSourceValue.FieldFlags * [svfAddress, svfOrdinal] <> [];
end;
end;
procedure TFpDwarfValue.Reset;
begin
FDataAddressCache := nil;
FLastError := NoError;
end;
function TFpDwarfValue.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
if FValueSymbol <> nil then begin
if FValueSymbol.HasAddress then Result := Result + [svfAddress];
end
else
if HasTypeCastInfo then begin
Result := Result + FTypeCastSourceValue.FieldFlags * [svfAddress];
end;
end;
function TFpDwarfValue.HasTypeCastInfo: Boolean;
begin
Result := (FTypeCastTargetType <> nil) and (FTypeCastSourceValue <> nil);
end;
function TFpDwarfValue.IsValidTypeCast: Boolean;
begin
Result := False;
end;
procedure TFpDwarfValue.DoReferenceAdded;
begin
inherited DoReferenceAdded;
DoPlainReferenceAdded;
end;
procedure TFpDwarfValue.DoReferenceReleased;
begin
inherited DoReferenceReleased;
DoPlainReferenceReleased;
end;
procedure TFpDwarfValue.CircleBackRefActiveChanged(NewActive: Boolean);
begin
inherited CircleBackRefActiveChanged(NewActive);
if NewActive then;
if CircleBackRefsActive then begin
if FValueSymbol <> nil then
FValueSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
if FStructureValue <> nil then
FStructureValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
end
else begin
if FValueSymbol <> nil then
FValueSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
if FStructureValue <> nil then
FStructureValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
end;
end;
procedure TFpDwarfValue.SetLastMember(ALastMember: TFpDwarfValue);
begin
if FLastMember <> nil then
FLastMember.ReleaseCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TDbgDwarfSymbolValue'){$ENDIF};
FLastMember := ALastMember;
if (FLastMember <> nil) then begin
FLastMember.SetStructureValue(Self);
FLastMember.AddCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TDbgDwarfSymbolValue'){$ENDIF};
if (FLastMember.FContext = nil) then
FLastMember.FContext := FContext;
end;
end;
function TFpDwarfValue.GetKind: TDbgSymbolKind;
begin
if FValueSymbol <> nil then
Result := FValueSymbol.Kind
else
if HasTypeCastInfo then
Result := FTypeCastTargetType.Kind
else
Result := inherited GetKind;
end;
function TFpDwarfValue.GetAddress: TFpDbgMemLocation;
begin
if FValueSymbol <> nil then
FValueSymbol.GetValueAddress(Self, Result)
else
if HasTypeCastInfo then
Result := FTypeCastSourceValue.Address
else
Result := inherited GetAddress;
end;
function TFpDwarfValue.OrdOrAddress: TFpDbgMemLocation;
begin
if HasTypeCastInfo and (svfOrdinal in FTypeCastSourceValue.FieldFlags) then
Result := ConstLoc(FTypeCastSourceValue.AsCardinal)
else
Result := Address;
end;
function TFpDwarfValue.GetMemberCount: Integer;
begin
if FValueSymbol <> nil then
Result := FValueSymbol.MemberCount
else
Result := inherited GetMemberCount;
end;
function TFpDwarfValue.GetMemberByName(AIndex: String): TFpDbgValue;
var
m: TFpDbgSymbol;
begin
Result := nil;
if FValueSymbol <> nil then begin
m := FValueSymbol.MemberByName[AIndex];
if m <> nil then
Result := m.Value;
end;
SetLastMember(TFpDwarfValue(Result));
end;
function TFpDwarfValue.GetMember(AIndex: Int64): TFpDbgValue;
var
m: TFpDbgSymbol;
begin
Result := nil;
if FValueSymbol <> nil then begin
m := FValueSymbol.Member[AIndex];
if m <> nil then
Result := m.Value;
end;
SetLastMember(TFpDwarfValue(Result));
end;
function TFpDwarfValue.GetDbgSymbol: TFpDbgSymbol;
begin
Result := FValueSymbol;
end;
function TFpDwarfValue.GetTypeInfo: TFpDbgSymbol;
begin
if HasTypeCastInfo then
Result := FTypeCastTargetType
else
Result := inherited GetTypeInfo;
end;
function TFpDwarfValue.GetContextTypeInfo: TFpDbgSymbol;
begin
if (FValueSymbol <> nil) and (FValueSymbol.ParentTypeInfo <> nil) then
Result := FValueSymbol.ParentTypeInfo
else
Result := nil; // internal error
end;
constructor TFpDwarfValue.Create(AOwner: TFpDwarfSymbolType);
begin
FOwner := AOwner;
inherited Create;
end;
destructor TFpDwarfValue.Destroy;
begin
FTypeCastTargetType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
FTypeCastSourceValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
SetLastMember(nil);
inherited Destroy;
end;
procedure TFpDwarfValue.SetValueSymbol(AValueSymbol: TFpDwarfSymbolValue);
begin
if FValueSymbol = AValueSymbol then
exit;
if CircleBackRefsActive and (FValueSymbol <> nil) then
FValueSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
FValueSymbol := AValueSymbol;
if CircleBackRefsActive and (FValueSymbol <> nil) then
FValueSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
end;
function TFpDwarfValue.SetTypeCastInfo(AStructure: TFpDwarfSymbolType;
ASource: TFpDbgValue): Boolean;
begin
Reset;
if FTypeCastSourceValue <> ASource then begin
if FTypeCastSourceValue <> nil then
FTypeCastSourceValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
FTypeCastSourceValue := ASource;
if FTypeCastSourceValue <> nil then
FTypeCastSourceValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
end;
if FTypeCastTargetType <> AStructure then begin
if FTypeCastTargetType <> nil then
FTypeCastTargetType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
FTypeCastTargetType := AStructure;
if FTypeCastTargetType <> nil then
FTypeCastTargetType.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
end;
Result := IsValidTypeCast;
end;
{ TFpDwarfValueSized }
function TFpDwarfValueSized.CanUseTypeCastAddress: Boolean;
begin
Result := True;
if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
exit
else
if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSize] = [svfAddress, svfSize]) and
(FTypeCastSourceValue.Size = FSize) and (FSize > 0)
then
exit;
if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) and
not ( (FTypeCastTargetType.Kind = skPointer) //or
//(FSize = AddressSize xxxxxxx)
)
then
exit;
Result := False;
end;
function TFpDwarfValueSized.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfSize];
end;
function TFpDwarfValueSized.GetSize: Integer;
begin
Result := FSize;
end;
constructor TFpDwarfValueSized.Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
begin
inherited Create(AOwner);
FSize := ASize;
end;
{ TFpDwarfValueNumeric }
procedure TFpDwarfValueNumeric.Reset;
begin
inherited Reset;
FEvaluated := [];
end;
function TFpDwarfValueNumeric.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfOrdinal];
end;
function TFpDwarfValueNumeric.IsValidTypeCast: Boolean;
begin
Result := HasTypeCastInfo;
If not Result then
exit;
if (svfOrdinal in FTypeCastSourceValue.FieldFlags) or CanUseTypeCastAddress then
exit;
Result := False;
end;
constructor TFpDwarfValueNumeric.Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
begin
inherited Create(AOwner, ASize);
FEvaluated := [];
end;
{ TFpDwarfValueInteger }
function TFpDwarfValueInteger.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfInteger];
end;
function TFpDwarfValueInteger.GetAsCardinal: QWord;
begin
Result := QWord(GetAsInteger); // include sign extension
end;
function TFpDwarfValueInteger.GetAsInteger: Int64;
begin
if doneInt in FEvaluated then begin
Result := FIntValue;
exit;
end;
Include(FEvaluated, doneInt);
if (FSize <= 0) or (FSize > SizeOf(Result)) then
Result := inherited GetAsInteger
else
if not MemManager.ReadSignedInt(OrdOrDataAddr, FSize, Result) then begin
Result := 0; // TODO: error
FLastError := MemManager.LastError;
end;
FIntValue := Result;
end;
{ TDbgDwarfCardinalSymbolValue }
function TFpDwarfValueCardinal.GetAsCardinal: QWord;
begin
if doneUInt in FEvaluated then begin
Result := FValue;
exit;
end;
Include(FEvaluated, doneUInt);
if (FSize <= 0) or (FSize > SizeOf(Result)) then
Result := inherited GetAsCardinal
else
if not MemManager.ReadUnsignedInt(OrdOrDataAddr, FSize, Result) then begin
Result := 0; // TODO: error
FLastError := MemManager.LastError;
end;
FValue := Result;
end;
function TFpDwarfValueCardinal.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfCardinal];
end;
{ TFpDwarfValueFloat }
function TFpDwarfValueFloat.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfFloat] - [svfOrdinal];
end;
function TFpDwarfValueFloat.GetAsFloat: Extended;
begin
if doneFloat in FEvaluated then begin
Result := FValue;
exit;
end;
Include(FEvaluated, doneUInt);
if (FSize <= 0) or (FSize > SizeOf(Result)) then
Result := inherited GetAsCardinal
else
if not MemManager.ReadFloat(OrdOrDataAddr, FSize, Result) then begin
Result := 0; // TODO: error
FLastError := MemManager.LastError;
end;
FValue := Result;
end;
{ TFpDwarfValueBoolean }
function TFpDwarfValueBoolean.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfBoolean];
end;
function TFpDwarfValueBoolean.GetAsBool: Boolean;
begin
Result := QWord(GetAsCardinal) <> 0;
end;
{ TFpDwarfValueChar }
function TFpDwarfValueChar.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
case FSize of
1: Result := Result + [svfString];
2: Result := Result + [svfWideString];
end;
end;
function TFpDwarfValueChar.GetAsString: AnsiString;
begin
// Can typecast, because of FSize = 1, GetAsCardinal only read one byte
if FSize <> 1 then
Result := inherited GetAsString
else
Result := SysToUTF8(char(byte(GetAsCardinal)));
end;
function TFpDwarfValueChar.GetAsWideString: WideString;
begin
if FSize > 2 then
Result := inherited GetAsString
else
Result := WideChar(Word(GetAsCardinal));
end;
{ TFpDwarfValuePointer }
function TFpDwarfValuePointer.GetAsCardinal: QWord;
var
a: TFpDbgMemLocation;
begin
a := GetDataAddress;
if IsTargetAddr(a) then
Result := LocToAddr(a)
else
Result := 0;
end;
function TFpDwarfValuePointer.GetFieldFlags: TFpDbgValueFieldFlags;
var
t: TFpDbgSymbol;
begin
Result := inherited GetFieldFlags;
//TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
Result := Result + [svfCardinal, svfOrdinal, svfSizeOfPointer, svfDataAddress] - [svfSize]; // data address
t := TypeInfo;
if (t <> nil) then t := t.TypeInfo;
if (t <> nil) and (t.Kind = skChar) and IsReadableMem(DataAddress) then // pchar
Result := Result + [svfString]; // data address
end;
function TFpDwarfValuePointer.GetDataAddress: TFpDbgMemLocation;
begin
if doneAddr in FEvaluated then begin
Result := FPointetToAddr;
exit;
end;
Include(FEvaluated, doneAddr);
if (FSize <= 0) then
Result := InvalidLoc
else
begin
if not MemManager.ReadAddress(OrdOrDataAddr, FSize, Result) then
FLastError := MemManager.LastError;
end;
FPointetToAddr := Result;
end;
function TFpDwarfValuePointer.GetAsString: AnsiString;
var
t: TFpDbgSymbol;
i: Integer;
begin
t := TypeInfo;
if (t <> nil) then t := t.TypeInfo;
if (MemManager <> nil) and (t <> nil) and (t.Kind = skChar) and IsReadableMem(DataAddress) then begin // pchar
SetLength(Result, 2000);
i := 2000;
while (i > 0) and (not MemManager.ReadMemory(DataAddress, 2000, @Result[1])) do
i := i div 2;
SetLength(Result,i);
i := pos(#0, Result);
if i > 0 then
SetLength(Result,i-1);
exit;
end;
Result := inherited GetAsString;
end;
function TFpDwarfValuePointer.GetMember(AIndex: Int64): TFpDbgValue;
var
ti: TFpDbgSymbol;
addr: TFpDbgMemLocation;
Tmp: TFpDwarfValueConstAddress;
begin
//TODO: ?? if no TypeInfo.TypeInfo;, then return TFpDwarfValueConstAddress.Create(addr); (for mem dump)
Result := nil;
ReleaseRefAndNil(FLastAddrMember);
if (TypeInfo = nil) then begin // TODO dedicanted error code
FLastError := CreateError(fpErrAnyError, ['Can not dereference an untyped pointer']);
exit;
end;
// TODO re-use last member
ti := TypeInfo.TypeInfo;
{$PUSH}{$R-}{$Q-} // TODO: check overflow
if ti <> nil then
AIndex := AIndex * ti.Size;
addr := DataAddress;
if not IsTargetAddr(addr) then begin
FLastError := CreateError(fpErrAnyError, ['Internal dereference error']);
exit;
end;
addr.Address := addr.Address + AIndex;
{$POP}
Tmp := TFpDwarfValueConstAddress.Create(addr);
if ti <> nil then begin
Result := ti.TypeCastValue(Tmp);
Tmp.ReleaseReference;
SetLastMember(TFpDwarfValue(Result));
Result.ReleaseReference;
end
else begin
Result := Tmp;
FLastAddrMember := Result;
end;
end;
destructor TFpDwarfValuePointer.Destroy;
begin
FLastAddrMember.ReleaseReference;
inherited Destroy;
end;
{ TFpDwarfValueEnum }
procedure TFpDwarfValueEnum.InitMemberIndex;
var
v: QWord;
i: Integer;
begin
// TODO: if TypeInfo is a subrange, check against the bounds, then bypass it, and scan all members (avoid subrange scanning members)
if FMemberValueDone then exit;
// FTypeCastTargetType (if not nil) must be same as FOwner. It may have wrappers like declaration.
v := GetAsCardinal;
i := FOwner.MemberCount - 1;
while i >= 0 do begin
if FOwner.Member[i].OrdinalValue = v then break;
dec(i);
end;
FMemberIndex := i;
FMemberValueDone := True;
end;
procedure TFpDwarfValueEnum.Reset;
begin
inherited Reset;
FMemberValueDone := False;
end;
function TFpDwarfValueEnum.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfOrdinal, svfMembers, svfIdentifier];
end;
function TFpDwarfValueEnum.GetAsCardinal: QWord;
begin
if doneUInt in FEvaluated then begin
Result := FValue;
exit;
end;
Include(FEvaluated, doneUInt);
if (FSize <= 0) or (FSize > SizeOf(Result)) then
Result := inherited GetAsCardinal
else
if not MemManager.ReadEnum(OrdOrDataAddr, FSize, Result) then begin
FLastError := MemManager.LastError;
Result := 0; // TODO: error
end;
FValue := Result;
end;
function TFpDwarfValueEnum.GetAsString: AnsiString;
begin
InitMemberIndex;
if FMemberIndex >= 0 then
Result := FOwner.Member[FMemberIndex].Name
else
Result := '';
end;
function TFpDwarfValueEnum.GetMemberCount: Integer;
begin
InitMemberIndex;
if FMemberIndex < 0 then
Result := 0
else
Result := 1;
end;
function TFpDwarfValueEnum.GetMember(AIndex: Int64): TFpDbgValue;
begin
InitMemberIndex;
if (FMemberIndex >= 0) and (AIndex = 0) then
Result := FOwner.Member[FMemberIndex].Value
else
Result := nil;
end;
{ TFpDwarfValueEnumMember }
function TFpDwarfValueEnumMember.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfOrdinal, svfIdentifier];
end;
function TFpDwarfValueEnumMember.GetAsCardinal: QWord;
begin
Result := FOwnerVal.OrdinalValue;
end;
function TFpDwarfValueEnumMember.GetAsString: AnsiString;
begin
Result := FOwnerVal.Name;
end;
function TFpDwarfValueEnumMember.IsValidTypeCast: Boolean;
begin
assert(False, 'TDbgDwarfEnumMemberSymbolValue.IsValidTypeCast can not be returned for typecast');
Result := False;
end;
constructor TFpDwarfValueEnumMember.Create(AOwner: TFpDwarfSymbolValue);
begin
FOwnerVal := AOwner;
inherited Create(nil);
end;
{ TFpDwarfValueConstNumber }
procedure TFpDwarfValueConstNumber.Update(AValue: QWord; ASigned: Boolean);
begin
Signed := ASigned;
Value := AValue;
end;
{ TFpDwarfValueSet }
procedure TFpDwarfValueSet.InitMap;
const
BitCount: array[0..15] of byte = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
i, i2, v, MemIdx, Bit, Cnt: Integer;
t: TFpDbgSymbol;
begin
if (length(FMem) > 0) or (FSize <= 0) then
exit;
t := TypeInfo;
if t = nil then exit;
t := t.TypeInfo;
if t = nil then exit;
if not MemManager.ReadSet(DataAddr, FSize, FMem) then begin
FLastError := MemManager.LastError;
exit; // TODO: error
end;
Cnt := 0;
for i := 0 to FSize - 1 do
Cnt := Cnt + (BitCount[FMem[i] and 15]) + (BitCount[(FMem[i] div 16) and 15]);
FMemberCount := Cnt;
if (Cnt = 0) then exit;
SetLength(FMemberMap, Cnt);
if (t.Kind = skEnum) then begin
i2 := 0;
for i := 0 to t.MemberCount - 1 do
begin
v := t.Member[i].OrdinalValue;
MemIdx := v shr 3;
Bit := 1 shl (v and 7);
if (FMem[MemIdx] and Bit) <> 0 then begin
assert(i2 < Cnt, 'TDbgDwarfSetSymbolValue.InitMap too many members');
if i2 = Cnt then break;
FMemberMap[i2] := i;
inc(i2);
end;
end;
if i2 < Cnt then begin
FMemberCount := i2;
debugln(FPDBG_DWARF_DATA_WARNINGS, ['TDbgDwarfSetSymbolValue.InitMap not enough members']);
end;
end
else begin
i2 := 0;
MemIdx := 0;
Bit := 1;
v := t.OrdLowBound;
for i := v to t.OrdHighBound do
begin
if (FMem[MemIdx] and Bit) <> 0 then begin
assert(i2 < Cnt, 'TDbgDwarfSetSymbolValue.InitMap too many members');
if i2 = Cnt then break;
FMemberMap[i2] := i - v; // offset from low-bound
inc(i2);
end;
if Bit = 128 then begin
Bit := 1;
inc(MemIdx);
end
else
Bit := Bit shl 1;
end;
if i2 < Cnt then begin
FMemberCount := i2;
debugln(FPDBG_DWARF_DATA_WARNINGS, ['TDbgDwarfSetSymbolValue.InitMap not enough members']);
end;
end;
end;
procedure TFpDwarfValueSet.Reset;
begin
inherited Reset;
SetLength(FMem, 0);
end;
function TFpDwarfValueSet.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers];
if FSize <= 8 then
Result := Result + [svfOrdinal];
end;
function TFpDwarfValueSet.GetMemberCount: Integer;
begin
InitMap;
Result := FMemberCount;
end;
function TFpDwarfValueSet.GetMember(AIndex: Int64): TFpDbgValue;
var
t: TFpDbgSymbol;
begin
Result := nil;
InitMap;
t := TypeInfo;
if t = nil then exit;
t := t.TypeInfo;
if t = nil then exit;
assert(t is TFpDwarfSymbolType, 'TDbgDwarfSetSymbolValue.GetMember t');
if t.Kind = skEnum then begin
Result := t.Member[FMemberMap[AIndex]].Value;
end
else begin
if (FNumValue = nil) or (FNumValue.RefCount > 1) then // refcount 1 by FTypedNumValue
FNumValue := TFpDwarfValueConstNumber.Create(FMemberMap[AIndex] + t.OrdLowBound, t.Kind = skInteger)
else
begin
FNumValue.Update(FMemberMap[AIndex] + t.OrdLowBound, t.Kind = skInteger);
FNumValue.AddReference;
end;
if (FTypedNumValue = nil) or (FTypedNumValue.RefCount > 1) then begin
FTypedNumValue.ReleaseReference;
FTypedNumValue := t.TypeCastValue(FNumValue)
end
else
TFpDwarfValue(FTypedNumValue).SetTypeCastInfo(TFpDwarfSymbolType(t), FNumValue); // update
FNumValue.ReleaseReference;
Assert((FTypedNumValue <> nil) and (TFpDwarfValue(FTypedNumValue).IsValidTypeCast), 'TDbgDwarfSetSymbolValue.GetMember FTypedNumValue');
Assert((FNumValue <> nil) and (FNumValue.RefCount > 0), 'TDbgDwarfSetSymbolValue.GetMember FNumValue');
Result := FTypedNumValue;
end;
end;
function TFpDwarfValueSet.GetAsCardinal: QWord;
begin
Result := 0;
if (FSize <= SizeOf(Result)) and (length(FMem) > 0) then
move(FMem[0], Result, FSize);
end;
function TFpDwarfValueSet.IsValidTypeCast: Boolean;
var
f: TFpDbgValueFieldFlags;
begin
Result := HasTypeCastInfo;
If not Result then
exit;
assert(FTypeCastTargetType.Kind = skSet, 'TFpDwarfValueSet.IsValidTypeCast: FTypeCastTargetType.Kind = skSet');
if (FTypeCastSourceValue.TypeInfo = FTypeCastTargetType)
then
exit; // pointer deref
f := FTypeCastSourceValue.FieldFlags;
if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
exit;
if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
(FTypeCastSourceValue.Size = FTypeCastTargetType.Size)
then
exit;
Result := False;
end;
destructor TFpDwarfValueSet.Destroy;
begin
FTypedNumValue.ReleaseReference;
inherited Destroy;
end;
{ TFpDwarfValueStruct }
procedure TFpDwarfValueStruct.Reset;
begin
inherited Reset;
FDataAddressDone := False;
end;
function TFpDwarfValueStruct.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers];
//TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
if Kind in [skClass] then begin
Result := Result + [svfOrdinal, svfDataAddress, svfDataSize]; // svfDataSize
if (FValueSymbol <> nil) and FValueSymbol.HasAddress then
Result := Result + [svfSizeOfPointer];
end
else begin
Result := Result + [svfSize];
end;
end;
function TFpDwarfValueStruct.GetAsCardinal: QWord;
begin
Result := QWord(LocToAddrOrNil(DataAddress));
end;
function TFpDwarfValueStruct.GetDataAddress: TFpDbgMemLocation;
var
t: TFpDbgMemLocation;
begin
if FValueSymbol <> nil then begin
if not FDataAddressDone then begin
FDataAddress := InvalidLoc;
FValueSymbol.GetValueAddress(Self, t);
assert(SizeOf(FDataAddress) >= AddressSize, 'TDbgDwarfStructSymbolValue.GetDataAddress');
if (MemManager <> nil) then begin
FDataAddress := MemManager.ReadAddress(t, AddressSize);
if not IsValidLoc(FDataAddress) then
FLastError := MemManager.LastError;
end;
FDataAddressDone := True;
end;
Result := FDataAddress;
end
else
Result := inherited GetDataAddress;
end;
function TFpDwarfValueStruct.GetDataSize: Integer;
begin
Assert((FValueSymbol = nil) or (FValueSymbol.TypeInfo is TFpDwarfSymbol));
if (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
if FValueSymbol.TypeInfo.Kind = skClass then
Result := TFpDwarfSymbol(FValueSymbol.TypeInfo).DataSize
else
Result := FValueSymbol.TypeInfo.Size
else
Result := -1;
end;
function TFpDwarfValueStruct.GetSize: Integer;
begin
if (Kind <> skClass) and (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
Result := FValueSymbol.TypeInfo.Size
else
Result := -1;
end;
{ TFpDwarfValueStructTypeCast }
procedure TFpDwarfValueStructTypeCast.Reset;
begin
inherited Reset;
FDataAddressDone := False;
end;
function TFpDwarfValueStructTypeCast.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers];
if kind = skClass then // todo detect hidden pointer
Result := Result + [svfDataSize]
else
Result := Result + [svfSize];
//TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
if Kind in [skClass] then
Result := Result + [svfOrdinal, svfDataAddress, svfSizeOfPointer]; // svfDataSize
end;
function TFpDwarfValueStructTypeCast.GetKind: TDbgSymbolKind;
begin
if HasTypeCastInfo then
Result := FTypeCastTargetType.Kind
else
Result := inherited GetKind;
end;
function TFpDwarfValueStructTypeCast.GetAsCardinal: QWord;
begin
Result := QWord(LocToAddrOrNil(DataAddress));
end;
function TFpDwarfValueStructTypeCast.GetSize: Integer;
begin
if (Kind <> skClass) and (FTypeCastTargetType <> nil) then
Result := FTypeCastTargetType.Size
else
Result := -1;
end;
function TFpDwarfValueStructTypeCast.GetDataSize: Integer;
begin
Assert((FTypeCastTargetType = nil) or (FTypeCastTargetType is TFpDwarfSymbol));
if FTypeCastTargetType <> nil then
if FTypeCastTargetType.Kind = skClass then
Result := TFpDwarfSymbol(FTypeCastTargetType).DataSize
else
Result := FTypeCastTargetType.Size
else
Result := -1;
end;
function TFpDwarfValueStructTypeCast.GetDataAddress: TFpDbgMemLocation;
var
fields: TFpDbgValueFieldFlags;
t: TFpDbgMemLocation;
begin
if HasTypeCastInfo then begin
if not FDataAddressDone then begin
// TODO: wrong for records // use GetDwarfDataAddress
fields := FTypeCastSourceValue.FieldFlags;
if svfOrdinal in fields then
FDataAddress := TargetLoc(TDbgPtr(FTypeCastSourceValue.AsCardinal))
else
if svfAddress in fields then begin
FDataAddress := InvalidLoc;
t := FTypeCastSourceValue.Address;
assert(SizeOf(FDataAddress) >= AddressSize, 'TDbgDwarfStructSymbolValue.GetDataAddress');
if (MemManager <> nil) then begin
FDataAddress := MemManager.ReadAddress(t, AddressSize);
if not IsValidLoc(FDataAddress) then
FLastError := MemManager.LastError;
end;
end;
FDataAddressDone := True;
end;
Result := FDataAddress;
end
else
Result := inherited GetDataAddress;
end;
function TFpDwarfValueStructTypeCast.IsValidTypeCast: Boolean;
var
f: TFpDbgValueFieldFlags;
begin
Result := HasTypeCastInfo;
if not Result then
exit;
if FTypeCastTargetType.Kind = skClass then begin
f := FTypeCastSourceValue.FieldFlags;
Result := (svfOrdinal in f); // ordinal is prefered in GetDataAddress
if Result then
exit;
Result := (svfAddress in f) and
( ( not(svfSize in f) ) or // either svfSizeOfPointer or a void type, e.g. pointer(1)^
( (svfSize in f) and (FTypeCastSourceValue.Size = AddressSize) )
);
end
else begin
f := FTypeCastSourceValue.FieldFlags;
if (f * [{svfOrdinal, }svfAddress] = [svfAddress]) then begin
if (f * [svfSize, svfSizeOfPointer]) = [svfSize] then
Result := Result and (FTypeCastTargetType.Size = FTypeCastSourceValue.Size)
else
if (f * [svfSize, svfSizeOfPointer]) = [svfSizeOfPointer] then
Result := Result and (FTypeCastTargetType.Size = AddressSize)
else
Result := (f * [svfSize, svfSizeOfPointer]) = []; // source is a void type, e.g. pointer(1)^
end
else
Result := False;
end;
end;
destructor TFpDwarfValueStructTypeCast.Destroy;
begin
FreeAndNil(FMembers);
inherited Destroy;
end;
function TFpDwarfValueStructTypeCast.GetMemberByName(AIndex: String): TFpDbgValue;
var
tmp: TFpDbgSymbol;
begin
Result := nil;
if not HasTypeCastInfo then
exit;
tmp := FTypeCastTargetType.MemberByName[AIndex];
if (tmp <> nil) then begin
assert((tmp is TFpDwarfSymbolValue), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp));
if FMembers = nil then
FMembers := TFpDbgCircularRefCntObjList.Create;
FMembers.Add(tmp);
Result := tmp.Value;
end;
SetLastMember(TFpDwarfValue(Result));
end;
function TFpDwarfValueStructTypeCast.GetMember(AIndex: Int64): TFpDbgValue;
var
tmp: TFpDbgSymbol;
begin
Result := nil;
if not HasTypeCastInfo then
exit;
// TODO: Why store them all in list? They are hold by the type
tmp := FTypeCastTargetType.Member[AIndex];
if (tmp <> nil) then begin
assert((tmp is TFpDwarfSymbolValue), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp));
if FMembers = nil then
FMembers := TFpDbgCircularRefCntObjList.Create;
FMembers.Add(tmp);
Result := tmp.Value;
end;
SetLastMember(TFpDwarfValue(Result));
end;
function TFpDwarfValueStructTypeCast.GetMemberCount: Integer;
var
ti: TFpDbgSymbol;
begin
Result := 0;
if not HasTypeCastInfo then
exit;
Result := FTypeCastTargetType.MemberCount;
ti := FTypeCastTargetType;
//TODO: cache result
if ti.Kind in [skClass, skObject] then
while ti.TypeInfo <> nil do begin
ti := ti.TypeInfo;
Result := Result + ti.MemberCount;
end;
end;
{ TFpDwarfValueConstAddress }
procedure TFpDwarfValueConstAddress.Update(AnAddress: TFpDbgMemLocation);
begin
Address := AnAddress;
end;
{ TFpDwarfValueArray }
function TFpDwarfValueArray.GetFieldFlags: TFpDbgValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers];
if (TypeInfo <> nil) and (sfDynArray in TypeInfo.Flags) then
Result := Result + [svfOrdinal, svfDataAddress];
end;
function TFpDwarfValueArray.GetKind: TDbgSymbolKind;
begin
Result := skArray;
end;
function TFpDwarfValueArray.GetAsCardinal: QWord;
begin
// TODO cache
if not MemManager.ReadUnsignedInt(OrdOrAddress, AddressSize, Result) then begin
FLastError := MemManager.LastError;
Result := 0;
end;
end;
function TFpDwarfValueArray.GetDataAddress: TFpDbgMemLocation;
begin
Result := OrdOrDataAddr;
end;
function TFpDwarfValueArray.GetMember(AIndex: Int64): TFpDbgValue;
begin
Result := GetMemberEx([AIndex]);
end;
function TFpDwarfValueArray.GetMemberEx(AIndex: array of Int64): TFpDbgValue;
var
Addr: TFpDbgMemLocation;
i: Integer;
begin
Result := nil;
assert((FOwner is TFpDwarfSymbolTypeArray) and (FOwner.Kind = skArray));
Addr := TFpDwarfSymbolTypeArray(FOwner).GetMemberAddress(Self, AIndex);
if not IsReadableLoc(Addr) then exit;
// FAddrObj.RefCount: hold by self
i := 1;
// FAddrObj.RefCount: hold by FLastMember (ignore only, if FLastMember is not hold by others)
if (FLastMember <> nil) and (FLastMember.RefCount = 1) then
i := 2;
if (FAddrObj = nil) or (FAddrObj.RefCount > i) then begin
FAddrObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FAddrObj, 'TDbgDwarfArraySymbolValue'){$ENDIF};
FAddrObj := TFpDwarfValueConstAddress.Create(Addr);
{$IFDEF WITH_REFCOUNT_DEBUG}FAddrObj.DbgRenameReference(@FAddrObj, 'TDbgDwarfArraySymbolValue');{$ENDIF}
end
else begin
FAddrObj.Update(Addr);
end;
if (FLastMember = nil) or (FLastMember.RefCount > 1) then begin
SetLastMember(TFpDwarfValue(FOwner.TypeInfo.TypeCastValue(FAddrObj)));
FLastMember.ReleaseReference;
end
else begin
TFpDwarfValue(FLastMember).SetTypeCastInfo(TFpDwarfSymbolType(FOwner.TypeInfo), FAddrObj);
end;
Result := FLastMember;
end;
function TFpDwarfValueArray.GetMemberCount: Integer;
var
t, t2: TFpDbgSymbol;
Addr: TFpDbgMemLocation;
LowBound, HighBound: int64;
i: Int64;
begin
Result := 0;
t := TypeInfo;
if t.MemberCount < 1 then // IndexTypeCount;
exit;
t2 := t.Member[0]; // IndexType[0];
if not ((t2 is TFpDwarfSymbolType) and (TFpDwarfSymbolType(t2).GetValueBounds(self, LowBound, HighBound))) and
not t2.HasBounds then begin
if (sfDynArray in t.Flags) and (AsCardinal <> 0) and
GetDwarfDataAddress(Addr, TFpDwarfSymbolType(FOwner))
then begin
if not (IsReadableMem(Addr) and (LocToAddr(Addr) > 4)) then
exit;
Addr.Address := Addr.Address - AddressSize;
if MemManager.ReadSignedInt(Addr, 4, i) then begin
Result := Integer(i)+1;
exit;
end
else
FLastError := MemManager.LastError;
end;
exit;
end;
if t2.HasBounds then
Result := Integer(t2.OrdHighBound - t2.OrdLowBound + 1);
end;
function TFpDwarfValueArray.GetMemberCountEx(AIndex: array of Int64): Integer;
var
t: TFpDbgSymbol;
begin
Result := 0;
t := TypeInfo;
if length(AIndex) >= t.MemberCount then
exit;
t := t.Member[length(AIndex)];
if not t.HasBounds then
exit;
Result := t.OrdHighBound - t.OrdLowBound + 1;
end;
function TFpDwarfValueArray.GetIndexType(AIndex: Integer): TFpDbgSymbol;
begin
Result := TypeInfo.Member[AIndex];
end;
function TFpDwarfValueArray.GetIndexTypeCount: Integer;
begin
Result := TypeInfo.MemberCount;
end;
function TFpDwarfValueArray.IsValidTypeCast: Boolean;
var
f: TFpDbgValueFieldFlags;
begin
Result := HasTypeCastInfo;
If not Result then
exit;
assert(FTypeCastTargetType.Kind = skArray, 'TFpDwarfValueArray.IsValidTypeCast: FTypeCastTargetType.Kind = skArray');
//TODO: shortcut, if FTypeCastTargetType = FTypeCastSourceValue.TypeInfo ?
f := FTypeCastSourceValue.FieldFlags;
if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
exit;
if sfDynArray in FTypeCastTargetType.Flags then begin
// dyn array
if (svfOrdinal in f)then
exit;
if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
(FTypeCastSourceValue.Size = FOwner.CompilationUnit.AddressSize)
then
exit;
if (f * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) then
exit;
end
else begin
// stat array
if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
(FTypeCastSourceValue.Size = FTypeCastTargetType.Size)
then
exit;
end;
Result := False;
end;
destructor TFpDwarfValueArray.Destroy;
begin
FAddrObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FAddrObj, 'TDbgDwarfArraySymbolValue'){$ENDIF};
inherited Destroy;
end;
{ TDbgDwarfIdentifier }
function TFpDwarfSymbol.GetNestedTypeInfo: TFpDwarfSymbolType;
begin
// TODO DW_AT_start_scope;
Result := FNestedTypeInfo;
if (Result <> nil) or (didtTypeRead in FDwarfReadFlags) then
exit;
include(FDwarfReadFlags, didtTypeRead);
FNestedTypeInfo := DoGetNestedTypeInfo;
Result := FNestedTypeInfo;
end;
procedure TFpDwarfSymbol.SetParentTypeInfo(AValue: TFpDwarfSymbol);
begin
if FParentTypeInfo = AValue then exit;
if (FParentTypeInfo <> nil) and CircleBackRefsActive then
FParentTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
FParentTypeInfo := AValue;
if (FParentTypeInfo <> nil) and CircleBackRefsActive then
FParentTypeInfo.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
end;
procedure TFpDwarfSymbol.DoReferenceAdded;
begin
inherited DoReferenceAdded;
DoPlainReferenceAdded;
end;
procedure TFpDwarfSymbol.DoReferenceReleased;
begin
inherited DoReferenceReleased;
DoPlainReferenceReleased;
end;
procedure TFpDwarfSymbol.CircleBackRefActiveChanged(ANewActive: Boolean);
begin
if (FParentTypeInfo = nil) then
exit;
if ANewActive then
FParentTypeInfo.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF}
else
FParentTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
end;
function TFpDwarfSymbol.DoGetNestedTypeInfo: TFpDwarfSymbolType;
var
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
InfoEntry: TDwarfInformationEntry;
begin // Do not access anything that may need forwardSymbol
if InformationEntry.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint) then begin
InfoEntry := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
Result := TFpDwarfSymbolType.CreateTypeSubClass('', InfoEntry);
ReleaseRefAndNil(InfoEntry);
end
else
Result := nil;
end;
function TFpDwarfSymbol.ReadMemberVisibility(out
AMemberVisibility: TDbgSymbolMemberVisibility): Boolean;
var
Val: Integer;
begin
Result := InformationEntry.ReadValue(DW_AT_external, Val);
if Result and (Val <> 0) then begin
AMemberVisibility := svPublic;
exit;
end;
Result := InformationEntry.ReadValue(DW_AT_accessibility, Val);
if not Result then exit;
case Val of
DW_ACCESS_private: AMemberVisibility := svPrivate;
DW_ACCESS_protected: AMemberVisibility := svProtected;
DW_ACCESS_public: AMemberVisibility := svPublic;
else AMemberVisibility := svPrivate;
end;
end;
function TFpDwarfSymbol.IsArtificial: Boolean;
begin
if not(didtArtificialRead in FDwarfReadFlags) then begin
if InformationEntry.IsArtificial then
Include(FDwarfReadFlags, didtIsArtifical);
Include(FDwarfReadFlags, didtArtificialRead);
end;
Result := didtIsArtifical in FDwarfReadFlags;
end;
procedure TFpDwarfSymbol.NameNeeded;
var
AName: String;
begin
if InformationEntry.ReadName(AName) then
SetName(AName)
else
inherited NameNeeded;
end;
procedure TFpDwarfSymbol.TypeInfoNeeded;
begin
SetTypeInfo(NestedTypeInfo);
end;
function TFpDwarfSymbol.DataSize: Integer;
var
t: TFpDwarfSymbolType;
begin
t := NestedTypeInfo;
if t <> nil then
Result := t.DataSize
else
Result := 0;
end;
function TFpDwarfSymbol.InitLocationParser(const ALocationParser: TDwarfLocationExpression;
AnInitLocParserData: PInitLocParserData): Boolean;
begin
if (AnInitLocParserData <> nil) and IsValidLoc(AnInitLocParserData^.ObjectDataAddress)
then begin
if AnInitLocParserData^.ObjectDataAddrPush then begin
debugln(FPDBG_DWARF_VERBOSE, ['TFpDwarfSymbol.InitLocationParser Push=', dbgs(AnInitLocParserData^.ObjectDataAddress)]);
ALocationParser.Push(AnInitLocParserData^.ObjectDataAddress, lseValue);
end
else begin
debugln(FPDBG_DWARF_VERBOSE, ['TFpDwarfSymbol.InitLocationParser CurrentObjectAddress=', dbgs(AnInitLocParserData^.ObjectDataAddress)]);
ALocationParser.CurrentObjectAddress := AnInitLocParserData^.ObjectDataAddress;
end;
end;
Result := True;
end;
function TFpDwarfSymbol.LocationFromTag(ATag: Cardinal; AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; AnInitLocParserData: PInitLocParserData;
AnInformationEntry: TDwarfInformationEntry; ASucessOnMissingTag: Boolean): Boolean;
var
Val: TByteDynArray;
LocationParser: TDwarfLocationExpression;
begin
//debugln(['TDbgDwarfIdentifier.LocationFromTag', ClassName, ' ',Name, ' ', DwarfAttributeToString(ATag)]);
Result := False;
if AnInformationEntry = nil then
AnInformationEntry := InformationEntry;
//TODO: avoid copying data
// DW_AT_data_member_location in members [ block or const]
// DW_AT_location [block or reference] todo: const
if not AnInformationEntry.ReadValue(ATag, Val) then begin
Result := ASucessOnMissingTag;
if not Result then
AnAddress := InvalidLoc;
if not Result then
DebugLn(['LocationFromTag: failed to read DW_AT_location / ASucessOnMissingTag=', dbgs(ASucessOnMissingTag)]);
exit;
end;
AnAddress := InvalidLoc;
if Length(Val) = 0 then begin
DebugLn('LocationFromTag: Warning DW_AT_location empty');
//exit;
end;
LocationParser := TDwarfLocationExpression.Create(@Val[0], Length(Val), CompilationUnit,
AValueObj.MemManager, AValueObj.Context);
InitLocationParser(LocationParser, AnInitLocParserData);
LocationParser.Evaluate;
if IsError(LocationParser.LastError) then
SetLastError(LocationParser.LastError);
if LocationParser.ResultKind in [lseValue] then begin
AnAddress := TargetLoc(LocationParser.ResultData);
if ATag=DW_AT_location then
AnAddress.Address :=CompilationUnit.MapAddressToNewValue(AnAddress.Address);
Result := True;
end
else
if LocationParser.ResultKind in [lseRegister] then begin
AnAddress := ConstLoc(LocationParser.ResultData);
Result := True;
end
else
debugln(['TDbgDwarfIdentifier.LocationFromTag FAILED']); // TODO
LocationParser.Free;
end;
function TFpDwarfSymbol.GetDataAddress(AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
ATargetCacheIndex: Integer): Boolean;
var
ti: TFpDwarfSymbolType;
InitLocParserData: TInitLocParserData;
begin
InitLocParserData.ObjectDataAddress := AnAddress;
InitLocParserData.ObjectDataAddrPush := False;
Result := LocationFromTag(DW_AT_data_location, AValueObj, AnAddress, @InitLocParserData, nil, True);
if not Result then
exit;
if ATargetType = Self then begin
Result := True;
exit;
end;
//TODO: Handle AValueObj.DataAddressCache[ATargetCacheIndex];
Result := GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex);
if not Result then
exit;
ti := NestedTypeInfo;
if ti <> nil then
Result := ti.GetDataAddress(AValueObj, AnAddress, ATargetType, ATargetCacheIndex+1)
else
Result := ATargetType = nil; // end of type chain
end;
function TFpDwarfSymbol.GetDataAddressNext(AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
ATargetCacheIndex: Integer): Boolean;
begin
Result := True;
end;
function TFpDwarfSymbol.HasAddress: Boolean;
begin
Result := False;
end;
procedure TFpDwarfSymbol.Init;
begin
//
end;
class function TFpDwarfSymbol.CreateSubClass(AName: String;
AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbol;
var
c: TDbgDwarfSymbolBaseClass;
begin
c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
Result := TFpDwarfSymbol(c.Create(AName, AnInformationEntry));
end;
destructor TFpDwarfSymbol.Destroy;
begin
inherited Destroy;
ReleaseRefAndNil(FNestedTypeInfo);
Assert(not CircleBackRefsActive, 'CircleBackRefsActive can not be is destructor');
// FParentTypeInfo := nil
end;
function TFpDwarfSymbol.StartScope: TDbgPtr;
begin
if not InformationEntry.ReadStartScope(Result) then
Result := 0;
end;
{ TFpDwarfSymbolValue }
function TFpDwarfSymbolValue.GetValueAddress(AValueObj: TFpDwarfValue; out
AnAddress: TFpDbgMemLocation): Boolean;
begin
Result := False;
end;
function TFpDwarfSymbolValue.GetValueDataAddress(AValueObj: TFpDwarfValue; out
AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType): Boolean;
begin
Result := TypeInfo <> nil;
if not Result then
exit;
Assert((TypeInfo is TFpDwarfSymbol) and (TypeInfo.SymbolType = stType), 'TFpDwarfSymbolValue.GetDataAddress');
Result := GetValueAddress(AValueObj, AnAddress);
Result := Result and IsReadableLoc(AnAddress);
if Result then begin
Result := TFpDwarfSymbolType(TypeInfo).GetDataAddress(AValueObj, AnAddress, ATargetType, 1);
if not Result then SetLastError(TypeInfo.LastError);
end;
end;
procedure TFpDwarfSymbolValue.KindNeeded;
var
t: TFpDbgSymbol;
begin
t := TypeInfo;
if t = nil then
inherited KindNeeded
else
SetKind(t.Kind);
end;
procedure TFpDwarfSymbolValue.MemberVisibilityNeeded;
var
Val: TDbgSymbolMemberVisibility;
begin
if ReadMemberVisibility(Val) then
SetMemberVisibility(Val)
else
if TypeInfo <> nil then
SetMemberVisibility(TypeInfo.MemberVisibility)
else
inherited MemberVisibilityNeeded;
end;
function TFpDwarfSymbolValue.GetMember(AIndex: Int64): TFpDbgSymbol;
var
ti: TFpDbgSymbol;
k: TDbgSymbolKind;
begin
ti := TypeInfo;
if ti = nil then begin
Result := inherited GetMember(AIndex);
exit;
end;
k := ti.Kind;
// while holding result, until refcount added, do not call any function
Result := ti.Member[AIndex];
assert((Result = nil) or (Result is TFpDwarfSymbolValue), 'TFpDwarfSymbolValue.GetMember is Value');
if (k in [skClass, skObject, skRecord {, skArray}]) and
(Result <> nil) and (Result is TFpDwarfSymbolValue)
then begin
if FMembers = nil then
FMembers := TFpDbgCircularRefCntObjList.Create;
FMembers.Add(Result); //TODO: last member only?
end;
end;
function TFpDwarfSymbolValue.GetMemberByName(AIndex: String): TFpDbgSymbol;
var
ti: TFpDbgSymbol;
k: TDbgSymbolKind;
begin
ti := TypeInfo;
if ti = nil then begin
Result := inherited GetMemberByName(AIndex);
exit;
end;
k := ti.Kind;
// while holding result, until refcount added, do not call any function
Result := ti.MemberByName[AIndex];
assert((Result = nil) or (Result is TFpDwarfSymbolValue), 'TFpDwarfSymbolValue.GetMember is Value');
if (k in [skClass, skObject, skRecord {, skArray}]) and
(Result <> nil) and (Result is TFpDwarfSymbolValue)
then begin
if FMembers = nil then
FMembers := TFpDbgCircularRefCntObjList.Create;
FMembers.Add(Result);
end;
end;
function TFpDwarfSymbolValue.GetMemberCount: Integer;
var
ti: TFpDbgSymbol;
begin
ti := TypeInfo;
if ti <> nil then begin
Result := ti.MemberCount;
//TODO: cache result
if ti.Kind in [skClass, skObject] then
while ti.TypeInfo <> nil do begin
ti := ti.TypeInfo;
Result := Result + ti.MemberCount;
end;
end
else
Result := inherited GetMemberCount;
end;
procedure TFpDwarfSymbolValue.Init;
begin
inherited Init;
SetSymbolType(stValue);
end;
destructor TFpDwarfSymbolValue.Destroy;
begin
Assert(not CircleBackRefsActive, 'CircleBackRefsActive can not be is ddestructor');
FreeAndNil(FMembers);
if FValueObject <> nil then begin
FValueObject.SetValueSymbol(nil);
FValueObject.ReleaseCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueObject, ClassName+'.FValueObject'){$ENDIF};
FValueObject := nil;
end;
ParentTypeInfo := nil;
inherited Destroy;
end;
class function TFpDwarfSymbolValue.CreateValueSubClass(AName: String;
AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolValue;
var
c: TDbgDwarfSymbolBaseClass;
begin
c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
if c.InheritsFrom(TFpDwarfSymbolValue) then
Result := TFpDwarfSymbolValueClass(c).Create(AName, AnInformationEntry)
else
Result := nil;
end;
{ TFpDwarfSymbolValueWithLocation }
function TFpDwarfSymbolValueWithLocation.InitLocationParser(const ALocationParser: TDwarfLocationExpression;
AnInitLocParserData: PInitLocParserData): Boolean;
begin
Result := inherited InitLocationParser(ALocationParser, AnInitLocParserData);
ALocationParser.OnFrameBaseNeeded := @FrameBaseNeeded;
end;
procedure TFpDwarfSymbolValueWithLocation.FrameBaseNeeded(ASender: TObject);
var
p: TFpDwarfSymbol;
fb: TDBGPtr;
begin
debugln(FPDBG_DWARF_SEARCH, ['TFpDwarfSymbolValueVariable.FrameBaseNeeded ']);
p := ParentTypeInfo;
// TODO: what if parent is declaration?
if (p <> nil) and (p is TFpDwarfSymbolValueProc) then begin
fb := TFpDwarfSymbolValueProc(p).GetFrameBase(ASender as TDwarfLocationExpression);
(ASender as TDwarfLocationExpression).FrameBase := fb;
if fb = 0 then begin
debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueWithLocation.FrameBaseNeeded result is 0']);
end;
exit;
end;
{$warning TODO}
//else
//if OwnerTypeInfo <> nil then
// OwnerTypeInfo.fr;
// TODO: check owner
debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueWithLocation.FrameBaseNeeded no parent type info']);
(ASender as TDwarfLocationExpression).FrameBase := 0;
end;
function TFpDwarfSymbolValueWithLocation.GetValueObject: TFpDbgValue;
var
ti: TFpDbgSymbol;
begin
Result := FValueObject;
if Result <> nil then exit;
ti := TypeInfo;
if (ti = nil) or not (ti.SymbolType = stType) then exit;
FValueObject := TFpDwarfSymbolType(ti).GetTypedValueObject(False);
if FValueObject <> nil then begin
{$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
FValueObject.MakePlainRefToCirclular;
FValueObject.SetValueSymbol(self);
end;
Result := FValueObject;
end;
{ TFpDwarfSymbolType }
procedure TFpDwarfSymbolType.Init;
begin
inherited Init;
SetSymbolType(stType);
end;
procedure TFpDwarfSymbolType.MemberVisibilityNeeded;
var
Val: TDbgSymbolMemberVisibility;
begin
if ReadMemberVisibility(Val) then
SetMemberVisibility(Val)
else
inherited MemberVisibilityNeeded;
end;
procedure TFpDwarfSymbolType.SizeNeeded;
var
ByteSize: Integer;
begin
if InformationEntry.ReadValue(DW_AT_byte_size, ByteSize) then
SetSize(ByteSize)
else
inherited SizeNeeded;
end;
function TFpDwarfSymbolType.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
Result := nil;
end;
function TFpDwarfSymbolType.GetValueBounds(AValueObj: TFpDwarfValue; out ALowBound,
AHighBound: Int64): Boolean;
begin
Result := HasBounds;
ALowBound := OrdLowBound;
AHighBound := OrdHighBound;
end;
class function TFpDwarfSymbolType.CreateTypeSubClass(AName: String;
AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolType;
var
c: TDbgDwarfSymbolBaseClass;
begin
c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
if c.InheritsFrom(TFpDwarfSymbolType) then
Result := TFpDwarfSymbolTypeClass(c).Create(AName, AnInformationEntry)
else
Result := nil;
end;
function TFpDwarfSymbolType.TypeCastValue(AValue: TFpDbgValue): TFpDbgValue;
begin
Result := GetTypedValueObject(True);
If Result = nil then
exit;
assert(Result is TFpDwarfValue);
if not TFpDwarfValue(Result).SetTypeCastInfo(self, AValue) then
ReleaseRefAndNil(Result);
end;
{ TDbgDwarfBaseTypeIdentifier }
procedure TFpDwarfSymbolTypeBasic.KindNeeded;
var
Encoding, ByteSize: Integer;
begin
if not InformationEntry.ReadValue(DW_AT_encoding, Encoding) then begin
DebugLn(FPDBG_DWARF_WARNINGS, ['TFpDwarfSymbolTypeBasic.KindNeeded: Failed reading encoding for ', DwarfTagToString(InformationEntry.AbbrevTag)]);
inherited KindNeeded;
exit;
end;
if InformationEntry.ReadValue(DW_AT_byte_size, ByteSize) then
SetSize(ByteSize);
case Encoding of
DW_ATE_address : SetKind(skPointer);
DW_ATE_boolean: SetKind(skBoolean);
//DW_ATE_complex_float:
DW_ATE_float: SetKind(skFloat);
DW_ATE_signed: SetKind(skInteger);
DW_ATE_signed_char: SetKind(skChar);
DW_ATE_unsigned: SetKind(skCardinal);
DW_ATE_unsigned_char: SetKind(skChar);
else
begin
DebugLn(FPDBG_DWARF_WARNINGS, ['TFpDwarfSymbolTypeBasic.KindNeeded: Unknown encoding ', DwarfBaseTypeEncodingToString(Encoding), ' for ', DwarfTagToString(InformationEntry.AbbrevTag)]);
inherited KindNeeded;
end;
end;
end;
procedure TFpDwarfSymbolTypeBasic.TypeInfoNeeded;
begin
SetTypeInfo(nil);
end;
function TFpDwarfSymbolTypeBasic.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
case Kind of
skPointer: Result := TFpDwarfValuePointer.Create(Self, Size);
skInteger: Result := TFpDwarfValueInteger.Create(Self, Size);
skCardinal: Result := TFpDwarfValueCardinal.Create(Self, Size);
skBoolean: Result := TFpDwarfValueBoolean.Create(Self, Size);
skChar: Result := TFpDwarfValueChar.Create(Self, Size);
skFloat: Result := TFpDwarfValueFloat.Create(Self, Size);
end;
end;
function TFpDwarfSymbolTypeBasic.GetHasBounds: Boolean;
begin
Result := (kind = skInteger) or (kind = skCardinal);
end;
function TFpDwarfSymbolTypeBasic.GetOrdHighBound: Int64;
begin
case Kind of
skInteger: Result := int64( high(int64) shr (64 - Min(Size, 8) * 8));
skCardinal: Result := int64( high(qword) shr (64 - Min(Size, 8) * 8));
else
Result := inherited GetOrdHighBound;
end;
end;
function TFpDwarfSymbolTypeBasic.GetOrdLowBound: Int64;
begin
case Kind of
skInteger: Result := -(int64( high(int64) shr (64 - Min(Size, 8) * 8)))-1;
skCardinal: Result := 0;
else
Result := inherited GetOrdHighBound;
end;
end;
{ TFpDwarfSymbolTypeModifier }
procedure TFpDwarfSymbolTypeModifier.TypeInfoNeeded;
var
p: TFpDwarfSymbolType;
begin
p := NestedTypeInfo;
if p <> nil then
SetTypeInfo(p.TypeInfo)
else
SetTypeInfo(nil);
end;
procedure TFpDwarfSymbolTypeModifier.ForwardToSymbolNeeded;
begin
SetForwardToSymbol(NestedTypeInfo)
end;
function TFpDwarfSymbolTypeModifier.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
var
ti: TFpDwarfSymbolType;
begin
ti := NestedTypeInfo;
if ti <> nil then
Result := ti.GetTypedValueObject(ATypeCast)
else
Result := inherited;
end;
{ TFpDwarfSymbolTypeRef }
function TFpDwarfSymbolTypeRef.GetFlags: TDbgSymbolFlags;
begin
Result := (inherited GetFlags) + [sfInternalRef];
end;
function TFpDwarfSymbolTypeRef.GetDataAddressNext(AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
ATargetCacheIndex: Integer): Boolean;
var
t: TFpDbgMemLocation;
begin
t := AValueObj.DataAddressCache[ATargetCacheIndex];
if IsInitializedLoc(t) then begin
AnAddress := t;
end
else begin
Result := AValueObj.MemManager <> nil;
if not Result then
exit;
AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize);
AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
end;
Result := IsValidLoc(AnAddress);
if Result then
Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex)
else
if IsError(AValueObj.MemManager.LastError) then
SetLastError(AValueObj.MemManager.LastError);
// Todo: other error
end;
{ TFpDwarfSymbolTypeDeclaration }
function TFpDwarfSymbolTypeDeclaration.DoGetNestedTypeInfo: TFpDwarfSymbolType;
var
ti: TFpDwarfSymbolType;
ti2: TFpDbgSymbol;
begin
Result := inherited DoGetNestedTypeInfo;
// Is internal class pointer?
// Do not trigged any cached property of the pointer
if (Result = nil) then
exit;
ti := Result;
if (ti is TFpDwarfSymbolTypeModifier) then begin
ti := TFpDwarfSymbolType(ti.TypeInfo);
if (Result = nil) then
exit;
end;
if not (ti is TFpDwarfSymbolTypePointer) then
exit;
ti2 := ti.NestedTypeInfo;
// only if it is NOT a declaration
if (ti2 <> nil) and (ti2 is TFpDwarfSymbolTypeStructure) then begin
TFpDwarfSymbolTypePointer(ti).IsInternalPointer := True;
// TODO: Flag the structure as class (save teme in KindNeeded)
end;
end;
{ TFpDwarfSymbolTypeSubRange }
procedure TFpDwarfSymbolTypeSubRange.InitEnumIdx;
var
t: TFpDwarfSymbolType;
i: Integer;
h, l: Int64;
begin
if FEnumIdxValid then
exit;
FEnumIdxValid := True;
t := NestedTypeInfo;
i := t.MemberCount - 1;
h := OrdHighBound;
l := OrdLowBound;
while (i >= 0) and (t.Member[i].OrdinalValue > h) do
dec(i);
FHighEnumIdx := i;
while (i >= 0) and (t.Member[i].OrdinalValue >= l) do
dec(i);
FLowEnumIdx := i + 1;
end;
procedure TFpDwarfSymbolTypeSubRange.ReadBounds(AValueObj: TFpDwarfValue);
var
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
NewInfo: TDwarfInformationEntry;
var
AnAddress: TFpDbgMemLocation;
InitLocParserData: TInitLocParserData;
begin
if FLowBoundState <> rfNotRead then exit;
// Todo: search attrib-IDX only once
if InformationEntry.ReadReference(DW_AT_lower_bound, FwdInfoPtr, FwdCompUint) then begin
NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
FLowBoundValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
NewInfo.ReleaseReference;
if FLowBoundValue = nil then begin
FLowBoundState := rfNotFound;
exit;
end
else
FLowBoundState := rfValue;
end
else
if InformationEntry.ReadValue(DW_AT_lower_bound, FLowBoundConst) then begin
FLowBoundState := rfConst;
end
else
begin
//FLowBoundConst := 0; // the default
//FLowBoundState := rfConst;
FLowBoundState := rfNotFound;
exit; // incomplete type
end;
if InformationEntry.ReadReference(DW_AT_upper_bound, FwdInfoPtr, FwdCompUint) then begin
NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
FHighBoundValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
NewInfo.ReleaseReference;
if FHighBoundValue = nil then begin
FHighBoundState := rfNotFound;
exit;
end
else
FHighBoundState := rfValue;
end
else
if InformationEntry.ReadValue(DW_AT_upper_bound, FHighBoundConst) then begin
FHighBoundState := rfConst;
end
else
begin
if assigned(AValueObj) then
InitLocParserData.ObjectDataAddress := AValueObj.Address;
InitLocParserData.ObjectDataAddrPush := False;
if assigned(AValueObj) and LocationFromTag(DW_AT_upper_bound, AValueObj, AnAddress, @InitLocParserData, InformationEntry, True) then begin
FHighBoundState := rfConst;
FHighBoundConst := Int64(AnAddress.Address);
end
else
begin
FHighBoundState := rfNotFound;
if InformationEntry.ReadReference(DW_AT_count, FwdInfoPtr, FwdCompUint) then begin
NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
FCountValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
NewInfo.ReleaseReference;
if FCountValue = nil then begin
FCountState := rfNotFound;
exit;
end
else
FCountState := rfValue;
end
else
if InformationEntry.ReadValue(DW_AT_count, FCountConst) then begin
FCountState := rfConst;
end
else
FCountState := rfNotFound;
end;
end;
end;
function TFpDwarfSymbolTypeSubRange.DoGetNestedTypeInfo: TFpDwarfSymbolType;
begin
Result := inherited DoGetNestedTypeInfo;
if Result <> nil then
exit;
if FLowBoundState = rfValue then
Result := FLowBoundValue.TypeInfo as TFpDwarfSymbolType
else
if FHighBoundState = rfValue then
Result := FHighBoundValue.TypeInfo as TFpDwarfSymbolType
else
if FCountState = rfValue then
Result := FCountValue.TypeInfo as TFpDwarfSymbolType;
end;
function TFpDwarfSymbolTypeSubRange.GetHasBounds: Boolean;
begin
ReadBounds(nil);
// TODO: currently limited to const.
// not standard, but upper may be missing?
Result := (FLowBoundState in [rfConst]) and
( (FHighBoundState in [rfConst]) or
(FCountState in [rfConst]) );
(*
Result := (FLowBoundState in [rfValue, rfConst]) and
( (FHighBoundState in [rfValue, rfConst]) or
(FCountState in [rfValue, rfConst]) );
*)
end;
function TFpDwarfSymbolTypeSubRange.GetOrdHighBound: Int64;
begin
// Todo range check off.
//if FHighBoundState = rfValue then
// Result := FHighBoundValue.VALUE // TODO
//else
if FHighBoundState = rfConst then
Result := FHighBoundConst
else
//if FCountState = rfValue then
// Result := GetOrdLowBound + FCountValue.VALUE - 1 // TODO
//else
if FHighBoundState = rfConst then
Result := GetOrdLowBound + FCountConst - 1;
end;
function TFpDwarfSymbolTypeSubRange.GetOrdLowBound: Int64;
begin
//if FLowBoundState = rfValue then
// Result := FLowBoundValue.VALUE // TODO
//else
Result := FLowBoundConst;
end;
procedure TFpDwarfSymbolTypeSubRange.NameNeeded;
var
AName: String;
begin
if InformationEntry.ReadName(AName) then
SetName(AName)
else
SetName('');
end;
procedure TFpDwarfSymbolTypeSubRange.KindNeeded;
var
t: TFpDbgSymbol;
begin
// TODO: limit to ordinal types
if not HasBounds then begin // does ReadBounds;
SetKind(skNone); // incomplete type
end;
t := NestedTypeInfo;
if t = nil then begin
SetKind(skInteger);
SetSize(CompilationUnit.AddressSize);
end
else
SetKind(t.Kind);
end;
procedure TFpDwarfSymbolTypeSubRange.SizeNeeded;
var
t: TFpDbgSymbol;
begin
t := NestedTypeInfo;
if t = nil then begin
SetKind(skInteger);
SetSize(CompilationUnit.AddressSize);
end
else
SetSize(t.Size);
end;
function TFpDwarfSymbolTypeSubRange.GetMember(AIndex: Int64): TFpDbgSymbol;
begin
if Kind = skEnum then begin
if not FEnumIdxValid then
InitEnumIdx;
Result := NestedTypeInfo.Member[AIndex - FLowEnumIdx];
end
else
Result := inherited GetMember(AIndex);
end;
function TFpDwarfSymbolTypeSubRange.GetMemberCount: Integer;
begin
if Kind = skEnum then begin
if not FEnumIdxValid then
InitEnumIdx;
Result := FHighEnumIdx - FLowEnumIdx + 1;
end
else
Result := inherited GetMemberCount;
end;
function TFpDwarfSymbolTypeSubRange.GetFlags: TDbgSymbolFlags;
begin
Result := (inherited GetFlags) + [sfSubRange];
end;
function TFpDwarfSymbolTypeSubRange.GetValueBounds(AValueObj: TFpDwarfValue; out
ALowBound, AHighBound: Int64): Boolean;
begin
ReadBounds(AValueObj);
Result := inherited GetValueBounds(AValueObj, ALowBound, AHighBound);
end;
procedure TFpDwarfSymbolTypeSubRange.Init;
begin
FLowBoundState := rfNotRead;
FHighBoundState := rfNotRead;
FCountState := rfNotRead;
inherited Init;
end;
{ TFpDwarfSymbolTypePointer }
function TFpDwarfSymbolTypePointer.IsInternalDynArrayPointer: Boolean;
var
ti: TFpDbgSymbol;
begin
Result := False;
ti := NestedTypeInfo; // Same as TypeInfo, but does not try to be forwarded
Result := (ti <> nil) and (ti is TFpDwarfSymbolTypeArray);
if Result then
Result := (sfDynArray in ti.Flags);
end;
procedure TFpDwarfSymbolTypePointer.TypeInfoNeeded;
var
p: TFpDwarfSymbolType;
begin
p := NestedTypeInfo;
if IsInternalPointer and (p <> nil) then begin
SetTypeInfo(p.TypeInfo);
exit;
end;
SetTypeInfo(p);
end;
function TFpDwarfSymbolTypePointer.GetIsInternalPointer: Boolean;
begin
Result := FIsInternalPointer or IsInternalDynArrayPointer;
end;
procedure TFpDwarfSymbolTypePointer.KindNeeded;
var
k: TDbgSymbolKind;
begin
if IsInternalPointer then begin
k := NestedTypeInfo.Kind;
if k = skObject then
SetKind(skClass)
else
SetKind(k);
end
else
SetKind(skPointer);
end;
procedure TFpDwarfSymbolTypePointer.SizeNeeded;
begin
SetSize(CompilationUnit.AddressSize);
end;
procedure TFpDwarfSymbolTypePointer.ForwardToSymbolNeeded;
begin
if IsInternalPointer then
SetForwardToSymbol(NestedTypeInfo) // Same as TypeInfo, but does not try to be forwarded
else
SetForwardToSymbol(nil); // inherited ForwardToSymbolNeeded;
end;
function TFpDwarfSymbolTypePointer.GetDataAddressNext(AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
ATargetCacheIndex: Integer): Boolean;
var
t: TFpDbgMemLocation;
begin
t := AValueObj.DataAddressCache[ATargetCacheIndex];
if IsInitializedLoc(t) then begin
AnAddress := t;
end
else begin
Result := AValueObj.MemManager <> nil;
if not Result then
exit;
AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize);
AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
end;
Result := IsValidLoc(AnAddress);
if Result then
Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex)
else
if IsError(AValueObj.MemManager.LastError) then
SetLastError(AValueObj.MemManager.LastError);
// Todo: other error
end;
function TFpDwarfSymbolTypePointer.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
if IsInternalPointer then
Result := NestedTypeInfo.GetTypedValueObject(ATypeCast)
else
Result := TFpDwarfValuePointer.Create(Self, CompilationUnit.AddressSize);
end;
function TFpDwarfSymbolTypePointer.DataSize: Integer;
begin
if Kind = skClass then
Result := NestedTypeInfo.Size
else
Result := inherited DataSize;
end;
{ TDbgDwarfIdentifierEnumElement }
procedure TFpDwarfSymbolValueEnumMember.ReadOrdinalValue;
begin
if FOrdinalValueRead then exit;
FOrdinalValueRead := True;
FHasOrdinalValue := InformationEntry.ReadValue(DW_AT_const_value, FOrdinalValue);
end;
procedure TFpDwarfSymbolValueEnumMember.KindNeeded;
begin
SetKind(skEnumValue);
end;
function TFpDwarfSymbolValueEnumMember.GetHasOrdinalValue: Boolean;
begin
ReadOrdinalValue;
Result := FHasOrdinalValue;
end;
function TFpDwarfSymbolValueEnumMember.GetOrdinalValue: Int64;
begin
ReadOrdinalValue;
Result := FOrdinalValue;
end;
procedure TFpDwarfSymbolValueEnumMember.Init;
begin
FOrdinalValueRead := False;
inherited Init;
end;
function TFpDwarfSymbolValueEnumMember.GetValueObject: TFpDbgValue;
begin
Result := FValueObject;
if Result <> nil then exit;
FValueObject := TFpDwarfValueEnumMember.Create(Self);
{$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
FValueObject.MakePlainRefToCirclular;
FValueObject.SetValueSymbol(self);
Result := FValueObject;
end;
{ TFpDwarfSymbolTypeEnum }
procedure TFpDwarfSymbolTypeEnum.CreateMembers;
var
Info, Info2: TDwarfInformationEntry;
sym: TFpDwarfSymbol;
begin
if FMembers <> nil then
exit;
FMembers := TFpDbgCircularRefCntObjList.Create;
Info := InformationEntry.FirstChild;
if Info = nil then exit;
while Info.HasValidScope do begin
if (Info.AbbrevTag = DW_TAG_enumerator) then begin
Info2 := Info.Clone;
sym := TFpDwarfSymbol.CreateSubClass('', Info2);
FMembers.Add(sym);
sym.ReleaseReference;
sym.ParentTypeInfo := self;
Info2.ReleaseReference;
end;
Info.GoNext;
end;
Info.ReleaseReference;
end;
function TFpDwarfSymbolTypeEnum.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
Result := TFpDwarfValueEnum.Create(Self, Size);
end;
procedure TFpDwarfSymbolTypeEnum.KindNeeded;
begin
SetKind(skEnum);
end;
function TFpDwarfSymbolTypeEnum.GetMember(AIndex: Int64): TFpDbgSymbol;
begin
CreateMembers;
Result := TFpDbgSymbol(FMembers[AIndex]);
end;
function TFpDwarfSymbolTypeEnum.GetMemberByName(AIndex: String): TFpDbgSymbol;
var
i: Integer;
s, s1, s2: String;
begin
if AIndex = '' then
s1 := UTF8UpperCase(AIndex);
s2 := UTF8LowerCase(AIndex);
CreateMembers;
i := FMembers.Count - 1;
while i >= 0 do begin
Result := TFpDbgSymbol(FMembers[i]);
s := Result.Name;
if (s <> '') and CompareUtf8BothCase(@s1[1], @s2[1], @s[1]) then
exit;
dec(i);
end;
Result := nil;
end;
function TFpDwarfSymbolTypeEnum.GetMemberCount: Integer;
begin
CreateMembers;
Result := FMembers.Count;
end;
function TFpDwarfSymbolTypeEnum.GetHasBounds: Boolean;
begin
Result := True;
end;
function TFpDwarfSymbolTypeEnum.GetOrdHighBound: Int64;
var
c: Integer;
begin
c := MemberCount;
if c > 0 then
Result := Member[c-1].OrdinalValue
else
Result := -1;
end;
function TFpDwarfSymbolTypeEnum.GetOrdLowBound: Int64;
var
c: Integer;
begin
c := MemberCount;
if c > 0 then
Result := Member[0].OrdinalValue
else
Result := 0;
end;
destructor TFpDwarfSymbolTypeEnum.Destroy;
var
i: Integer;
begin
if FMembers <> nil then
for i := 0 to FMembers.Count - 1 do
TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
FreeAndNil(FMembers);
inherited Destroy;
end;
{ TFpDwarfSymbolTypeSet }
procedure TFpDwarfSymbolTypeSet.KindNeeded;
begin
SetKind(skSet);
end;
function TFpDwarfSymbolTypeSet.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
Result := TFpDwarfValueSet.Create(Self, Size);
end;
function TFpDwarfSymbolTypeSet.GetMemberCount: Integer;
begin
if TypeInfo.Kind = skEnum then
Result := TypeInfo.MemberCount
else
Result := inherited GetMemberCount;
end;
function TFpDwarfSymbolTypeSet.GetMember(AIndex: Int64): TFpDbgSymbol;
begin
if TypeInfo.Kind = skEnum then
Result := TypeInfo.Member[AIndex]
else
Result := inherited GetMember(AIndex);
end;
{ TFpDwarfSymbolValueMember }
function TFpDwarfSymbolValueMember.GetValueAddress(AValueObj: TFpDwarfValue; out
AnAddress: TFpDbgMemLocation): Boolean;
var
BaseAddr: TFpDbgMemLocation;
InitLocParserData: TInitLocParserData;
begin
AnAddress := AValueObj.DataAddressCache[0];
Result := IsValidLoc(AnAddress);
if IsInitializedLoc(AnAddress) then
exit;
if AValueObj = nil then debugln(['TFpDwarfSymbolValueMember.InitLocationParser: NO VAl Obj !!!!!!!!!!!!!!!'])
else if AValueObj.StructureValue = nil then debugln(['TFpDwarfSymbolValueMember.InitLocationParser: NO STRUCT Obj !!!!!!!!!!!!!!!']);
if (AValueObj = nil) or (AValueObj.StructureValue = nil) or (ParentTypeInfo = nil)
then begin
debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueMember.InitLocationParser Error: ',ErrorCode(LastError),' ValueObject=', DbgSName(FValueObject)]);
Result := False;
if not IsError(LastError) then
SetLastError(CreateError(fpErrLocationParserInit)); // TODO: error message?
exit;
end;
Assert((ParentTypeInfo is TFpDwarfSymbol) and (ParentTypeInfo.SymbolType = stType), '');
if not AValueObj.GetStructureDwarfDataAddress(BaseAddr, TFpDwarfSymbolType(ParentTypeInfo)) then begin
debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueMember.InitLocationParser Error: ',ErrorCode(LastError),' ValueObject=', DbgSName(FValueObject)]);
Result := False;
if not IsError(LastError) then
SetLastError(CreateError(fpErrLocationParserInit)); // TODO: error message?
exit;
end;
//TODO: AValueObj.StructureValue.LastError
InitLocParserData.ObjectDataAddress := BaseAddr;
InitLocParserData.ObjectDataAddrPush := True;
Result := LocationFromTag(DW_AT_data_member_location, AValueObj, AnAddress, @InitLocParserData);
AValueObj.DataAddressCache[0] := AnAddress;
end;
function TFpDwarfSymbolValueMember.HasAddress: Boolean;
begin
Result := (InformationEntry.HasAttrib(DW_AT_data_member_location));
end;
{ TFpDwarfSymbolTypeStructure }
function TFpDwarfSymbolTypeStructure.GetMemberByName(AIndex: String): TFpDbgSymbol;
var
Ident: TDwarfInformationEntry;
ti: TFpDbgSymbol;
begin
// Todo, maybe create all children?
if FLastChildByName <> nil then begin
FLastChildByName.ReleaseCirclularReference;
FLastChildByName := nil;
end;
Result := nil;
Ident := InformationEntry.FindNamedChild(AIndex);
if Ident <> nil then begin
FLastChildByName := TFpDwarfSymbol.CreateSubClass('', Ident);
FLastChildByName.MakePlainRefToCirclular;
FLastChildByName.ParentTypeInfo := self;
//assert is member ?
ReleaseRefAndNil(Ident);
Result := FLastChildByName;
exit;
end;
ti := TypeInfo; // Parent
if ti <> nil then
Result := ti.MemberByName[AIndex];
end;
function TFpDwarfSymbolTypeStructure.GetMemberCount: Integer;
begin
CreateMembers;
Result := FMembers.Count;
end;
function TFpDwarfSymbolTypeStructure.GetDataAddressNext(AValueObj: TFpDwarfValue;
var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
ATargetCacheIndex: Integer): Boolean;
var
t: TFpDbgMemLocation;
InitLocParserData: TInitLocParserData;
begin
t := AValueObj.DataAddressCache[ATargetCacheIndex];
if IsInitializedLoc(t) then begin
AnAddress := t;
Result := IsValidLoc(AnAddress);
end
else begin
InitInheritanceInfo;
//TODO: may be a constant // offset
InitLocParserData.ObjectDataAddress := AnAddress;
InitLocParserData.ObjectDataAddrPush := True;
Result := LocationFromTag(DW_AT_data_member_location, AValueObj, t, @InitLocParserData, FInheritanceInfo);
if not Result then
exit;
AnAddress := t;
AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
if IsError(AValueObj.MemManager.LastError) then
SetLastError(AValueObj.MemManager.LastError);
end;
Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex);
end;
function TFpDwarfSymbolTypeStructure.GetMember(AIndex: Int64): TFpDbgSymbol;
var
ti: TFpDbgSymbol;
begin
CreateMembers;
if AIndex >= FMembers.Count then begin
ti := TypeInfo;
if ti <> nil then
Result := ti.Member[AIndex - FMembers.Count];
end
else
Result := TFpDbgSymbol(FMembers[AIndex]);
end;
destructor TFpDwarfSymbolTypeStructure.Destroy;
var
i: Integer;
begin
ReleaseRefAndNil(FInheritanceInfo);
if FMembers <> nil then begin
for i := 0 to FMembers.Count - 1 do
TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
FreeAndNil(FMembers);
end;
if FLastChildByName <> nil then begin
FLastChildByName.ParentTypeInfo := nil;
FLastChildByName.ReleaseCirclularReference;
FLastChildByName := nil;
end;
inherited Destroy;
end;
procedure TFpDwarfSymbolTypeStructure.CreateMembers;
var
Info: TDwarfInformationEntry;
Info2: TDwarfInformationEntry;
sym: TFpDwarfSymbol;
begin
if FMembers <> nil then
exit;
FMembers := TFpDbgCircularRefCntObjList.Create;
Info := InformationEntry.Clone;
Info.GoChild;
while Info.HasValidScope do begin
if (Info.AbbrevTag = DW_TAG_member) or (Info.AbbrevTag = DW_TAG_subprogram) then begin
Info2 := Info.Clone;
sym := TFpDwarfSymbol.CreateSubClass('', Info2);
FMembers.Add(sym);
sym.ReleaseReference;
sym.ParentTypeInfo := self;
Info2.ReleaseReference;
end;
Info.GoNext;
end;
Info.ReleaseReference;
end;
procedure TFpDwarfSymbolTypeStructure.InitInheritanceInfo;
begin
if FInheritanceInfo = nil then
FInheritanceInfo := InformationEntry.FindChildByTag(DW_TAG_inheritance);
end;
function TFpDwarfSymbolTypeStructure.DoGetNestedTypeInfo: TFpDwarfSymbolType;
var
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
ParentInfo: TDwarfInformationEntry;
begin
Result:= nil;
InitInheritanceInfo;
if (FInheritanceInfo <> nil) and
FInheritanceInfo.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint)
then begin
ParentInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
//DebugLn(FPDBG_DWARF_SEARCH, ['Inherited from ', dbgs(ParentInfo.FInformationEntry, FwdCompUint) ]);
Result := TFpDwarfSymbolType.CreateTypeSubClass('', ParentInfo);
ParentInfo.ReleaseReference;
end;
end;
procedure TFpDwarfSymbolTypeStructure.KindNeeded;
begin
if (InformationEntry.AbbrevTag = DW_TAG_class_type) then
SetKind(skClass)
else
begin
if TypeInfo <> nil then // inheritance
SetKind(skObject) // skClass
else
if MemberByName['_vptr$TOBJECT'] <> nil then
SetKind(skObject) // skClass
else
if MemberByName['_vptr$'+Name] <> nil then
SetKind(skObject)
else
SetKind(skRecord);
end;
end;
function TFpDwarfSymbolTypeStructure.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
if ATypeCast then
Result := TFpDwarfValueStructTypeCast.Create(Self)
else
Result := TFpDwarfValueStruct.Create(Self);
end;
{ TFpDwarfSymbolTypeArray }
procedure TFpDwarfSymbolTypeArray.CreateMembers;
var
Info, Info2: TDwarfInformationEntry;
t: Cardinal;
sym: TFpDwarfSymbol;
begin
if FMembers <> nil then
exit;
FMembers := TFpDbgCircularRefCntObjList.Create;
Info := InformationEntry.FirstChild;
if Info = nil then exit;
while Info.HasValidScope do begin
t := Info.AbbrevTag;
if (t = DW_TAG_enumeration_type) or (t = DW_TAG_subrange_type) then begin
Info2 := Info.Clone;
sym := TFpDwarfSymbol.CreateSubClass('', Info2);
FMembers.Add(sym);
sym.ReleaseReference;
sym.ParentTypeInfo := self;
Info2.ReleaseReference;
end;
Info.GoNext;
end;
Info.ReleaseReference;
end;
procedure TFpDwarfSymbolTypeArray.ReadStride;
var
t: TFpDwarfSymbolType;
begin
if didtStrideRead in FDwarfArrayReadFlags then
exit;
Include(FDwarfArrayReadFlags, didtStrideRead);
if InformationEntry.ReadValue(DW_AT_bit_stride, FStrideInBits) then
exit;
CreateMembers;
if (FMembers.Count > 0) and // TODO: stride for diff member
(TDbgDwarfSymbolBase(FMembers[0]).InformationEntry.ReadValue(DW_AT_byte_stride, FStrideInBits))
then begin
FStrideInBits := FStrideInBits * 8;
exit;
end;
t := NestedTypeInfo;
if t = nil then
FStrideInBits := 0 // TODO error
else
FStrideInBits := t.Size * 8;
end;
procedure TFpDwarfSymbolTypeArray.ReadOrdering;
var
AVal: Integer;
begin
if didtOrdering in FDwarfArrayReadFlags then
exit;
Include(FDwarfArrayReadFlags, didtOrdering);
if InformationEntry.ReadValue(DW_AT_ordering, AVal) then
FRowMajor := AVal = DW_ORD_row_major
else
FRowMajor := True; // default (at least in pas)
end;
procedure TFpDwarfSymbolTypeArray.KindNeeded;
begin
SetKind(skArray); // Todo: static/dynamic?
end;
function TFpDwarfSymbolTypeArray.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
begin
Result := TFpDwarfValueArray.Create(Self);
end;
function TFpDwarfSymbolTypeArray.GetFlags: TDbgSymbolFlags;
function IsDynSubRange(m: TFpDwarfSymbol): Boolean;
begin
Result := sfSubRange in m.Flags;
if not Result then exit;
while (m <> nil) and not(m is TFpDwarfSymbolTypeSubRange) do
m := m.NestedTypeInfo;
Result := m <> nil;
if not Result then exit; // TODO: should not happen, handle error
Result := TFpDwarfSymbolTypeSubRange(m).FHighBoundState = rfValue; // dynamic high bound
end;
var
m: TFpDbgSymbol;
begin
Result := inherited GetFlags;
if (MemberCount = 1) then begin
m := Member[0];
if (not m.HasBounds) or // e.g. Subrange with missing upper bound
(m.OrdHighBound < m.OrdLowBound) or
(IsDynSubRange(TFpDwarfSymbol(m)))
then
Result := Result + [sfDynArray]
else
Result := Result + [sfStatArray];
end
else
Result := Result + [sfStatArray];
end;
function TFpDwarfSymbolTypeArray.GetMember(AIndex: Int64): TFpDbgSymbol;
begin
CreateMembers;
Result := TFpDbgSymbol(FMembers[AIndex]);
end;
function TFpDwarfSymbolTypeArray.GetMemberByName(AIndex: String): TFpDbgSymbol;
begin
Result := nil; // no named members
end;
function TFpDwarfSymbolTypeArray.GetMemberCount: Integer;
begin
CreateMembers;
Result := FMembers.Count;
end;
function TFpDwarfSymbolTypeArray.GetMemberAddress(AValObject: TFpDwarfValue;
AIndex: array of Int64): TFpDbgMemLocation;
var
Idx, Offs, Factor: Int64;
LowBound, HighBound: int64;
i: Integer;
bsize: Integer;
m: TFpDwarfSymbol;
begin
assert((AValObject is TFpDwarfValueArray), 'TFpDwarfSymbolTypeArray.GetMemberAddress AValObject');
ReadOrdering;
ReadStride; // TODO Stride per member (member = dimension/index)
Result := InvalidLoc;
if (FStrideInBits <= 0) or (FStrideInBits mod 8 <> 0) then
exit;
CreateMembers;
if Length(AIndex) > FMembers.Count then
exit;
if AValObject is TFpDwarfValueArray then begin
if not TFpDwarfValueArray(AValObject).GetDwarfDataAddress(Result, Self) then begin
Result := InvalidLoc;
Exit;
end;
end
else
exit; // TODO error
Offs := 0;
Factor := 1;
{$PUSH}{$R-}{$Q-} // TODO: check range of index
bsize := FStrideInBits div 8;
if FRowMajor then begin
for i := Length(AIndex) - 1 downto 0 do begin
Idx := AIndex[i];
m := TFpDwarfSymbol(FMembers[i]);
if ((m is TFpDwarfSymbolType) and (TFpDwarfSymbolType(m).GetValueBounds(AValObject, LowBound, HighBound))) or
m.HasBounds then begin
Idx := Idx - m.OrdLowBound;
end;
Offs := Offs + Idx * bsize * Factor;
if i > 0 then begin
if not m.HasBounds then begin
Result := InvalidLoc;
exit;
end;
// TODO range check
Factor := Factor * (m.OrdHighBound - m.OrdLowBound + 1);
end;
end;
end
else begin
for i := 0 to Length(AIndex) - 1 do begin
Idx := AIndex[i];
m := TFpDwarfSymbol(FMembers[i]);
if m.HasBounds then begin
Idx := Idx - m.OrdLowBound;
end;
Offs := Offs + Idx * bsize * Factor;
if i < Length(AIndex) - 1 then begin
if not m.HasBounds then begin
Result := InvalidLoc;
exit;
end;
Factor := Factor * (m.OrdHighBound - m.OrdLowBound + 1);
end;
end;
end;
assert(IsTargetAddr(Result), 'DwarfArray MemberAddress');
Result.Address := Result.Address + Offs;
{$POP}
end;
destructor TFpDwarfSymbolTypeArray.Destroy;
var
i: Integer;
begin
if FMembers <> nil then begin
for i := 0 to FMembers.Count - 1 do
TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
FreeAndNil(FMembers);
end;
inherited Destroy;
end;
{ TDbgDwarfSymbol }
constructor TFpDwarfSymbolValueProc.Create(ACompilationUnit: TDwarfCompilationUnit;
AInfo: PDwarfAddressInfo; AAddress: TDbgPtr);
var
InfoEntry: TDwarfInformationEntry;
begin
FAddress := AAddress;
FAddressInfo := AInfo;
InfoEntry := TDwarfInformationEntry.Create(ACompilationUnit, nil);
InfoEntry.ScopeIndex := AInfo^.ScopeIndex;
inherited Create(
String(FAddressInfo^.Name),
InfoEntry
);
SetAddress(TargetLoc(FAddressInfo^.StartPC));
InfoEntry.ReleaseReference;
//BuildLineInfo(
// AFile: String = ''; ALine: Integer = -1; AFlags: TDbgSymbolFlags = []; const AReference: TDbgSymbol = nil);
end;
destructor TFpDwarfSymbolValueProc.Destroy;
begin
FreeAndNil(FProcMembers);
FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
FreeAndNil(FStateMachine);
if FSelfParameter <> nil then begin
//TDbgDwarfIdentifier(FSelfParameter.DbgSymbol).ParentTypeInfo := nil;
FSelfParameter.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSelfParameter, 'FSelfParameter'){$ENDIF};
end;
inherited Destroy;
end;
function TFpDwarfSymbolValueProc.GetColumn: Cardinal;
begin
if StateMachineValid
then Result := FStateMachine.Column
else Result := inherited GetColumn;
end;
function TFpDwarfSymbolValueProc.GetFile: String;
begin
if StateMachineValid
then Result := FStateMachine.FileName
else Result := inherited GetFile;
end;
function TFpDwarfSymbolValueProc.GetLine: Cardinal;
begin
if StateMachineValid
then Result := FStateMachine.Line
else Result := inherited GetLine;
end;
function TFpDwarfSymbolValueProc.GetValueObject: TFpDbgValue;
begin
Result := FValueObject;
if Result <> nil then exit;
FValueObject := TFpDwarfValue.Create(nil);
{$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
FValueObject.MakePlainRefToCirclular;
FValueObject.SetValueSymbol(self);
Result := FValueObject;
end;
function TFpDwarfSymbolValueProc.StateMachineValid: Boolean;
var
SM1, SM2: TDwarfLineInfoStateMachine;
begin
Result := FStateMachine <> nil;
if Result then Exit;
if FAddressInfo^.StateMachine = nil
then begin
CompilationUnit.BuildLineInfo(FAddressInfo, False);
if FAddressInfo^.StateMachine = nil then Exit;
end;
// we cannot restore a statemachine to its current state
// so we shouldn't modify FAddressInfo^.StateMachine
// so use clones to navigate
SM1 := FAddressInfo^.StateMachine.Clone;
if FAddress < SM1.Address
then begin
// The address we want to find is before the start of this symbol ??
SM1.Free;
Exit;
end;
SM2 := FAddressInfo^.StateMachine.Clone;
repeat
if (FAddress = SM1.Address)
or not SM2.NextLine
or (FAddress < SM2.Address)
then begin
// found
FStateMachine := SM1;
SM2.Free;
Result := True;
Exit;
end;
until not SM1.NextLine;
//if all went well we shouldn't come here
SM1.Free;
SM2.Free;
end;
function TFpDwarfSymbolValueProc.ReadVirtuality(out AFlags: TDbgSymbolFlags): Boolean;
var
Val: Integer;
begin
AFlags := [];
Result := InformationEntry.ReadValue(DW_AT_virtuality, Val);
if not Result then exit;
case Val of
DW_VIRTUALITY_none: ;
DW_VIRTUALITY_virtual: AFlags := [sfVirtual];
DW_VIRTUALITY_pure_virtual: AFlags := [sfVirtual];
end;
end;
procedure TFpDwarfSymbolValueProc.CreateMembers;
var
Info: TDwarfInformationEntry;
Info2: TDwarfInformationEntry;
begin
if FProcMembers <> nil then
exit;
FProcMembers := TRefCntObjList.Create;
Info := InformationEntry.Clone;
Info.GoChild;
while Info.HasValidScope do begin
if ((Info.AbbrevTag = DW_TAG_formal_parameter) or (Info.AbbrevTag = DW_TAG_variable)) //and
//not(Info.IsArtificial)
then begin
Info2 := Info.Clone;
FProcMembers.Add(Info2);
Info2.ReleaseReference;
end;
Info.GoNext;
end;
Info.ReleaseReference;
end;
function TFpDwarfSymbolValueProc.GetMember(AIndex: Int64): TFpDbgSymbol;
begin
CreateMembers;
FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
FLastMember := TFpDwarfSymbol.CreateSubClass('', TDwarfInformationEntry(FProcMembers[AIndex]));
{$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF}
Result := FLastMember;
end;
function TFpDwarfSymbolValueProc.GetMemberByName(AIndex: String): TFpDbgSymbol;
var
Info: TDwarfInformationEntry;
s, s2: String;
i: Integer;
begin
CreateMembers;
s2 := LowerCase(AIndex);
FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
FLastMember := nil;;
for i := 0 to FProcMembers.Count - 1 do begin
Info := TDwarfInformationEntry(FProcMembers[i]);
if Info.ReadName(s) and (LowerCase(s) = s2) then begin
FLastMember := TFpDwarfSymbol.CreateSubClass('', Info);
{$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF}
break;
end;
end;
Result := FLastMember;
end;
function TFpDwarfSymbolValueProc.GetMemberCount: Integer;
begin
CreateMembers;
Result := FProcMembers.Count;
end;
function TFpDwarfSymbolValueProc.GetFrameBase(ASender: TDwarfLocationExpression): TDbgPtr;
var
Val: TByteDynArray;
begin
Result := 0;
if FFrameBaseParser = nil then begin
//TODO: avoid copying data
if not InformationEntry.ReadValue(DW_AT_frame_base, Val) then begin
// error
debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase failed to read DW_AT_frame_base']);
exit;
end;
if Length(Val) = 0 then begin
// error
debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase failed to read DW_AT_location']);
exit;
end;
FFrameBaseParser := TDwarfLocationExpression.Create(@Val[0], Length(Val), CompilationUnit,
ASender.MemManager, ASender.Context);
FFrameBaseParser.Evaluate;
end;
if FFrameBaseParser.ResultKind in [lseValue] then
Result := FFrameBaseParser.ResultData;
if IsError(FFrameBaseParser.LastError) then begin
SetLastError(FFrameBaseParser.LastError);
debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase location parser failed ', ErrorHandler.ErrorAsString(LastError)]);
end
else
if Result = 0 then begin
debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase location parser failed. result is 0']);
end;
end;
procedure TFpDwarfSymbolValueProc.KindNeeded;
begin
if TypeInfo <> nil then
SetKind(skFunction)
else
SetKind(skProcedure);
end;
procedure TFpDwarfSymbolValueProc.SizeNeeded;
begin
SetSize(FAddressInfo^.EndPC - FAddressInfo^.StartPC);
end;
function TFpDwarfSymbolValueProc.GetFlags: TDbgSymbolFlags;
var
flg: TDbgSymbolFlags;
begin
Result := inherited GetFlags;
if ReadVirtuality(flg) then
Result := Result + flg;
end;
function TFpDwarfSymbolValueProc.GetSelfParameter(AnAddress: TDbgPtr): TFpDwarfValue;
const
this1: string = 'THIS';
this2: string = 'this';
self1: string = '$SELF';
self2: string = '$self';
var
InfoEntry: TDwarfInformationEntry;
tg: Cardinal;
found: Boolean;
begin
// special: search "self"
// Todo nested procs
Result := FSelfParameter;
if Result <> nil then exit;
InfoEntry := InformationEntry.Clone;
//StartScopeIdx := InfoEntry.ScopeIndex;
InfoEntry.GoParent;
tg := InfoEntry.AbbrevTag;
if (tg = DW_TAG_class_type) or (tg = DW_TAG_structure_type) then begin
InfoEntry.ScopeIndex := InformationEntry.ScopeIndex;
found := InfoEntry.GoNamedChildEx(@this1[1], @this2[1]);
if not found then begin
InfoEntry.ScopeIndex := InformationEntry.ScopeIndex;
found := InfoEntry.GoNamedChildEx(@self1[1], @self2[1]);
end;
if found then begin
if ((AnAddress = 0) or InfoEntry.IsAddressInStartScope(AnAddress)) and
InfoEntry.IsArtificial
then begin
Result := TFpDwarfValue(TFpDwarfSymbolValue.CreateValueSubClass('self', InfoEntry).Value);
FSelfParameter := Result;
FSelfParameter.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSelfParameter, 'FSelfParameter'){$ENDIF};
FSelfParameter.DbgSymbol.ReleaseReference;
//FSelfParameter.DbgSymbol.ParentTypeInfo := Self;
debugln(FPDBG_DWARF_SEARCH, ['TFpDwarfSymbolValueProc.GetSelfParameter ', InfoEntry.ScopeDebugText, DbgSName(Result)]);
end;
end;
end;
InfoEntry.ReleaseReference;
end;
{ TFpDwarfSymbolValueVariable }
function TFpDwarfSymbolValueVariable.GetValueAddress(AValueObj: TFpDwarfValue; out
AnAddress: TFpDbgMemLocation): Boolean;
begin
AnAddress := AValueObj.DataAddressCache[0];
Result := IsValidLoc(AnAddress);
if IsInitializedLoc(AnAddress) then
exit;
Result := LocationFromTag(DW_AT_location, AValueObj, AnAddress);
AValueObj.DataAddressCache[0] := AnAddress;
end;
function TFpDwarfSymbolValueVariable.HasAddress: Boolean;
begin
Result := InformationEntry.HasAttrib(DW_AT_location);
end;
{ TFpDwarfSymbolValueParameter }
function TFpDwarfSymbolValueParameter.GetValueAddress(AValueObj: TFpDwarfValue; out
AnAddress: TFpDbgMemLocation): Boolean;
begin
AnAddress := AValueObj.DataAddressCache[0];
Result := IsValidLoc(AnAddress);
if IsInitializedLoc(AnAddress) then
exit;
Result := LocationFromTag(DW_AT_location, AValueObj, AnAddress);
AValueObj.DataAddressCache[0] := AnAddress;
end;
function TFpDwarfSymbolValueParameter.HasAddress: Boolean;
begin
Result := InformationEntry.HasAttrib(DW_AT_location);
end;
function TFpDwarfSymbolValueParameter.GetFlags: TDbgSymbolFlags;
begin
Result := (inherited GetFlags) + [sfParameter];
end;
{ TFpDwarfSymbolUnit }
procedure TFpDwarfSymbolUnit.Init;
begin
inherited Init;
SetSymbolType(stNone);
SetKind(skUnit);
end;
function TFpDwarfSymbolUnit.GetMemberByName(AIndex: String): TFpDbgSymbol;
var
Ident: TDwarfInformationEntry;
begin
// Todo, param to only search external.
ReleaseRefAndNil(FLastChildByName);
Result := nil;
Ident := InformationEntry.Clone;
Ident.GoNamedChildEx(AIndex);
if Ident <> nil then
Result := TFpDwarfSymbol.CreateSubClass('', Ident);
// No need to set ParentTypeInfo
ReleaseRefAndNil(Ident);
FLastChildByName := Result;
end;
destructor TFpDwarfSymbolUnit.Destroy;
begin
ReleaseRefAndNil(FLastChildByName);
inherited Destroy;
end;
initialization
DwarfSymbolClassMapList.SetDefaultMap(TFpDwarfDefaultSymbolClassMap);
FPDBG_DWARF_VERBOSE := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_VERBOSE' {$IFDEF FPDBG_DWARF_VERBOSE} , True {$ENDIF} );
FPDBG_DWARF_ERRORS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_ERRORS' {$IFDEF FPDBG_DWARF_ERRORS} , True {$ENDIF} );
FPDBG_DWARF_WARNINGS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_WARNINGS' {$IFDEF FPDBG_DWARF_WARNINGS} , True {$ENDIF} );
FPDBG_DWARF_SEARCH := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_SEARCH' {$IFDEF FPDBG_DWARF_SEARCH} , True {$ENDIF} );
FPDBG_DWARF_DATA_WARNINGS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_DATA_WARNINGS' {$IFDEF FPDBG_DWARF_DATA_WARNINGS} , True {$ENDIF} );
end.