paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 13:39:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

Debugger: Converter, match "*" and inheritance via "is:"

Browse Source
This commit is contained in:
Martin 2022-08-01 18:39:58 +02:00
parent bca093c6ec
commit 48043da966
3 changed files with 158 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
components/fpdebug/fpdbgdwarffreepascal.pas
View File

@ -157,10 +157,13 @@ type
//function GetInstanceClass(AValueObj: TFpValueDwarf): TFpSymbolDwarf; override;
class function GetInstanceClassNameFromPVmt(APVmt: TDbgPtr;
AContext: TFpDbgLocationContext; ASizeOfAddr: Integer;
out AClassName: String; out AnError: TFpError): boolean;
out AClassName: String; out AnError: TFpError;
AParentClassIndex: integer = 0;
ACompilerVersion: Cardinal = 0): boolean;
public
function GetInstanceClassName(AValueObj: TFpValue; out
AClassName: String): boolean; override;
AClassName: String;
AParentClassIndex: integer = 0): boolean; override;
end;
(* *** Record vs ShortString *** *)
@ -965,7 +968,8 @@ begin
end;
function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassName(
AValueObj: TFpValue; out AClassName: String): boolean;
AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer
): boolean;
var
AnErr: TFpError;
begin
@ -973,21 +977,27 @@ begin
if not Result then
exit;
Result := GetInstanceClassNameFromPVmt(LocToAddrOrNil(AValueObj.DataAddress),
TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress, AClassName, AnErr);
TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress,
AClassName, AnErr, AParentClassIndex,
TFpDwarfFreePascalSymbolClassMap(CompilationUnit.DwarfSymbolClassMap).FCompilerVersion
);
if not Result then
SetLastError(AValueObj, AnErr);
end;
class function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassNameFromPVmt
(APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; out
AClassName: String; out AnError: TFpError): boolean;
AClassName: String; out AnError: TFpError; AParentClassIndex: integer;
ACompilerVersion: Cardinal): boolean;
var
VmtAddr, ClassNameAddr: TFpDbgMemLocation;
VmtAddr, ClassNameAddr, A: TFpDbgMemLocation;
NameLen: QWord;
begin
Result := False;
AnError := NoError;
AClassName := '';
if not AContext.ReadAddress(TargetLoc(APVmt), SizeVal(ASizeOfAddr), VmtAddr) then begin
AnError := AContext.LastMemError;
exit;
@ -996,6 +1006,37 @@ begin
AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
exit;
end;
while AParentClassIndex > 0 do begin
{$PUSH}{$Q-}
VmtAddr.Address := VmtAddr.Address + TDBGPtr(2 * ASizeOfAddr);
{$POP}
A := VmtAddr;
if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin
AnError := AContext.LastMemError;
exit;
end;
if not IsReadableMem(VmtAddr) then begin
AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
exit;
end;
if (ACompilerVersion >= $030200)
then begin
A := VmtAddr;
if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin
AnError := AContext.LastMemError;
exit;
end;
if not IsReadableMem(VmtAddr) then begin
AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
exit;
end;
end;
dec(AParentClassIndex);
end;
{$PUSH}{$Q-}
VmtAddr.Address := VmtAddr.Address + TDBGPtr(3 * ASizeOfAddr);
{$POP}

19
components/fpdebug/fpdbginfo.pas
View File

