mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-12-04 23:57:33 +01:00
FPDebug: tests
git-svn-id: trunk@43959 -
This commit is contained in:
martin
parent
7b11f22871
commit
82bb935fdd
@ -1,3 +1,248 @@
|
||||
This tool can be used to generate the dwarf setup data for the testcase.
|
||||
|
||||
Warning: Very slow
|
||||
|
||||
|
||||
|
||||
The output can be processed in the IDE with the below pas script macro.
|
||||
NOTE: avoid variables of the same name in different scopes.
|
||||
|
||||
|
||||
const
|
||||
AddressLen = 8; // chars in hex = 4 bytes
|
||||
VarNamePrefix = 'GLOBTESTSETUP1';
|
||||
VarNamePrefixRepl = 'GlobTestSetup1.Var';
|
||||
VarParamPrefix = '';
|
||||
VarParamPrefixRepl = 'TestStackFrame.';
|
||||
VarParamOffset = 'TestStackFrame.EndPoint';
|
||||
|
||||
|
||||
const HexDigits= '0123456789ABCDEF';
|
||||
|
||||
function IntToHex(Value: int64; Digits: integer): string;
|
||||
var i: integer;
|
||||
begin
|
||||
If Digits=0 then
|
||||
Digits:=1;
|
||||
SetLength(result, digits);
|
||||
for i := 0 to digits - 1 do
|
||||
begin
|
||||
result[digits - i] := HexDigits[(value and 15+1)];
|
||||
value := value shr 4;
|
||||
end ;
|
||||
while value <> 0 do begin
|
||||
result := HexDigits[(value and 15+1)] + result;
|
||||
value := value shr 4;
|
||||
end;
|
||||
end ;
|
||||
|
||||
function GetCurrentLineId: String;
|
||||
var p : TPoint;
|
||||
begin
|
||||
p := Caller.CaretXY;
|
||||
ecLineStart;
|
||||
caller.SelectWord;
|
||||
Result := caller.SelText;
|
||||
Caller.CaretXY := p;
|
||||
end;
|
||||
|
||||
function GetCurrentLineIndent: String;
|
||||
var p : TPoint;
|
||||
begin
|
||||
Result := '';
|
||||
if copy(caller.LineAtCaret, 1,1) <> ' ' then exit;
|
||||
p := Caller.CaretXY;
|
||||
Caller.CaretX := 1;
|
||||
ecSelWordRight;
|
||||
Result := caller.SelText;
|
||||
Caller.CaretXY := p;
|
||||
end;
|
||||
|
||||
function FindTAG(ATag: String; var StartPoint: TPoint; out ID: String): Boolean;
|
||||
begin
|
||||
Result := Caller.SearchReplaceEx('.Tag := '+ATag+';', '', [], StartPoint) > 0;
|
||||
if not Result Then exit;
|
||||
StartPoint := Caller.CaretXY;
|
||||
StartPoint.y := StartPoint.y + 1;
|
||||
ID := GetCurrentLineId;
|
||||
end;
|
||||
|
||||
function FindTAGEx(ATag, AnIndent: String; var StartPoint: TPoint; out ID: String): Boolean;
|
||||
begin
|
||||
repeat
|
||||
Result := Caller.SearchReplaceEx('.Tag := '+ATag+';', '', [], StartPoint) > 0;
|
||||
if not Result Then exit;
|
||||
if (Copy(caller.LineAtCaret, 1, length(AnIndent)) = AnIndent) and
|
||||
(Copy(caller.LineAtCaret, length(AnIndent),1) <> ' ')
|
||||
then exit;
|
||||
until not result;
|
||||
end;
|
||||
|
||||
function FindAttr(AnAttr, AnID: String; FindInLine: String): Boolean;
|
||||
var i: Integer;
|
||||
begin
|
||||
Result := Caller.SearchReplaceEx('^ *'+AnId+'\..*\('+AnAttr+' *,', '', [ssoRegExpr], Point(1,1)) > 0;
|
||||
if (not Result) or (FindInLine='') then exit;
|
||||
i := pos(FindInLine, caller.LineAtCaret);
|
||||
Result := i > 0;
|
||||
if not result then exit;
|
||||
Caller.LogicalCaretXY := Point(i, Caller.CaretY);
|
||||
end;
|
||||
|
||||
function FindName(AnID: String): String;
|
||||
begin
|
||||
Result := AnId;
|
||||
if not FindAttr('DW_AT_name', ANId, '+#0') then exit;
|
||||
while (Caller.LogicalCaretX > 1) and (caller.LineAtCaret[caller.LogicalCaretX] <> '''') do ecLeft;
|
||||
while (Caller.LogicalCaretX > 1) and (caller.LineAtCaret[caller.LogicalCaretX-1] <> '''') do ecSelLeft;
|
||||
Result := caller.SelText;
|
||||
end;
|
||||
|
||||
function PrefIxIdParagraph(AnId, ANewLine: String): Boolean;
|
||||
begin
|
||||
Result := Caller.SearchReplaceEx(AnId+' :=', '', [ssoWholeWord], Point(1,1)) > 0;
|
||||
if not Result Then exit;
|
||||
Caller.CaretX := 1; ecSelWordRight;
|
||||
if copy(caller.LineAtCaret, 1,1) = ' ' then
|
||||
ANewLine := caller.SelText+ ANewLine;
|
||||
Caller.CaretX := 1;
|
||||
caller.SelText := ANewLine + #13+#10;
|
||||
end;
|
||||
|
||||
function ReplaceHexAddrInLine(NewText: String): Boolean;
|
||||
var p,p2: TPoint;
|
||||
begin
|
||||
p := Caller.CaretXY;
|
||||
p2 := p; p2.x := 1;
|
||||
Result := Caller.SearchReplaceEx('\$[0-9a-f]+', '', [ssoRegExpr], p2) > 0;
|
||||
Result := Result and (Caller.CaretY = p.y);
|
||||
if Result then
|
||||
caller.SelText := NewText;
|
||||
Caller.CaretXY := p;
|
||||
end;
|
||||
|
||||
function ReplaceSLEBInLine(NewText: String): Boolean;
|
||||
var p,p2: TPoint;
|
||||
begin
|
||||
p := Caller.CaretXY;
|
||||
p2 := p; p2.x := 1;
|
||||
Result := Caller.SearchReplaceEx('SLEB\(-?[0-9]+\)', '', [ssoRegExpr], p2) > 0;
|
||||
Result := Result and (Caller.CaretY = p.y);
|
||||
if Result then
|
||||
caller.SelText := 'SLEB('+NewText+')';
|
||||
Caller.CaretXY := p;
|
||||
end;
|
||||
|
||||
function ReplacePreFix(AText, APrefix, ANew: String): String;
|
||||
begin
|
||||
Result := AText;
|
||||
if copy(Result,1,length(APrefix))=APrefix
|
||||
then Result := ANew+copy(Result,1+length(APrefix),length(Result));
|
||||
end;
|
||||
|
||||
var
|
||||
MainComment: String;
|
||||
UnitAddr, UnitIncr: Int64;
|
||||
UnitFoundPos : TPoint;
|
||||
UnitId, UnitName: string;
|
||||
|
||||
ProcAddr, ProcIncr: Int64;
|
||||
ProcFoundPos : TPoint;
|
||||
ProcEndLine: Integer;
|
||||
ProcId, ProcName: string;
|
||||
|
||||
VarFoundPos : TPoint;
|
||||
VarId, VarName, VarNewName: string;
|
||||
|
||||
p : TPoint;
|
||||
s:String;
|
||||
begin
|
||||
UnitAddr := $400000;
|
||||
UnitIncr := $100000;
|
||||
ProcAddr := $400000;
|
||||
ProcIncr := $001000;
|
||||
UnitFoundPos:=Point(1,1);
|
||||
|
||||
if FindTag('DW_TAG_compile_unit', UnitFoundPos, UnitId) then begin
|
||||
UnitName:=FindName(UnitId);
|
||||
|
||||
|
||||
if FindAttr('DW_AT_low_pc', UnitId, '') then begin
|
||||
if ReplaceHexAddrInLine('$'+inttohex(UnitAddr, AddressLen))
|
||||
then MainComment := MainComment + '// '+UnitName+' DW_AT_low_pc at $'+ inttohex(UnitAddr, AddressLen)+ #13+#10
|
||||
else MainComment := MainComment + '// '+UnitName+' DW_AT_low_pc at Addr NOT found'+ #13+#10;
|
||||
UnitAddr := UnitAddr + UnitIncr;
|
||||
end;
|
||||
if FindAttr('DW_AT_high_pc', UnitId, '') then begin
|
||||
ReplaceHexAddrInLine('$'+inttohex(UnitAddr-1, AddressLen));
|
||||
end;
|
||||
|
||||
|
||||
ProcFoundPos:=Point(1,1);
|
||||
while FindTag('DW_TAG_subprogram', ProcFoundPos, ProcId) do begin
|
||||
ProcName := FindName(ProcID);
|
||||
if FindAttr('DW_AT_low_pc', ProcId, '') then begin
|
||||
if ReplaceHexAddrInLine('$'+inttohex(ProcAddr, AddressLen))
|
||||
then MainComment := MainComment + '// '+ProcName+' DW_AT_low_pc at $'+ inttohex(ProcAddr, AddressLen)+ #13+#10
|
||||
else MainComment := MainComment + '// '+ProcName+' DW_AT_low_pc at Addr NOT found'+ #13+#10;
|
||||
ProcAddr := ProcAddr + ProcIncr;
|
||||
end;
|
||||
if FindAttr('DW_AT_high_pc', ProcId, '') then begin
|
||||
ReplaceHexAddrInLine('$'+inttohex(ProcAddr-1, AddressLen));
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
VarFoundPos:=Point(1,1);
|
||||
while FindTag('DW_TAG_variable', VarFoundPos, VarId) do begin
|
||||
VarName := FindName(VarID);
|
||||
if not( (VarName='this') or (VarName='result') or (VarName='self') or (VarName='vmt') ) then begin
|
||||
if FindAttr('DW_AT_location', VarId, 'SLEB') then begin
|
||||
// local var
|
||||
VarNewName := ReplacePreFix(VarName, VarParamPrefix, VarParamPrefixRepl);
|
||||
s := 'StackOffs := @'+VarNewName+' - @'+VarParamOffset+';'
|
||||
if ReplaceSLEBInLine('StackOffs')
|
||||
then MainComment := MainComment + '// param '+UnitName+'.'+VarName+' = ' + VarNewName+ #13+#10
|
||||
else MainComment := MainComment + '// param '+UnitName+'.'+VarName+' Addr NOT FOUND'+ #13+#10;
|
||||
PrefIxIdParagraph(VarID, s);
|
||||
end
|
||||
else
|
||||
if FindAttr('DW_AT_location', VarId, '$') then begin
|
||||
// Global var
|
||||
VarNewName := ReplacePreFix(VarName, VarNamePrefix, VarNamePrefixRepl);
|
||||
if ReplaceHexAddrInLine('@'+VarNewName)
|
||||
then MainComment := MainComment + '// var '+UnitName+'.'+VarName+' = ' + VarNewName+ #13+#10
|
||||
else MainComment := MainComment + '// var '+UnitName+'.'+VarName+' Addr NOT FOUND'+ #13+#10;
|
||||
end
|
||||
else
|
||||
MainComment := MainComment + '// var '+UnitName+'.'+VarName+' DW_AT_location NOT FOUND'+ #13+#10;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
VarFoundPos:=Point(1,1);
|
||||
while FindTag('DW_TAG_formal_parameter', VarFoundPos, VarId) do begin
|
||||
VarName := FindName(VarID);
|
||||
if not( (VarName='this') or (VarName='result') or (VarName='self') or (VarName='vmt') ) then begin
|
||||
if FindAttr('DW_AT_location', VarId, '') then begin
|
||||
VarNewName := ReplacePreFix(VarName, VarParamPrefix, VarParamPrefixRepl);
|
||||
s := 'StackOffs := @'+VarNewName+' - @'+VarParamOffset+';'
|
||||
if ReplaceSLEBInLine('StackOffs')
|
||||
then MainComment := MainComment + '// param '+UnitName+'.'+VarName+' = ' + VarNewName+ #13+#10
|
||||
else MainComment := MainComment + '// param '+UnitName+'.'+VarName+' Addr NOT FOUND'+ #13+#10;
|
||||
PrefIxIdParagraph(VarID, s);
|
||||
end
|
||||
else
|
||||
MainComment := MainComment + '// param '+UnitName+'.'+VarName+' DW_AT_location NOT FOUND'+ #13+#10;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end;
|
||||
|
||||
|
||||
Caller.LogicalCaretXY := Point(1,1);
|
||||
caller.SelText:=MainComment;
|
||||
end.
|
||||
98
components/fpdebug/test/testdata/dwarfsetup1.lpr
vendored
98
components/fpdebug/test/testdata/dwarfsetup1.lpr
vendored
@ -1,5 +1,11 @@
|
||||
program ProgFoo;
|
||||
{$mode objfpc}{$H+}
|
||||
{$IF FPC_FULLVERSION>=20701}
|
||||
{$OPTIMIZATION NOREMOVEEMPTYPROCS}
|
||||
{$OPTIMIZATION NOORDERFIELDS}
|
||||
{$ENDIF}
|
||||
{$OPTIMIZATION OFF}
|
||||
{$A2}
|
||||
|
||||
type
|
||||
|
||||
@ -14,17 +20,30 @@ type
|
||||
end;
|
||||
PTestSetup1Record = ^TTestSetup1Record;
|
||||
|
||||
TTestSetup1Record2 = record // same size
|
||||
FWord: Word;
|
||||
FBool: Boolean;
|
||||
FTest: TTestSetup1Class;
|
||||
end;
|
||||
PTestSetup1Record2 = ^TTestSetup1Record2;
|
||||
|
||||
TTestSetup1Record3 = record // other size
|
||||
FWord: Word;
|
||||
end;
|
||||
PTestSetup1Record3 = ^TTestSetup1Record3;
|
||||
|
||||
{ TTestSetup1Class }
|
||||
|
||||
TTestSetup1Class = class
|
||||
public
|
||||
FBool: Boolean;
|
||||
FWord: Word;
|
||||
FWordL: QWord;
|
||||
FInt: ShortInt;
|
||||
FIntL: Int64;
|
||||
FBool: Boolean;
|
||||
FTest: TTestSetup1Class;
|
||||
procedure f0(a:integer); virtual;
|
||||
FByte: Byte;
|
||||
procedure ClassProc0(a:integer); virtual;
|
||||
end;
|
||||
PTestSetup1Class = ^TTestSetup1Class;
|
||||
|
||||
@ -34,6 +53,13 @@ type
|
||||
end;
|
||||
PTestSetup1ClassChild = ^TTestSetup1ClassChild;
|
||||
|
||||
TTestSetup1Class2 = class
|
||||
public
|
||||
FInt: Integer;
|
||||
FWord: Word;
|
||||
end;
|
||||
PTestSetup1Class2 = ^TTestSetup1Class2;
|
||||
|
||||
TTestSetup1ClassClass = class of TTestSetup1Class;
|
||||
TTestSetup1ClassChildClass = class of TTestSetup1ClassChild;
|
||||
|
||||
@ -49,10 +75,42 @@ type
|
||||
FBool2: LongBool;
|
||||
FBool3: ByteBool;
|
||||
FTest: TTestSetup1Class;
|
||||
procedure f0(a:integer); virtual;
|
||||
procedure ObjProc0(o1:integer); virtual;
|
||||
//only with a wirtual method, will there be a vptr entry
|
||||
end;
|
||||
PTestSetup1Object = ^TTestSetup1Object;
|
||||
|
||||
{ TTestSetup1Object2 }
|
||||
|
||||
TTestSetup1Object2 = object // same size
|
||||
public
|
||||
FWord: Word;
|
||||
FWordL: QWord;
|
||||
FInt: ShortInt;
|
||||
FIntL: Int64;
|
||||
FBool: Boolean;
|
||||
FBool2: LongBool;
|
||||
FBool3: ByteBool;
|
||||
FTest: TTestSetup1Class;
|
||||
procedure ObjProc1(o2:integer); virtual;
|
||||
end;
|
||||
PTestSetup1Object2 = ^TTestSetup1Object2;
|
||||
|
||||
{ TTestSetup1Object3 }
|
||||
|
||||
TTestSetup1Object3 = object // diff size
|
||||
public
|
||||
FWord: Word;
|
||||
procedure ObjProc1(o2:integer); virtual;
|
||||
end;
|
||||
PTestSetup1Object3 = ^TTestSetup1Object3;
|
||||
|
||||
TTestSetup1Object4 = object // looks like a record....
|
||||
public
|
||||
FWord: Word;
|
||||
end;
|
||||
PTestSetup1Object4 = ^TTestSetup1Object4;
|
||||
|
||||
Pint = ^ integer;
|
||||
PPInt = ^Pint;
|
||||
PPPInt = ^PPint;
|
||||
@ -61,23 +119,35 @@ type
|
||||
var // Globals
|
||||
GlobTestSetup1Record: TTestSetup1Record;
|
||||
GlobTestSetup1RecordP: PTestSetup1Record;
|
||||
GlobTestSetup1Record2: TTestSetup1Record2;
|
||||
GlobTestSetup1Record2P: PTestSetup1Record2;
|
||||
GlobTestSetup1Record3: TTestSetup1Record3;
|
||||
GlobTestSetup1Record3P: PTestSetup1Record3;
|
||||
|
||||
GlobTestSetup1Class: TTestSetup1Class;
|
||||
GlobTestSetup1ClassP: PTestSetup1Class;
|
||||
GlobTestSetup1ClassChild: TTestSetup1ClassChild;
|
||||
GlobTestSetup1ClassChildP: PTestSetup1ClassChild;
|
||||
GlobTestSetup1Class2: TTestSetup1Class2;
|
||||
GlobTestSetup1Class2P: PTestSetup1Class2;
|
||||
GlobTestSetup1ClassClass: TTestSetup1ClassClass;
|
||||
GlobTestSetup1ClassChildClass: TTestSetup1ClassChildClass;
|
||||
|
||||
GlobTestSetup1Object: TTestSetup1Object;
|
||||
GlobTestSetup1ObjectP: PTestSetup1Object;
|
||||
GlobTestSetup1Object2: TTestSetup1Object2;
|
||||
GlobTestSetup1Object2P: PTestSetup1Object2;
|
||||
GlobTestSetup1Object3: TTestSetup1Object3;
|
||||
GlobTestSetup1Object3P: PTestSetup1Object3;
|
||||
GlobTestSetup1Object4: TTestSetup1Object4;
|
||||
GlobTestSetup1Object4P: PTestSetup1Object4;
|
||||
|
||||
GlobTestSetup1Pointer: Pointer;
|
||||
GlobTestSetup1QWord: QWord;
|
||||
|
||||
function TestSetup1Bar(
|
||||
ParamTestSetup1Record: TTestSetup1Record;
|
||||
ParamTestRecord: PTestSetup1Record;
|
||||
ParamTestSetup1RecordP: PTestSetup1Record;
|
||||
|
||||
ParamTestSetup1Class: TTestSetup1Class;
|
||||
ParamTestSetup1ClassP: PTestSetup1Class;
|
||||
@ -140,17 +210,31 @@ begin
|
||||
subr3 := #9;
|
||||
end;
|
||||
|
||||
{ TTestSetup1Object3 }
|
||||
|
||||
procedure TTestSetup1Class.f0(a: integer);
|
||||
procedure TTestSetup1Object3.ObjProc1(o2: integer);
|
||||
begin
|
||||
FWord := 0;//
|
||||
end;
|
||||
|
||||
{ TTestSetup1Object2 }
|
||||
|
||||
procedure TTestSetup1Object2.ObjProc1(o2: integer);
|
||||
begin
|
||||
FWord := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TTestSetup1Class.ClassProc0(a: integer);
|
||||
begin
|
||||
FWord := 0;
|
||||
end;
|
||||
|
||||
{ TTestSetup1Object }
|
||||
|
||||
procedure TTestSetup1Object.f0(a: integer);
|
||||
procedure TTestSetup1Object.ObjProc0(o1: integer);
|
||||
begin
|
||||
|
||||
FWord := 0;
|
||||
end;
|
||||
|
||||
begin
|
||||
|
||||
File diff suppressed because one or more lines are too long
@ -17,6 +17,9 @@ type
|
||||
TTestTypInfo = class(TTestCase)
|
||||
protected
|
||||
FDwarfInfo: TDbgDwarf;
|
||||
public
|
||||
//procedure SetUp; override;
|
||||
//procedure TearDown; override;
|
||||
published
|
||||
Procedure TestExpressions;
|
||||
procedure TestCompareUtf8BothCase;
|
||||
@ -253,7 +256,7 @@ begin
|
||||
FDwarfInfo.MemReader := MemReader;
|
||||
//////////////////////////////////////////////////////////
|
||||
|
||||
Ctx := FDwarfInfo.FindContext($00401010);
|
||||
Ctx := FDwarfInfo.FindContext(TTestSetup1ProcBarAddr);
|
||||
AssertTrue('got ctx', Ctx <> nil);
|
||||
|
||||
sym := Ctx.FindSymbol('Int1');
|
||||
@ -402,6 +405,7 @@ begin
|
||||
ImageLoader.TestStackFrame.VParamTestSetup1Class := @ImageLoader.TestStackFrame.Obj1;
|
||||
ImageLoader.TestStackFrame.VParamTestSetup1ClassP := @ImageLoader.TestStackFrame.PObj1;
|
||||
Obj1.FWord := 1019;
|
||||
Obj1.FBool := Boolean($9aa99aa9); // Make sure there is data, if other fields read to much
|
||||
Obj1.FWordL := QWord($9aa99aa97bb7b77b); // Make sure there is data, if other fields read to much
|
||||
|
||||
for i := 0 to 23 do begin
|
||||
|
||||
Loading…
Reference in New Issue
Block a user