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

FpDebug: Fix subtraction for some pointers / Fix type-info for @char, so minus considers them compatible.

Browse Source
This commit is contained in:
Martin 2022-12-05 19:51:16 +01:00
parent 1e302eb754
commit 55f314c9ac
7 changed files with 117 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/fpdebug/fpdbgdwarf.pas
View File

@ -317,12 +317,12 @@ type
TFpValueDwarfPointer = class(TFpValueDwarfNumeric)
private
FPointedToAddr: TFpDbgMemLocation;
function GetDerefAddress: TFpDbgMemLocation;
protected
function GetAsCardinal: QWord; override;
procedure SetAsCardinal(AValue: QWord); override;
function GetFieldFlags: TFpValueFieldFlags; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetDerefAddress: TFpDbgMemLocation; override;
function GetAsString: AnsiString; override;
function GetAsWideString: WideString; override;
function GetMember(AIndex: Int64): TFpValue; override;

4
components/fpdebug/fpdbgdwarffreepascal.pas
View File

@ -899,9 +899,9 @@ function TFpSymbolDwarfFreePascalTypePointer.GetDataAddressNext(
AValueObj: TFpValueDwarf; var AnAddress: TFpDbgMemLocation; out
ADoneWork: Boolean; ATargetType: TFpSymbolDwarfType): Boolean;
begin
if (not IsInternalPointer) and (ATargetType = nil) then exit(True);
Result := inherited GetDataAddressNext(AValueObj, AnAddress, ADoneWork, ATargetType);
if (not IsInternalPointer) and (ATargetType = nil) then exit;
if (not Result) or ADoneWork then
exit;

18
components/fpdebug/fpdbginfo.pas
View File

@ -133,6 +133,7 @@ type
function GetAddress: TFpDbgMemLocation; virtual;
function DoGetSize(out ASize: TFpDbgValueSize): Boolean; virtual;
function GetDataAddress: TFpDbgMemLocation; virtual;
function GetDerefAddress: TFpDbgMemLocation; virtual;
function GetDataSize: TFpDbgValueSize; virtual;
function GetHasBounds: Boolean; virtual;
@ -174,10 +175,11 @@ type
* DataAddress/DataSize
Address of Data, if avail and diff from Address (e.g. String, TObject, DynArray, ..., BUT NOT record)
Otherwise same as Address/Size
For pointers, this is the address of the pointed-to data
For pointers, this is the same as Address (Not DerefAddress)
*)
property Address: TFpDbgMemLocation read GetAddress;
property DataAddress: TFpDbgMemLocation read GetDataAddress; //
property DerefAddress: TFpDbgMemLocation read GetDerefAddress; //
property DataSize: TFpDbgValueSize read GetDataSize;
property HasBounds: Boolean read GetHasBounds;
@ -236,6 +238,7 @@ type
public
destructor Destroy; override;
procedure SetTypeName(AName: String);
procedure SetType(AType: TFpSymbol);
procedure SetAddress(AnAddress: TFpDbgMemLocation);
end;
@ -1087,6 +1090,11 @@ begin
Result := Address;
end;
function TFpValue.GetDerefAddress: TFpDbgMemLocation;
begin
Result := InvalidLoc;
end;
function TFpValue.GetDataSize: TFpDbgValueSize;
begin
if not GetSize(Result) then
@ -1183,6 +1191,14 @@ begin
FType.SetName(AName);
end;
procedure TFpValueConstWithType.SetType(AType: TFpSymbol);
begin
assert(FType=nil, 'TFpValueConstWithType.SetType: FType=nil');
FType := AType;
if FType <> nil then
FType.AddReference;
end;
procedure TFpValueConstWithType.SetAddress(AnAddress: TFpDbgMemLocation);
begin
FValAddress := AnAddress;

21
components/fpdebug/fppascalparser.pas
View File

