paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-27 19:01:43 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revision(s) 59825 #35103e664b, 59870 #4d4aa06706 from trunk:

Browse Source 
FpDebug: Implement correct length for open-array params
........
FpDebug: Fixed Array of ShortString for dwarf2
........

git-svn-id: branches/fixes_2_0@59871 -
This commit is contained in:
martin 2018-12-19 23:00:27 +00:00
parent 67008a7ffa
commit 2a70f59029
2 changed files with 165 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
components/fpdebug/fpdbgdwarf.pas
View File

@ -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

190
components/fpdebug/fpdbgdwarffreepascal.pas
View File

@ -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;