paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-13 12:49:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

FPDebug: fix finding parentclass data address

Browse Source 
git-svn-id: trunk@44408 -
This commit is contained in:
martin 2014-03-11 22:16:38 +00:00
parent 2ffd578010
commit e3b1d7060b
2 changed files with 25 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
components/fpdebug/fpdbgdwarf.pas
View File

@ -1219,8 +1219,8 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
procedure CreateMembers; procedure CreateMembers;
procedure InitInheritanceInfo; inline; procedure InitInheritanceInfo; inline;
protected protected
function DoGetNestedTypeInfo: TDbgDwarfTypeIdentifier; override;
procedure KindNeeded; override; procedure KindNeeded; override;
procedure TypeInfoNeeded; override; // nil or inherited
function GetTypedValueObject(ATypeCast: Boolean): TFpDbgDwarfValue; override; function GetTypedValueObject(ATypeCast: Boolean): TFpDbgDwarfValue; override;
// GetMember, if AIndex > Count then parent // GetMember, if AIndex > Count then parent
@ -2886,18 +2886,11 @@ function TFpDbgDwarfValue.GetDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
var var
fields: TFpDbgValueFieldFlags; fields: TFpDbgValueFieldFlags;
begin begin
// TODO: also cache none valid address
//Result := IsValidLoc(ATargetType.FCachedDataAddress);
//if Result then begin
// AnAddress := ATargetType.FCachedDataAddress;
// exit;
//end;
if FValueSymbol <> nil then begin if FValueSymbol <> nil then begin
Assert(FValueSymbol is TDbgDwarfValueIdentifier, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol'); Assert(FValueSymbol is TDbgDwarfValueIdentifier, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol');
Assert(TypeInfo is TDbgDwarfTypeIdentifier, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo'); Assert(TypeInfo is TDbgDwarfTypeIdentifier, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo');
Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo'); Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo');
Result := FValueSymbol.GetValueDataAddress(Self, AnAddress, TDbgDwarfTypeIdentifier(FOwner)); Result := FValueSymbol.GetValueDataAddress(Self, AnAddress, ATargetType);
if IsError(FValueSymbol.LastError) then if IsError(FValueSymbol.LastError) then
FLastError := FValueSymbol.LastError; FLastError := FValueSymbol.LastError;
end end
@ -2925,8 +2918,6 @@ begin
if IsError(FTypeCastTargetType.LastError) then if IsError(FTypeCastTargetType.LastError) then
FLastError := FTypeCastTargetType.LastError; FLastError := FTypeCastTargetType.LastError;
end; end;
//ATargetType.FCachedDataAddress := AnAddress;
end; end;
function TFpDbgDwarfValue.GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation; function TFpDbgDwarfValue.GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
@ -6349,6 +6340,24 @@ begin
FInheritanceInfo := FInformationEntry.FindChildByTag(DW_TAG_inheritance); FInheritanceInfo := FInformationEntry.FindChildByTag(DW_TAG_inheritance);
end; end;
function TDbgDwarfIdentifierStructure.DoGetNestedTypeInfo: TDbgDwarfTypeIdentifier;
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 := TDbgDwarfTypeIdentifier.CreateTypeSubClass('', ParentInfo);
ParentInfo.ReleaseReference;
end;
end;
procedure TDbgDwarfIdentifierStructure.KindNeeded; procedure TDbgDwarfIdentifierStructure.KindNeeded;
begin begin
if (FInformationEntry.AbbrevTag = DW_TAG_class_type) then if (FInformationEntry.AbbrevTag = DW_TAG_class_type) then
@ -6368,27 +6377,6 @@ begin
end; end;
end; end;
procedure TDbgDwarfIdentifierStructure.TypeInfoNeeded;
var
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
ti: TDbgDwarfIdentifier;
ParentInfo: TDwarfInformationEntry;
begin
ti:= 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) ]);
ti := TDbgDwarfIdentifier.CreateSubClass('', ParentInfo);
ParentInfo.ReleaseReference;
end;
SetTypeInfo(ti);
ti.ReleaseReference;
end;
function TDbgDwarfIdentifierStructure.GetTypedValueObject(ATypeCast: Boolean): TFpDbgDwarfValue; function TDbgDwarfIdentifierStructure.GetTypedValueObject(ATypeCast: Boolean): TFpDbgDwarfValue;
begin begin
if ATypeCast then if ATypeCast then
@ -6734,7 +6722,7 @@ begin
if ti <> nil then if ti <> nil then
Result := ti.GetDataAddress(AValueObj, AnAddress, ATargetType, ATargetCacheIndex+1) Result := ti.GetDataAddress(AValueObj, AnAddress, ATargetType, ATargetCacheIndex+1)
else else
Result := True; // TODO: False; // Result := ATargetType = nil; // end of type chain Result := False; // Result := ATargetType = nil; // end of type chain
end; end;
end; end;

6
components/fpdebug/test/testtypeinfo.pas
View File

@ -864,6 +864,7 @@ begin
// Class/Object // typecast, and inherhited // Class/Object // typecast, and inherhited
obj1c := TTestSetup1ClassChild.Create; obj1c := TTestSetup1ClassChild.Create;
ImgLoader.GlobTestSetup1.VarClass := Obj1c; ImgLoader.GlobTestSetup1.VarClass := Obj1c;
ImgLoader.GlobTestSetup1.VarClassChild := Obj1c;
Obj1c.FWord := 1019; Obj1c.FWord := 1019;
Obj1c.FBool := Boolean($9aa99aa9); // Make sure there is data, if other fields read to much Obj1c.FBool := Boolean($9aa99aa9); // Make sure there is data, if other fields read to much
Obj1c.FWordL := QWord($9aa99aa97bb7b77b); // Make sure there is data, if other fields read to much Obj1c.FWordL := QWord($9aa99aa97bb7b77b); // Make sure there is data, if other fields read to much
@ -871,10 +872,11 @@ begin
StartTest('GlobTestSetup1Class.FWord', skCardinal, [ttHasType]); StartTest('GlobTestSetup1Class.FWord', skCardinal, [ttHasType]);
ExpResult(svfCardinal, 1019); ExpResult(svfCardinal, 1019);
StartTest('TTestSetup1ClassChild(GlobTestSetup1Class).FWord', skCardinal, [ttHasType]); StartTest('GlobTestSetup1ClassChild.FWord', skCardinal, [ttHasType]);
ExpResult(svfCardinal, 1019); ExpResult(svfCardinal, 1019);
///////////////////------------- StartTest('TTestSetup1ClassChild(GlobTestSetup1Class).FWord', skCardinal, [ttHasType]);
ExpResult(svfCardinal, 1019);
// Record // Record
// VParamTestRecord mis-named // VParamTestRecord mis-named