@ -602,7 +602,7 @@ type
function GetTypeInfo: TFpSymbol; override;
function GetAsCardinal: QWord; override;
function GetAddress: TFpDbgMemLocation; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetDerefAddress: TFpDbgMemLocation; override;
function GetMember(AIndex: Int64): TFpValue; override;
public
constructor Create(AValue: TFpValue; ATypeInfo: TFpSymbol; AContext: TFpDbgLocationContext);
@ -665,7 +665,7 @@ type
function GetAsInteger: Int64; override;
function GetAsCardinal: QWord; override;
function GetTypeInfo: TFpSymbol; override;
function GetDataAddress: TFpDbgMemLocation; override;
function GetDerefAddress: TFpDbgMemLocation; override;
function GetMember(AIndex: Int64): TFpValue; override;
function GetAsString: AnsiString; override;
function GetAsWideString: WideString; override;
@ -779,7 +779,7 @@ begin
Result := FValue.Address;
end;
function TFpPasParserValueCastToPointer.GetDataAddress: TFpDbgMemLocation;
function TFpPasParserValueCastToPointer.GetDerefAddress: TFpDbgMemLocation;
begin
Result := TargetLoc(TDbgPtr(AsCardinal));
end;
@ -794,7 +794,7 @@ begin
Result := nil;
ti := FTypeSymbol.TypeInfo;
addr := DataAddress;
addr := DerefAddress;
if not IsTargetAddr(addr) then begin
//LastError := CreateError(fpErrAnyError, ['Internal dereference error']);
exit;
@ -916,8 +916,7 @@ end;
function TFpPasParserValueDerefPointer.GetAddress: TFpDbgMemLocation;
begin
Result := FValue.DataAddress;
Result := Context.ReadAddress(Result, SizeVal(Context.SizeOfAddress));
Result := FValue.DerefAddress;
if IsValidLoc(Result) then begin
SetLastError(Context.LastMemError);
exit;
@ -1053,7 +1052,7 @@ begin
Result := FTypeInfo;
end;
function TFpPasParserValueAddressOf.GetDataAddress: TFpDbgMemLocation;
function TFpPasParserValueAddressOf.GetDerefAddress: TFpDbgMemLocation;
begin
Result := FValue.Address;
end;
@ -1349,6 +1348,8 @@ begin
end;
TmpVal2 := TFpValueConstChar.Create(v[Offs]);
if TmpVal.TypeInfo <> nil then
TFpValueConstChar(TmpVal2).SetType(TmpVal.TypeInfo.TypeInfo);
a := TmpVal.DataAddress;
if IsTargetAddr(a) and IsReadableMem(a) then
TFpValueConstChar(TmpVal2).SetAddress(a + Offs-1);
@ -3299,7 +3300,7 @@ begin
end
else
if tmp.Kind = skPointer then begin
if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DataAddress)) and // TODO, what if Not readable addr
if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DerefAddress)) and // TODO, what if Not readable addr
(tmp.TypeInfo <> nil) //and (tmp.TypeInfo.TypeInfo <> nil)
then begin
Result := tmp.Member[0];
@ -3424,7 +3425,7 @@ function TFpPascalExpressionPartOperatorPlusMinus.DoGetResultValue: TFpValue;
(s1 = s2)
then begin
TmpVal := APointerVal.Member[1];
if s1 <> (TmpVal.DataAddress.Address - APointerVal.DataAddress.Address) then begin
if (TmpVal = nil) or (s1 <> (TmpVal.Address.Address - APointerVal.DerefAddress.Address)) then begin
TmpVal.ReleaseReference;
debugln(DBG_WARNINGS, 'Size mismatch for pointer math');
exit;
@ -4117,7 +4118,7 @@ begin
// Copy from TFpPascalExpressionPartOperatorDeRef.DoGetResultValue
tmp2 := nil;
if tmp.Kind = skPointer then begin
if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DataAddress)) and // TODO, what if Not readable addr
if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DerefAddress)) and // TODO, what if Not readable addr
(tmp.TypeInfo <> nil) //and (tmp.TypeInfo.TypeInfo <> nil)
then begin
tmp := tmp.Member[0];

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