@ -187,7 +187,7 @@ type
public
function GetTypeCastedValue(ADataVal: TFpValue): TFpValue; virtual; // only if Symbol is a type
function GetInstanceClassName(out AClassName: String): boolean; virtual;
function GetInstanceClassName(out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual;
// base class? Or Member includes member from base
(* Member:
@ -463,7 +463,7 @@ type
//
property Flags: TDbgSymbolFlags read GetFlags;
property Parent: TFpSymbol read GetParent; deprecated;
function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; virtual;
function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual;
// for Subranges // Type-Symbols only?
// TODO: flag bounds as cardinal if needed
@ -508,7 +508,7 @@ type
function GetNestedSymbolByName(const AIndex: String): TFpSymbol; override;
function GetNestedSymbolCount: Integer; override;
public
function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; override;
function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; override;
function GetValueBounds(AValueObj: TFpValue; out ALowBound, AHighBound: Int64): Boolean; override;
function GetValueLowBound(AValueObj: TFpValue; out ALowBound: Int64): Boolean; override;
function GetValueHighBound(AValueObj: TFpValue; out AHighBound: Int64): Boolean; override;
@ -929,14 +929,15 @@ begin
Result := nil;
end;
function TFpValue.GetInstanceClassName(out AClassName: String): boolean;
function TFpValue.GetInstanceClassName(out AClassName: String;
AParentClassIndex: integer): boolean;
var
ti: TFpSymbol;
begin
ti := TypeInfo;
Result := ti <> nil;
if Result then
Result := ti.GetInstanceClassName(Self, AClassName);
Result := ti.GetInstanceClassName(Self, AClassName, AParentClassIndex);
end;
procedure TFpValue.ResetError;
@ -1396,7 +1397,7 @@ begin
end;
function TFpSymbol.GetInstanceClassName(AValueObj: TFpValue; out
AClassName: String): boolean;
AClassName: String; AParentClassIndex: integer): boolean;
begin
AClassName := '';
Result := False;
@ -1777,15 +1778,15 @@ begin
end;
function TFpSymbolForwarder.GetInstanceClassName(AValueObj: TFpValue; out
AClassName: String): boolean;
AClassName: String; AParentClassIndex: integer): boolean;
var
p: TFpSymbol;
begin
p := GetForwardToSymbol;
if p <> nil then
Result := p.GetInstanceClassName(AValueObj, AClassName)
Result := p.GetInstanceClassName(AValueObj, AClassName, AParentClassIndex)
else
Result := inherited GetInstanceClassName(AValueObj, AClassName);
Result := inherited GetInstanceClassName(AValueObj, AClassName, AParentClassIndex);
end;
function TFpSymbolForwarder.GetValueBounds(AValueObj: TFpValue; out

108
components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas
View File

@ -6,9 +6,9 @@ interface
uses
Classes, SysUtils, fgl, FpDbgInfo, FpdMemoryTools, FpDbgCallContextInfo,
FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, DbgIntfBaseTypes,
lazCollections, LazClasses, LCLProc, FpDebugDebuggerBase,
LazDebuggerIntfBaseTypes;
FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil,
DbgIntfBaseTypes, lazCollections, LazClasses, LCLProc, StrUtils,
FpDebugDebuggerBase, LazDebuggerIntfBaseTypes;
type
TDbgSymbolKinds = set of TDbgSymbolKind;
@ -59,6 +59,7 @@ type
procedure Assign(ASource: TFpDbgConverterConfig); virtual;
function CheckMatch(AValue: TFpValue): Boolean;
function CheckTypeMatch(AValue: TFpValue): Boolean;
property Converter: TFpDbgValueConverter read FConverter write SetConverter;
property MatchKinds: TDbgSymbolKinds read FMatchKinds write FMatchKinds;
@ -212,11 +213,104 @@ var
t: TFpSymbol;
TpName: String;
begin
t := AValue.TypeInfo;
Result := (AValue.Kind in (FMatchKinds * Converter.GetSupportedKinds)) and
(t <> nil) and
GetTypeName(TpName, t, [tnfNoSubstitute]) and
(FMatchTypeNames.IndexOf(TpName) >= 0);
CheckTypeMatch(AValue);
end;
function TFpDbgConverterConfig.CheckTypeMatch(AValue: TFpValue): Boolean;
function MatchPattern(const AName, APattern: String): Boolean;
var
NamePos, PatternPos, p: Integer;
begin
Result := False;
if APattern = '' then
exit;
NamePos := 1;
PatternPos := 1;
while PatternPos <= Length(APattern) do begin
if APattern[PatternPos] = '*' then begin
inc(PatternPos);
end
else begin
p := PatternPos;
PatternPos := PosEx('*', APattern, p);
if PatternPos < 1 then
PatternPos := Length(APattern)+1;
if PatternPos-p > Length(AName)+1 - NamePos then
break;
NamePos := PosEx(Copy(APattern, p, PatternPos-p), AName, NamePos);
if (NamePos < 1) or
( (p = 1) and (NamePos <> 1) ) // APattern does not start with *
then
break;
inc(NamePos, PatternPos-p);
end;
end;
Result := (PatternPos = Length(APattern)+1) and
( (NamePos = Length(AName)+1) or
( (APattern[Length(APattern)] = '*') and
(NamePos <= Length(AName)+1)
)
);
end;
var
i, CnIdx: Integer;
TpName, Pattern, ValClassName: String;
t: TFpSymbol;
begin
t := AValue.TypeInfo;
Result := (t <> nil) and GetTypeName(TpName, t, [tnfNoSubstitute]);
if not Result then
exit;
TpName := LowerCase(TpName);
i := FMatchTypeNames.Count;
while i > 0 do begin
dec(i);
Pattern := LowerCase(trim(FMatchTypeNames[i]));
if AnsiStrLIComp('is:', @Pattern[1], 3) = 0 then begin
Delete(Pattern, 1, 3);
Pattern := trim(Pattern);
if (AValue.Kind in [skRecord, skClass, skObject, skInterface]) then begin
ValClassName := TpName;
while t <> nil do begin
Result := MatchPattern(ValClassName, Pattern);
if Result then
exit;
t := t.TypeInfo;
if (t = nil) or not GetTypeName(ValClassName, t, [tnfNoSubstitute]) then
break;
ValClassName := LowerCase(ValClassName);
end;
CnIdx := 0;
while AValue.GetInstanceClassName(ValClassName, CnIdx) and
(ValClassName <> '')
do begin
ValClassName := LowerCase(ValClassName);
if ValClassName = TpName then
Break;
Result := MatchPattern(ValClassName, Pattern);
if Result then
exit;
inc(CnIdx);
end;
Continue;
end;
end;
Result := MatchPattern(TpName, Pattern);
if Result then
exit;
end;
end;
{ TFpDbgConverterConfigList }