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

Debugger: Fix parsing class with nested record / array of record

Browse Source 
git-svn-id: trunk@43317 -
This commit is contained in:
martin 2013-10-24 20:38:48 +00:00
parent 40b4393fe1
commit 60810fa307
4 changed files with 140 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
debugger/gdbtypeinfo.pp
View File

@ -2310,7 +2310,7 @@ var
{%region * Class * }
procedure DoClass;
var
n, i: Integer;
n, i, j, l: Integer;
S, S2: String;
Name: String;
@ -2387,16 +2387,36 @@ var
else begin
Name := GetPart([' '], [' '], S);
S2 := GetPart([' : '], [';'], S);
if (lowercase(copy(S2, 1, 7)) = 'record ') then begin
l := Length(S2);
j := 1;
while true do begin
while (j <= l) and (S2[j] in ['^','(', ' ']) do inc(j);
if (lowercase(copy(S2, j, 7)) = 'array [') then begin
inc(j, 8+3);
while (j <= l) and
not ( (S2[j-3] = ' ') and (S2[j-2] in ['o','O']) and (S2[j-1] in ['f','F']) and (S2[j] = ' ') )
do
inc(j);
continue;
end;
break;
end;
if (lowercase(copy(S2, j, 7)) = 'record ') and
not( (copy(S2, j+7, 1) = ';') or (copy(S2, j+7, 6) = '{...};') )
then begin
i := 1;
while (n < Lines.Count - 2) and (i > 0) do
begin
inc(n);
S := Lines[n];
if S = '' then Continue;
if pos(': record ', S) > 0 then inc(i);
if pos(' end;', S) > 0 then dec(i);
S2 := S2 + ' ' + Trim(S);
j := pos(': record ', S);
if (j > 0) and not( (copy(S, j+9, 1) = ';') or (copy(S, j+9, 6) = '{...};') )
then
inc(i);
S := Trim(S);
if (pos('end;', S) = 1) or (pos('end)', S) = 1) then dec(i);
S2 := S2 + ' ' + S;
end;
end;
DBGType := TGDBType.Create(skSimple, S2);

18
debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc
View File

@ -423,8 +423,26 @@
{%region TYPE}
{$IFDEF Global_Type}
TFooStatArray = Array[3..7] of boolean;
TFooDynArray = Array of boolean;
TString25 = string[25];
TFooTestRecord = record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
TFoo = class
private
a1: TFooStatArray;
a2: TFooDynArray;
a3: Array[3..7, 2..4] of boolean;
a4: Array of Array of boolean;
a5: array [1..2] of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
a6: array [1..2,3..4] of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
a7: array of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
a8: array of array of record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
r1: record x1:boolean; x2:integer; xr: record x1:boolean; x2:integer; end; end;
r2: TFooTestRecord;
s1: string[25];
s2: TString25;
function GetValueInt: Integer;
procedure SetValueInt(AValue: Integer);
public

1
debugger/test/Gdbmi/testbase.pas
View File

@ -34,6 +34,7 @@ const
stDwarf2All = [stDwarf, stDwarfSet];
stDwarfAll = [stDwarf, stDwarfSet, stDwarf3];
stSymAll = [stStabs, stDwarf, stDwarfSet, stDwarf3];
type

106
debugger/test/Gdbmi/testwatches.pas
View File