@ -3513,6 +3513,24 @@ begin
t.Add('Pointer-Op: ', '^Word(10)-^Word(4)', weInteger(3));
t.Add('Pointer-Op: ', '^Word(10)-Pointer(4)', weInteger(3)).ExpectError();
t.Add('Pointer-Op: ', '^Char(10)-^Char(4)', weInteger(6));
t.Add('Pointer-Op: ', '^Char(10)-PChar(4)', weInteger(6));
t.Add('Pointer-Op: ', 'PChar(10)-^Char(4)', weInteger(6));
t.Add('Pointer-Op: ', 'PChar(10)-PChar(4)', weInteger(6));
t.Add('Pointer-Op: ', 'gvPChar3-gvPChar2', weInteger(3));
t.Add('Pointer-Op: ', 'PChar(@gvAnsi2[3])-PChar(gvAnsi2)', weInteger(2)).ChrIdxExpString(stDwarf2);
t.Add('Pointer-Op: ', '^Char(@gvAnsi2[3])-^Char(gvAnsi2)', weInteger(2)).ChrIdxExpString(stDwarf2);
t.Add('Pointer-Op: ', '@gvAnsi2[3]-@gvAnsi2[1]', weInteger(2)).ChrIdxExpString(stDwarf2);
t.Add('Pointer-Op: ', '@gvAnsi2[3]-@gvPChar2[1]', weInteger(1))
.ChrIdxSkip(stDwarf2) //skip
.ChrIdxExpPChar(stDwarf3Up);
t.Add('Pointer-Op: ', '@gvAnsi2[3]-gvPChar2', weInteger(2)).ChrIdxExpString();
t.Add('Pointer-Op: ', '@gvPChar2[3]-@gvPChar2[1]', weInteger(2)).ChrIdxExpPChar();
t.Add('Pointer-Op: ', '@gvPChar3[2]-@gvPChar2[1]', weInteger(4)).ChrIdxExpPChar();
t.Add('Pointer-Op: ', 'gcPtr2 - gcPtr1', weInteger(1000));
t.Add('Pointer-Op: ', 'gcPtr2 - gvPtr1', weInteger(1000));
t.Add('Pointer-Op: ', 'gvPtr2 - gcPtr2', weInteger(1));

2
components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrgIdent.inc
View File

@ -103,8 +103,10 @@
pre__PChar{e} _OP_ PChar ( nil ); //@@ _pre3_PChar{e3};
pre__PChar2{e} _OP_ TPChr ( nil ); //@@ _pre3_PChar2{e3};
pre__PChar3{e} _OP_ TPChr ( nil ); //@@ _pre3_PChar2{e3};
{$IFDEF TestAssign}
pre__PChar2{e} := @pre__Ansi2{e}[1]; //@@ _pre3_PChar2{e3}; // }
pre__PChar3{e} := @pre__Ansi2{e}[4]; //@@ _pre3_PChar2{e3}; // }
{$ENDIF}
pre__WideChar{e} _OP_ char (CHR1 ); //@@ _pre3_WideChar{e3};

66
components/lazdebuggers/lazdebugtestbase/ttestwatchutilities.pas
View File

