diff --git a/components/fpdebug/fpdbgdwarf.pas b/components/fpdebug/fpdbgdwarf.pas index 984d58ca18..78458735e7 100644 --- a/components/fpdebug/fpdbgdwarf.pas +++ b/components/fpdebug/fpdbgdwarf.pas @@ -122,7 +122,7 @@ type private FContext: TFpDbgInfoContext; public - property Context: TFpDbgInfoContext read FContext; + property Context: TFpDbgInfoContext read FContext write FContext; end; { TFpDwarfValueTypeDefinition } @@ -152,7 +152,6 @@ type FStructureValue: TFpDwarfValue; FLastMember: TFpDwarfValue; function GetDataAddressCache(AIndex: Integer): TFpDbgMemLocation; - function AddressSize: Byte; inline; procedure SetDataAddressCache(AIndex: Integer; AValue: TFpDbgMemLocation); procedure SetStructureValue(AValue: TFpDwarfValue); protected @@ -163,6 +162,7 @@ type procedure CircleBackRefActiveChanged(NewActive: Boolean); override; procedure SetLastMember(ALastMember: TFpDwarfValue); function GetLastError: TFpError; override; + function AddressSize: Byte; inline; // Address of the symbol (not followed any type deref, or location) function GetAddress: TFpDbgMemLocation; override; @@ -186,6 +186,9 @@ type function GetDbgSymbol: TFpDbgSymbol; override; function GetTypeInfo: TFpDbgSymbol; override; function GetContextTypeInfo: TFpDbgSymbol; override; + + property TypeCastTargetType: TFpDwarfSymbolType read FTypeCastTargetType; + property TypeCastSourceValue: TFpDbgValue read FTypeCastSourceValue; public constructor Create(AOwner: TFpDwarfSymbolType); destructor Destroy; override; @@ -4302,7 +4305,7 @@ var m: TFpDbgSymbol; begin Result := inherited GetFlags; - if (MemberCount = 1) then begin + if (MemberCount = 1) then begin // TODO: move to freepascal specific m := Member[0]; if (not m.HasBounds) or // e.g. Subrange with missing upper bound (m.OrdHighBound < m.OrdLowBound) or diff --git a/components/fpdebug/fpdbgdwarffreepascal.pas b/components/fpdebug/fpdbgdwarffreepascal.pas index 2a6220c705..c8c6f0fe87 100644 --- a/components/fpdebug/fpdbgdwarffreepascal.pas +++ b/components/fpdebug/fpdbgdwarffreepascal.pas @@ -5,18 +5,21 @@ unit FpDbgDwarfFreePascal; interface uses - Classes, SysUtils, FpDbgDwarfDataClasses, FpDbgDwarf, FpDbgInfo, FpDbgUtil, - FpDbgDwarfConst, FpErrorMessages, FpdMemoryTools, DbgIntfBaseTypes, + Classes, SysUtils, Types, FpDbgDwarfDataClasses, FpDbgDwarf, FpDbgInfo, + FpDbgUtil, FpDbgDwarfConst, FpErrorMessages, FpdMemoryTools, DbgIntfBaseTypes, LazLoggerBase; type + (* ***** SymbolClassMap ***** + *) + { TFpDwarfFreePascalSymbolClassMap } TFpDwarfFreePascalSymbolClassMap = class(TFpDwarfDefaultSymbolClassMap) public class function HandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override; - //class function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; 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; @@ -47,6 +50,9 @@ type // AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override; end; + (* ***** Context ***** + *) + { TFpDwarfFreePascalAddressContext } TFpDwarfFreePascalAddressContext = class(TFpDwarfInfoAddressContext) @@ -60,6 +66,11 @@ type destructor Destroy; override; end; + (* ***** Value & Types ***** + *) + + (* *** Record vs ShortString *** *) + { TFpDwarf2FreePascalSymbolTypeStructure } TFpDwarf2FreePascalSymbolTypeStructure = class(TFpDwarfSymbolTypeStructure) @@ -73,9 +84,13 @@ type //function GetMemberByName(AIndex: String): TFpDbgSymbol; override; end; - { TFpDwarfValue2FreePascalShortString } + { TFpDwarfV2ValueFreePascalShortString } - TFpDwarfValue2FreePascalShortString = class(TFpDwarfValue) + TFpDwarfV2ValueFreePascalShortString = class(TFpDwarfValue) + protected + function IsValidTypeCast: Boolean; override; + function GetInternMemberByName(AIndex: String): TFpDbgValue; + procedure Reset; override; private FValue: String; FValueDone: Boolean; @@ -85,9 +100,27 @@ type function GetAsWideString: WideString; override; end; - { TFpDwarf3FreePascalSymbolTypeArray } + (* *** "Open Array" in params *** *) - TFpDwarf3FreePascalSymbolTypeArray = class(TFpDwarfSymbolTypeArray) + { TFpDwarfFreePascalSymbolTypeArray } + + TFpDwarfFreePascalSymbolTypeArray = class(TFpDwarfSymbolTypeArray) + protected + function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override; + end; + + { TFpDwarfValueFreePascalArray } + + TFpDwarfValueFreePascalArray = class(TFpDwarfValueArray) + protected + function GetMemberCount: Integer; override; + end; + + (* *** Array vs AnsiString *** *) + + { TFpDwarfV3FreePascalSymbolTypeArray } + + TFpDwarfV3FreePascalSymbolTypeArray = class(TFpDwarfFreePascalSymbolTypeArray) private type TArrayOrStringType = (iasUnknown, iasArray, iasShortString, iasAnsiString); private @@ -98,9 +131,9 @@ type procedure KindNeeded; override; end; - { TFpDwarfValue3FreePascalString } + { TFpDwarfV3ValueFreePascalString } - TFpDwarfValue3FreePascalString = class(TFpDwarfValue) // short & ansi... + TFpDwarfV3ValueFreePascalString = class(TFpDwarfValue) // short & ansi... private FValue: String; FValueDone: Boolean; @@ -122,6 +155,17 @@ begin Result := pos('free pascal', s) > 0; end; +class function TFpDwarfFreePascalSymbolClassMap.GetDwarfSymbolClass( + ATag: Cardinal): TDbgDwarfSymbolBaseClass; +begin + case ATag of + DW_TAG_array_type: + Result := TFpDwarfFreePascalSymbolTypeArray; + else + Result := inherited GetDwarfSymbolClass(ATag); + end; +end; + class function TFpDwarfFreePascalSymbolClassMap.CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext; begin @@ -175,7 +219,7 @@ class function TFpDwarfFreePascalSymbolClassMapDwarf3.GetDwarfSymbolClass( begin case ATag of DW_TAG_array_type: - Result := TFpDwarf3FreePascalSymbolTypeArray; + Result := TFpDwarfV3FreePascalSymbolTypeArray; // DW_TAG_structure_type: // Result := TFpDwarf2FreePascalSymbolTypeStructure; // maybe record // // TODO: @@ -369,7 +413,7 @@ begin if not IsShortString then Result := inherited GetTypedValueObject(ATypeCast) else - Result := TFpDwarfValue2FreePascalShortString.Create(Self); + Result := TFpDwarfV2ValueFreePascalShortString.Create(Self); end; procedure TFpDwarf2FreePascalSymbolTypeStructure.KindNeeded; @@ -388,15 +432,48 @@ begin Result := inherited GetMemberCount; end; -{ TFpDwarfValue2FreePascalShortString } +{ TFpDwarfV2ValueFreePascalShortString } -function TFpDwarfValue2FreePascalShortString.GetFieldFlags: TFpDbgValueFieldFlags; +function TFpDwarfV2ValueFreePascalShortString.IsValidTypeCast: Boolean; +begin + // currently only allow this / used by array access + Result := TypeCastSourceValue is TFpDbgValueConstAddress; +end; + +function TFpDwarfV2ValueFreePascalShortString.GetInternMemberByName( + AIndex: String): TFpDbgValue; +var + tmp: TFpDbgSymbol; +begin + if HasTypeCastInfo then begin + Result := nil; + tmp := TypeCastTargetType.MemberByName[AIndex]; + if (tmp <> nil) then begin + assert((tmp is TFpDwarfSymbolValue), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp)); + Result := tmp.Value; + + TFpDwarfValue(Result).StructureValue := Self; + if (TFpDwarfValue(Result).Context = nil) then + TFpDwarfValue(Result).Context := Context; + end; + end + else + Result := MemberByName[AIndex]; +end; + +procedure TFpDwarfV2ValueFreePascalShortString.Reset; +begin + inherited Reset; + FValueDone := False; +end; + +function TFpDwarfV2ValueFreePascalShortString.GetFieldFlags: TFpDbgValueFieldFlags; begin Result := inherited GetFieldFlags; Result := Result + [svfString]; end; -function TFpDwarfValue2FreePascalShortString.GetAsString: AnsiString; +function TFpDwarfV2ValueFreePascalShortString.GetAsString: AnsiString; var len: QWord; LenSym, StSym: TFpDwarfValue; @@ -404,12 +481,7 @@ begin if FValueDone then exit(FValue); - if HasTypeCastInfo then begin - FLastError := CreateError(fpErrAnyError); - exit(''); - end; - - LenSym := TFpDwarfValue(inherited MemberByName['length']); + LenSym := TFpDwarfValue(GetInternMemberByName('length')); assert(LenSym is TFpDwarfValue, 'LenSym is TFpDwarfValue'); len := LenSym.AsCardinal; @@ -418,7 +490,7 @@ begin exit(''); end; - StSym := TFpDwarfValue(inherited MemberByName['st']); + StSym := TFpDwarfValue(GetInternMemberByName('st')); assert(StSym is TFpDwarfValue, 'StSym is TFpDwarfValue'); @@ -435,14 +507,70 @@ begin FValueDone := True; end; -function TFpDwarfValue2FreePascalShortString.GetAsWideString: WideString; +function TFpDwarfV2ValueFreePascalShortString.GetAsWideString: WideString; begin Result := GetAsString; end; -{ TFpDwarf3FreePascalSymbolTypeArray } +{ TFpDwarfFreePascalSymbolTypeArray } -function TFpDwarf3FreePascalSymbolTypeArray.GetInternalStringType: TArrayOrStringType; +function TFpDwarfFreePascalSymbolTypeArray.GetTypedValueObject( + ATypeCast: Boolean): TFpDwarfValue; +begin + Result := TFpDwarfValueFreePascalArray.Create(Self); +end; + +{ TFpDwarfValueFreePascalArray } + +function TFpDwarfValueFreePascalArray.GetMemberCount: Integer; +var + t, t2: TFpDbgSymbol; + Info, Info2: TDwarfInformationEntry; + n: AnsiString; + UpperBoundSym: TFpDwarfSymbol; +begin + Result := 0; + t := TypeInfo; + if t.MemberCount < 1 then // IndexTypeCount; + exit(inherited GetMemberCount); + + t2 := t.Member[0]; // IndexType[0]; + if (t is TFpDwarfSymbolTypeArray) and + (t2 is TFpDwarfSymbolTypeSubRange) and + (DbgSymbol is TFpDwarfSymbolValueParameter) // open array exists only as param + then begin + Info := TFpDwarfSymbolTypeSubRange(t2).InformationEntry; + if Info.HasAttrib(DW_AT_lower_bound) and + not Info.HasAttrib(DW_AT_upper_bound) + then begin + Info2 := TFpDwarfSymbolValueVariable(DbgSymbol).InformationEntry.Clone; + Info2.GoNext; + if Info2.HasValidScope and + Info2.HasAttrib(DW_AT_location) and // the high param must have a location / cannot be a constant + Info2.ReadName(n) + then begin + if (n <> '') and (n[1] = '$') then // dwarf3 // TODO: make required in dwarf3 + delete(n, 1, 1); + if (copy(n,1,4) = 'high') and (UpperCase(copy(n, 5, length(n))) = UpperCase(DbgSymbol.Name)) then begin + UpperBoundSym := TFpDwarfSymbol.CreateSubClass('', Info2); + if UpperBoundSym <> nil then begin + Result := UpperBoundSym.Value.AsInteger - t2.OrdLowBound + 1; + Info2.ReleaseReference; + UpperBoundSym.ReleaseReference; + exit; + end; + end; + end; + Info2.ReleaseReference; + end; + end; + + Result := inherited GetMemberCount; +end; + +{ TFpDwarfV3FreePascalSymbolTypeArray } + +function TFpDwarfV3FreePascalSymbolTypeArray.GetInternalStringType: TArrayOrStringType; var Info: TDwarfInformationEntry; t: Cardinal; @@ -478,16 +606,16 @@ begin Info.ReleaseReference; end; -function TFpDwarf3FreePascalSymbolTypeArray.GetTypedValueObject( +function TFpDwarfV3FreePascalSymbolTypeArray.GetTypedValueObject( ATypeCast: Boolean): TFpDwarfValue; begin if GetInternalStringType in [iasShortString, iasAnsiString] then - Result := TFpDwarfValue3FreePascalString.Create(Self) + Result := TFpDwarfV3ValueFreePascalString.Create(Self) else Result := inherited GetTypedValueObject(ATypeCast); end; -procedure TFpDwarf3FreePascalSymbolTypeArray.KindNeeded; +procedure TFpDwarfV3FreePascalSymbolTypeArray.KindNeeded; begin case GetInternalStringType of iasShortString: @@ -499,15 +627,15 @@ begin end; end; -{ TFpDwarfValue3FreePascalString } +{ TFpDwarfV3ValueFreePascalString } -function TFpDwarfValue3FreePascalString.GetFieldFlags: TFpDbgValueFieldFlags; +function TFpDwarfV3ValueFreePascalString.GetFieldFlags: TFpDbgValueFieldFlags; begin Result := inherited GetFieldFlags; Result := Result + [svfString]; end; -function TFpDwarfValue3FreePascalString.GetAsString: AnsiString; +function TFpDwarfV3ValueFreePascalString.GetAsString: AnsiString; var t, t2: TFpDbgSymbol; LowBound, HighBound: Int64; @@ -553,7 +681,7 @@ begin end; -function TFpDwarfValue3FreePascalString.GetAsWideString: WideString; +function TFpDwarfV3ValueFreePascalString.GetAsWideString: WideString; begin // todo: widestring, but currently that is encoded as PWideChar Result := GetAsString;