@ -62,7 +62,8 @@ type
fTstSkip, // Do not run test
fTstSkipDwarf3,
fTpMtch
fTpMtch,
fTExpectNotFound
);
TWatchExpectationFlags = set of TWatchExpectationFlag;
@ -103,6 +104,14 @@ const
type
TFullTypeMemberExpectationResult = record
Name: string;
ExpTypeName: string;
ExpKind: TDBGSymbolKind;
Flgs: TWatchExpectationFlags;
end;
TFullTypeMemberExpectationResultArray = array of TFullTypeMemberExpectationResult;
PWatchExpectation= ^TWatchExpectation;
TWatchExpectationResult = record
ExpMatch: string;
@ -110,6 +119,7 @@ type
ExpTypeName: string;
Flgs: TWatchExpectationFlags;
MinGdb, MinFpc: Integer;
FullTypesExpect: TFullTypeMemberExpectationResultArray;
end;
TWatchExpectation = record
@ -128,6 +138,8 @@ type
TTestWatches = class(TGDBTestCase)
private
FWatches: TcurrentWatches;
Frx: TRegExpr;
ExpectBreakFooGdb: TWatchExpectationArray; // direct commands to gdb, to check assumptions // only Exp and Mtch
ExpectBreakSubFoo: TWatchExpectationArray; // Watches, evaluated in SubFoo (nested)
@ -212,6 +224,11 @@ type
procedure UpdResMinGdb(AWatchExp: PWatchExpectation; ASymbolTypes: TSymbolTypes; AMinGdb: Integer);
procedure UpdResMinFpc(AWatchExp: PWatchExpectation; ASymbolTypes: TSymbolTypes; AMinFpc: Integer);
procedure AddMemberExpect(AWatchExp: PWatchExpectation;
AName, ATpNm: string; AFlgs: TWatchExpectationFlags; AnExpKind: TDBGSymbolKind;
ASymbolTypes: TSymbolTypes = stSymAll
);
procedure AddExpectBreakFooGdb;
procedure AddExpectBreakFooAll;
procedure AddExpectBreakFooArray;
@ -498,6 +515,23 @@ begin
UpdResMinFpc(AWatchExp, i, AMinFpc);
end;
procedure TTestWatches.AddMemberExpect(AWatchExp: PWatchExpectation; AName, ATpNm: string;
AFlgs: TWatchExpectationFlags; AnExpKind: TDBGSymbolKind; ASymbolTypes: TSymbolTypes);
var
i: TSymbolType;
l: Integer;
begin
for i := low(TSymbolType) to high(TSymbolType) do
if i in ASymbolTypes then begin
l := length(AWatchExp^.Result[i].FullTypesExpect);
SetLength(AWatchExp^.Result[i].FullTypesExpect, l + 1);
AWatchExp^.Result[i].FullTypesExpect[l].Name := AName;
AWatchExp^.Result[i].FullTypesExpect[l].ExpTypeName := ATpNm;
AWatchExp^.Result[i].FullTypesExpect[l].ExpKind := AnExpKind;
AWatchExp^.Result[i].FullTypesExpect[l].Flgs := AFlgs;
end;
end;
procedure TTestWatches.UpdResMinGdb(AWatchExp: PWatchExpectation; ASymbolType: TSymbolType;
AMinGdb: Integer);
begin
@ -893,6 +927,14 @@ begin
// if (DebuggerInfo.Version > 0) and (DebuggerInfo.Version < 060750) then UpdRes(r, stStabs, '.', skClass, '.', [fTpMtch]);
// Full type info
r := AddFmtDef('ArgTFoo', [defFullTypeInfo], Match_ArgTFoo, skClass, 'TFoo', []);
AddMemberExpect(r, 'ValueInt', 'Integer|LongInt', [fTpMtch], skSimple);
AddMemberExpect(r, 'a1', 'TFooStatArray', [], skSimple);
AddMemberExpect(r, 'a2', 'TFooDynArray', [], skSimple);
AddMemberExpect(r, 'a3', 'array', [fTpMtch], skSimple);
AddMemberExpect(r, 'x1', '', [fTExpectNotFOund], skSimple);
{%endregion * Classes * }
{%region * Strings * }
@ -1954,6 +1996,7 @@ var
dbg: TGDBMIDebugger;
Only: Integer;
OnlyName, OnlyNamePart: String;
MemberTests: TFullTypeMemberExpectationResultArray;
function SkipTest(const Data: TWatchExpectation): Boolean;
begin
@ -1985,6 +2028,20 @@ var
IgnoreFlags: TWatchExpectationFlags;
IgnoreAll, IgnoreData, IgnoreKind, IgnoreKindPtr, IgnoreTpName: boolean;
IgnoreText: String;
i, j: Integer;
fld: TDBGField;
function CmpNames(TestName, Exp, Got: String; Match: Boolean): Boolean;
begin
if Match then begin
if Frx = nil then Frx := TRegExpr.Create;
Frx.ModifierI := true;
Frx.Expression := Exp;
TestTrue(TestName + ' matches '+Exp+' but was '+Got, Frx.Exec(Got), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
end
else TestEquals(TestName + ' equals ', LowerCase(Exp), LowerCase(Got), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
end;
begin
if not TestTrue('Dbg did NOT enter dsError', dbg.State <> dsError) then exit;
rx := nil;
@ -2055,19 +2112,47 @@ var
if IsValid and HasTpInfo then begin
s:='';
if HasTpInfo then s := WV.TypeInfo.TypeName;
if fTpMtch in DataRes.Flgs
then begin
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := DataRes.ExpTypeName;
TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but was '+s, rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
FreeAndNil(rx);
end
else TestEquals(Name + ' TypeName', LowerCase(DataRes.ExpTypeName), LowerCase(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
CmpNames('TypeName', DataRes.ExpTypeName, s, fTpMtch in DataRes.Flgs);
//if fTpMtch in DataRes.Flgs
//then begin
// rx := TRegExpr.Create;
// rx.ModifierI := true;
// rx.Expression := DataRes.ExpTypeName;
// TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but was '+s, rx.Exec(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
// FreeAndNil(rx);
// end
// else TestEquals(Name + ' TypeName', LowerCase(DataRes.ExpTypeName), LowerCase(s), DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
end else begin
TestTrue(Name + ' TypeName matches '+DataRes.ExpTypeName+' but STATE was <'+dbgs(WV.Validity)+'> HasTypeInfo='+dbgs(HasTpInfo)+' Val="'+s+'"', False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);
end;
MemberTests := DataRes.FullTypesExpect;
if Length(MemberTests) > 0 then begin
if HasTpInfo then begin
for i := 0 to Length(MemberTests) - 1 do begin
j := WV.TypeInfo.Fields.Count - 1;
while (j >= 0) and (uppercase(WV.TypeInfo.Fields[j].Name) <> UpperCase(MemberTests[i].Name)) do dec(j);
TestTrue(Name + ' no members with name ' + MemberTests[i].Name,
(fTExpectNotFOund in MemberTests[i].Flgs) <> (j >= 0),
DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
if j >= 0 then begin
fld := WV.TypeInfo.Fields[j];
if fld.DBGType <> nil then begin
TestTrue(Name + ' members with name ' + MemberTests[i].Name + ' type=' + KindName[MemberTests[i].ExpKind] + ' but was ' + KindName[fld.DBGType.Kind],
MemberTests[i].ExpKind = fld.DBGType.Kind, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
CmpNames(Name + ' members with name ' + MemberTests[i].Name + 'TypeName',
MemberTests[i].ExpTypeName, fld.DBGType.TypeName, fTpMtch in MemberTests[i].Flgs);
end
else
TestTrue(Name + ' no dbgtype for members with name' + MemberTests[i].Name, False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
end;
end;
end
else
TestTrue(Name + ' no typeinfo for members' , False, DataRes.MinGdb, DataRes.MinFpc, IgnoreText);;
end;
end;
var
@ -2312,6 +2397,7 @@ begin
end;
FreeAndNil(Frx);
AssertTestErrors;
end;