{ --------------------------------------------------------------------------- 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$) @author(Marc Weustink ) @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 . 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.