@ -44,6 +44,10 @@ type
ehNoCharQuoting, // unprintable chars are already escaped/quoted
ehCharFromIndex, // Debugger is allowed Pchar: 'x' String 'y'
ehChrIdxExpString, // Use "String" *IF* Debugger returns Pchar: 'x' String 'y'
ehChrIdxExpPChar, // Use "PChar" *IF* Debugger returns Pchar: 'x' String 'y'
ehChrIdxSkip, // SKIP checks " *IF* Debugger returns Pchar: 'x' String 'y'
//ehChrIdxOnly, // SKIP checks " *UNLESS* Debugger returns Pchar: 'x' String 'y'
ehNoFieldOrder, // structure: fields can be in any order
ehMissingFields, // structure: fields may have gaps
@ -94,6 +98,9 @@ type
function MatchTypeName(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function CharFromIndex(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function ChrIdxExpString(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function ChrIdxExpPChar(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function ChrIdxSkip(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function ExpectNotFound(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
function ExpectError(ASymTypes: TSymbolTypes = []): TWatchExpectationResult;
@ -189,6 +196,9 @@ type
function NoCharQuoting(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function CharFromIndex(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function ChrIdxExpString(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function ChrIdxExpPChar(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function ChrIdxSkip(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function ExpectNotFound(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
function ExpectError(ASymTypes: TSymbolTypes = []; ACond: Boolean = True): PWatchExpectation;
@ -919,6 +929,24 @@ begin
Result := Self.AddFlag(ehCharFromIndex, ASymTypes);
end;
function TWatchExpectationResult.ChrIdxExpString(ASymTypes: TSymbolTypes
): TWatchExpectationResult;
begin
Result := Self.AddFlag(ehChrIdxExpString, ASymTypes);
end;
function TWatchExpectationResult.ChrIdxExpPChar(ASymTypes: TSymbolTypes
): TWatchExpectationResult;
begin
Result := Self.AddFlag(ehChrIdxExpPChar, ASymTypes);
end;
function TWatchExpectationResult.ChrIdxSkip(ASymTypes: TSymbolTypes
): TWatchExpectationResult;
begin
Result := Self.AddFlag(ehChrIdxSkip, ASymTypes);
end;
function TWatchExpectationResult.ExpectNotFound(ASymTypes: TSymbolTypes
): TWatchExpectationResult;
begin
@ -1073,6 +1101,27 @@ begin
Result := Self^.AddFlag(ehCharFromIndex, ASymTypes);
end;
function TWatchExpectationHelper.ChrIdxExpString(ASymTypes: TSymbolTypes;
ACond: Boolean): PWatchExpectation;
begin
if not ACond then exit(Self);
Result := Self^.AddFlag(ehChrIdxExpString, ASymTypes);
end;
function TWatchExpectationHelper.ChrIdxExpPChar(ASymTypes: TSymbolTypes;
ACond: Boolean): PWatchExpectation;
begin
if not ACond then exit(Self);
Result := Self^.AddFlag(ehChrIdxExpPChar, ASymTypes);
end;
function TWatchExpectationHelper.ChrIdxSkip(ASymTypes: TSymbolTypes;
ACond: Boolean): PWatchExpectation;
begin
if not ACond then exit(Self);
Result := Self^.AddFlag(ehChrIdxSkip, ASymTypes);
end;
function TWatchExpectationHelper.ExpectNotFound(ASymTypes: TSymbolTypes; ACond: Boolean): PWatchExpectation;
begin
if not ACond then exit(Self);
@ -1375,6 +1424,23 @@ begin
Stack := TstStackFrame;
WatchVal := TstWatch.Values[Thread, Stack];
Context.WatchRes := WatchVal.ResultData;
if (Context.WatchRes <> nil) and
(Context.WatchRes.ValueKind = rdkPCharOrString)
then begin
if ehChrIdxExpPChar in ehf then begin
Context.WatchRes.SetSelectedIndex(0);
Context.WatchRes := Context.WatchRes.SelectedEntry;
end
else
if ehChrIdxExpString in ehf then begin
Context.WatchRes.SetSelectedIndex(1);
Context.WatchRes := Context.WatchRes.SelectedEntry;
end;
if ehChrIdxSkip in ehf then
exit;
end;
if (Context.WatchRes <> nil) and
(Context.WatchRes.ValueKind = rdkConvertRes) and
(Context.WatchRes.FieldCount > 0)