paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-31 07:12:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

FpDebug: Show "class var" if in current context (no class/instance-name prefix).

Browse Source 
(cherry picked from commit d8188bb780)
This commit is contained in:
Martin 2021-11-30 15:50:52 +01:00
parent 709f86d99f
commit 340f6f1502
5 changed files with 176 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
components/fpdebug/fpdbgdwarf.pas
View File

@ -123,10 +123,13 @@ type
function FindExportedSymbolInUnits(const AName: String; const ANameInfo: TNameSearchInfo;
SkipCompUnit: TDwarfCompilationUnit; out ADbgValue: TFpValue; const OnlyUnitNameLower: String = ''): Boolean;
function FindSymbolInStructure(const AName: String; const ANameInfo: TNameSearchInfo;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean; virtual;
function FindSymbolInStructureRecursive(const AName: String; const ANameInfo: TNameSearchInfo;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean; inline;
// FindLocalSymbol: for the subroutine itself
function FindLocalSymbol(const AName: String; const ANameInfo: TNameSearchInfo;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean; virtual;
procedure Init; virtual;
public
constructor Create(ALocationContext: TFpDbgLocationContext; ASymbol: TFpSymbol; ADwarf: TFpDwarfInfo);
destructor Destroy; override;
@ -1474,22 +1477,34 @@ end;
function TFpDwarfInfoSymbolScope.FindSymbolInStructure(const AName: String;
const ANameInfo: TNameSearchInfo; InfoEntry: TDwarfInformationEntry; out
ADbgValue: TFpValue): Boolean;
begin
ADbgValue := nil;
Result := False;
end;
function TFpDwarfInfoSymbolScope.FindSymbolInStructureRecursive(const AName: String;
const ANameInfo: TNameSearchInfo; InfoEntry: TDwarfInformationEntry; out
ADbgValue: TFpValue): Boolean;
var
InfoEntryInheritance: TDwarfInformationEntry;
FwdInfoPtr: Pointer;
FwdCompUint: TDwarfCompilationUnit;
SelfParam: TFpValue;
StartScope: Integer;
begin
Result := False;
ADbgValue := nil;
InfoEntry.AddReference;
InfoEntryInheritance := nil;
while True do begin
if not InfoEntry.IsAddressInStartScope(FAddress) then
break;
InfoEntryInheritance.ReleaseReference;
InfoEntryInheritance := InfoEntry.FindChildByTag(DW_TAG_inheritance);
StartScope := InfoEntry.ScopeIndex;
if InfoEntry.GoNamedChildEx(ANameInfo) then begin
if InfoEntry.IsAddressInStartScope(FAddress) then begin
SelfParam := GetSelfParameter;
@ -1501,12 +1516,13 @@ begin
if ADbgValue = nil then begin // Todo: abort the searh /SetError
ADbgValue := SymbolToValue(TFpSymbolDwarf.CreateSubClass(AName, InfoEntry));
end;
InfoEntry.ReleaseReference;
InfoEntryInheritance.ReleaseReference;
Result := True;
exit;
break;
end;
end;
InfoEntry.ScopeIndex := StartScope;
if FindSymbolInStructure(AName, ANameInfo, InfoEntry, ADbgValue) then
break;
if not( (InfoEntryInheritance <> nil) and
@ -1515,10 +1531,10 @@ begin
break;
InfoEntry.ReleaseReference;
InfoEntry := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
InfoEntryInheritance.ReleaseReference;
DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier PARENT ', dbgs(InfoEntry, FwdCompUint) ]);
end;
InfoEntryInheritance.ReleaseReference;
InfoEntry.ReleaseReference;
Result := ADbgValue <> nil;
end;
@ -1541,6 +1557,11 @@ begin
Result := ADbgValue <> nil;
end;
procedure TFpDwarfInfoSymbolScope.Init;
begin
//
end;
constructor TFpDwarfInfoSymbolScope.Create(
ALocationContext: TFpDbgLocationContext; ASymbol: TFpSymbol;
ADwarf: TFpDwarfInfo);
@ -1552,6 +1573,7 @@ begin
FAddress := LocationContext.Address; // for quick access
if FSymbol <> nil then
FSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'Context to Symbol'){$ENDIF};
Init;
end;
destructor TFpDwarfInfoSymbolScope.Destroy;
@ -1648,7 +1670,7 @@ begin
if (tg = DW_TAG_class_type) or (tg = DW_TAG_structure_type) then begin
if FindSymbolInStructure(AName,NameInfo, InfoEntry, Result) then begin
if FindSymbolInStructureRecursive(AName,NameInfo, InfoEntry, Result) then begin
exit; // TODO: check error
end;
//InfoEntry.ScopeIndex := StartScopeIdx;

72
components/fpdebug/fpdbgdwarffreepascal.pas
View File

@ -72,6 +72,8 @@ type
class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
public
function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
function CreateScopeForSymbol(ALocationContext: TFpDbgLocationContext; ASymbol: TFpSymbol;
ADwarf: TFpDwarfInfo): TFpDbgSymbolScope; override;
//class function CreateSymbolScope(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
// ADwarf: TFpDwarfInfo): TFpDbgSymbolScope; override;
//class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
@ -88,13 +90,25 @@ type
private
FOuterNestContext: TFpDbgSymbolScope;
FOuterNotFound: Boolean;
FClassVarStaticPrefix: String;
protected
function FindLocalSymbol(const AName: String; const ANameInfo: TNameSearchInfo;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean; override;
function FindSymbolInStructure(const AName: String;
const ANameInfo: TNameSearchInfo; InfoEntry: TDwarfInformationEntry; out
ADbgValue: TFpValue): Boolean; override;
procedure Init; override;
public
destructor Destroy; override;
end;
{ TFpDwarfFreePascalSymbolScopeDwarf3 }
TFpDwarfFreePascalSymbolScopeDwarf3 = class(TFpDwarfFreePascalSymbolScope)
protected
procedure Init; override;
end;
{%EndRegion }
{%Region * ***** Value & Types ***** *}
@ -450,6 +464,13 @@ begin
end;
end;
function TFpDwarfFreePascalSymbolClassMapDwarf3.CreateScopeForSymbol(
ALocationContext: TFpDbgLocationContext; ASymbol: TFpSymbol;
ADwarf: TFpDwarfInfo): TFpDbgSymbolScope;
begin
Result := TFpDwarfFreePascalSymbolScopeDwarf3.Create(ALocationContext, ASymbol, ADwarf);
end;
type
{ TFpDbgDwarfSimpleLocationContext }
@ -613,12 +634,63 @@ begin
Result := True; // self, global was done by outer
end;
function TFpDwarfFreePascalSymbolScope.FindSymbolInStructure(
const AName: String; const ANameInfo: TNameSearchInfo;
InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean;
var
CU: TDwarfCompilationUnit;
CurClassName, StaticName, FoundName: String;
MangledNameInfo: TNameSearchInfo;
FoundInfoEntry: TDwarfInformationEntry;
IsExternal: Boolean;
begin
Result := inherited FindSymbolInStructure(AName, ANameInfo, InfoEntry, ADbgValue);
if Result then
exit;
CU := InfoEntry.CompUnit;
if (CU <> nil) and InfoEntry.HasValidScope and
InfoEntry.ReadName(CurClassName) and not InfoEntry.IsArtificial
then begin
StaticName := FClassVarStaticPrefix + LowerCase(CurClassName) + '_' + UpperCase(AName);
MangledNameInfo := NameInfoForSearch(StaticName);
if CU.KnownNameHashes^[MangledNameInfo.NameHash and KnownNameHashesBitMask] then begin
if FindExportedSymbolInUnit(CU, MangledNameInfo, FoundInfoEntry, IsExternal) then begin
if {(IsExternal) and} (FoundInfoEntry.ReadName(FoundName)) then begin
if FoundName = StaticName then begin // must be case-sensitive
ADbgValue := SymbolToValue(TFpSymbolDwarf.CreateSubClass(AName, FoundInfoEntry));
Result := True;
end;
end;
FoundInfoEntry.ReleaseReference;
if Result then
exit;
end;
end;
end;
end;
procedure TFpDwarfFreePascalSymbolScope.Init;
begin
inherited Init;
FClassVarStaticPrefix := '_static_';
end;
destructor TFpDwarfFreePascalSymbolScope.Destroy;
begin
FOuterNestContext.ReleaseReference;
inherited Destroy;
end;
{ TFpDwarfFreePascalSymbolScopeDwarf3 }
procedure TFpDwarfFreePascalSymbolScopeDwarf3.Init;
begin
inherited Init;
FClassVarStaticPrefix := '$_static_';
end;
{ TFpSymbolDwarfV2FreePascalTypeStructure }
function TFpSymbolDwarfV2FreePascalTypeStructure.IsShortString: Boolean;

52
components/lazdebuggers/lazdebuggerfp/test/testwatches.pas
View File

@ -18,7 +18,7 @@ type
FEvalDone: Boolean;
procedure DoEvalDone(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
procedure RunToPause(var ABrk: TDBGBreakPoint);
procedure RunToPause(var ABrk: TDBGBreakPoint; ADisableBreak: Boolean = True);
published
procedure TestWatchesScope;
procedure TestWatchesValue;
@ -37,11 +37,13 @@ var
ControlTestWatchAddressOf, ControlTestWatchTypeCast, ControlTestModify,
ControlTestExpression, ControlTestErrors: Pointer;
procedure TTestWatches.RunToPause(var ABrk: TDBGBreakPoint);
procedure TTestWatches.RunToPause(var ABrk: TDBGBreakPoint;
ADisableBreak: Boolean);
begin
Debugger.RunToNextPause(dcRun);
AssertDebuggerState(dsPause);
ABrk.Enabled := False;
if ADisableBreak then
ABrk.Enabled := False;
end;
procedure TTestWatches.DoEvalDone(Sender: TObject; ASuccess: Boolean;
@ -1123,6 +1125,12 @@ for i := StartIdx to t.Count-1 do
for i := StartIdxClassConst to t.Count-1 do
t.Tests[i].SkipIf(ALoc in [tlClassConst]);
// Trigger a search through everything
t.Add('NotExistingFooBar123_X', weInteger(0))^.AddFlag(ehExpectError);
end;
var
@ -1130,7 +1138,7 @@ var
t: TWatchExpectationList;
Src: TCommonSource;
BrkPrg, BrkFooBegin, BrkFoo, BrkFooVar, BrkFooVarBegin,
BrkFooConstRef: TDBGBreakPoint;
BrkFooConstRef, BrkMethFoo, BrkBaseMethFoo: TDBGBreakPoint;
c, i: Integer;
begin
if SkipTest then exit;
@ -1158,6 +1166,9 @@ begin
BrkFooVarBegin := Debugger.SetBreakPoint(Src, 'FooVarBegin');
BrkFooVar := Debugger.SetBreakPoint(Src, 'FooVar');
BrkFooConstRef := Debugger.SetBreakPoint(Src, 'FooConstRef');
BrkMethFoo := Debugger.SetBreakPoint(Src, 'MethFoo'); // call with TMyClass
BrkBaseMethFoo := Debugger.SetBreakPoint(Src, 'BaseMethFoo'); // call with TMyClass
AssertDebuggerNotInErrorState;
(* ************ Nested Functions ************* *)
@ -1358,6 +1369,39 @@ if Compiler.Version < 030300 then
t.CheckResults;
RunToPause(BrkBaseMethFoo, False);
t.Clear;
t.Add('BaseMethFoo of TMyClass1 - ClassBaseVar1', 'ClassBaseVar1', weInteger(118));
// t.Add('BaseMethFoo of TMyClass1 - ClassVar1', 'ClassVar1', weInteger(119));
// Trigger a search through everything
t.Add('BaseMethFoo of NotExistingFooBar123_X', weInteger(0))^.AddFlag(ehExpectError);
//AddWatches(t, 'foo const ref args', 'argconstref', 001, 'B', tlParam);
t.EvaluateWatches;
t.CheckResults;
RunToPause(BrkMethFoo);
t.Clear;
t.Add('MethFoo of TMyClass1 - ClassBaseVar1', 'ClassBaseVar1', weInteger(118));
t.Add('MethFoo of TMyClass1 - ClassVar1', 'ClassVar1', weInteger(119));
// Trigger a search through everything
t.Add('MethFoo of TMyClass1 - NotExistingFooBar123_X', weInteger(0))^.AddFlag(ehExpectError);
//AddWatches(t, 'foo const ref args', 'argconstref', 001, 'B', tlParam);
t.EvaluateWatches;
t.CheckResults;
RunToPause(BrkBaseMethFoo);
t.Clear;
t.Add('BaseMethFoo of TMyBaseClass - ClassBaseVar1', 'ClassBaseVar1', weInteger(118));
// t.Add('BaseMethFoo of TMyBaseClass - ClassVar1', 'ClassVar1', weInteger(119));
// Trigger a search through everything
t.Add('BaseMethFoo of TMyBaseClass - NotExistingFooBar123_X', weInteger(0))^.AddFlag(ehExpectError);
//AddWatches(t, 'foo const ref args', 'argconstref', 001, 'B', tlParam);
t.EvaluateWatches;
t.CheckResults;
finally
Debugger.RunToNextPause(dcStop);
t.Free;

BIN
components/lazdebuggers/lazdebugtestbase/sources.res
View File

Binary file not shown.

29
components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas
View File

@ -13,6 +13,7 @@ program WatchesValuePrg;
{$hints off}
{$notes off}
{$warnings off}
{$inline off}
uses sysutils, Classes;
@ -68,7 +69,7 @@ type
var
BreakDummy: PtrUInt;
BreakDummy, BreakDummy2: PtrUInt;
PByteDummy: PByte;
p: Pointer;
pw: PWord; // ensure we have the type
@ -349,10 +350,13 @@ type
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=cl_v_, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
public
function SomeMeth1(SomeValue: Integer): Boolean;
procedure BaseMethFoo;
public
(* LOCATION: field in baseclass *)
// mbcByte: Byte;
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=mbc, _OP_=:, (=;//, _O2_=:, _EQ_=, _BLOCK_=TestVar )
public class var
ClassBaseVar1: integer;
end;
PMyBaseClass = ^TMyBaseClass;
@ -367,6 +371,9 @@ type
function SomeFuncIntRes(): Integer;
function SomeFuncIntResAdd(a: integer): Integer;
procedure MethFoo;
public class var
ClassVar1: integer;
end;
PMyClass = ^TMyClass;
@ -479,6 +486,18 @@ begin end;
function TMyBaseClass.SomeMeth1(SomeValue: Integer): Boolean;
begin result := SomeValue = 0; end;
procedure TMyBaseClass.BaseMethFoo;
begin
BreakDummy:= 112; // TEST_BREAKPOINT=BaseMethFoo
BreakDummy2 := ClassBaseVar1;
end;
procedure TMyClass.MethFoo;
begin
BreakDummy:= 113; // TEST_BREAKPOINT=MethFoo
BreakDummy2 := ClassVar1;
end;
procedure Foo(
(* LOCATION: param *)
TEST_PREPOCESS(WatchesValuePrgIdent.inc, pre__=arg, _OP_=:, (=;//, _O2_=:, _EQ_= , _BLOCK_=TestArg)
@ -969,5 +988,13 @@ begin
0
);
TMyClass.ClassBaseVar1 := 118;
TMyClass.ClassVar1 := 119;
MyClass1.BaseMethFoo();
MyClass1.MethFoo();
MyClass2.BaseMethFoo();
end.