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

LazDebuggerIntf, FpDebug: add array and structure types

Browse Source
This commit is contained in:
Martin 2022-06-07 00:46:57 +02:00
parent e3d41a28e0
commit e7b23f98d0
18 changed files with 4867 additions and 435 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
components/fpdebug/fpdbgdwarf.pas
View File

@ -3646,6 +3646,7 @@ function TFpSymbolDwarf.ReadMemberVisibility(out
var
Val: Integer;
begin
AMemberVisibility := svUnknown;
Result := InformationEntry.ReadValue(DW_AT_external, Val);
if Result and (Val <> 0) then begin
AMemberVisibility := svPublic;

1
components/fpdebug/fpdbginfo.pas
View File

@ -54,6 +54,7 @@ type
);
TDbgSymbolMemberVisibility =(
svUnknown,
svPrivate,
svProtected,
svPublic

5
components/fpdebug/fppascalbuilder.pas
View File

@ -13,7 +13,8 @@ uses
type
TTypeNameFlag = (
tnfOnlyDeclared // do not return a substitute with ^ symbol
tnfOnlyDeclared, // do not return a substitute with ^ symbol
tnfNoSubstitute // do not return "{record}" if debug info has no type name
);
TTypeNameFlags = set of TTypeNameFlag;
@ -125,6 +126,8 @@ begin
exit;
end;
end;
if tnfNoSubstitute in AFlags then
exit;
Result := True;
case ADbgSymbol.Kind of

281
components/fpdebug/fpwatchresultdata.pas
View File

@ -5,8 +5,8 @@ unit FpWatchResultData;
interface
uses
FpDbgInfo, FpPascalBuilder, FpdMemoryTools, FpErrorMessages, DbgIntfBaseTypes,
fgl, SysUtils, LazDebuggerIntf;
FpDbgInfo, FpPascalBuilder, FpdMemoryTools, FpErrorMessages, FpDbgDwarf,
DbgIntfBaseTypes, fgl, SysUtils, LazDebuggerIntf;
type
@ -18,7 +18,9 @@ type
NEST_PTR_RECURSE_LVL = 6; // must be less-or-equal than MAX_RECURSE_LVL
private
FContext: TFpDbgLocationContext;
FRecurseCnt: integer;
FRecurseCnt, FRecurseInstanceCnt: integer;
FOuterArrayIdx: integer;
FRepeatCount: Integer;
protected
function CheckError(AnFpValue: TFpValue; AnResData: TLzDbgWatchDataIntf): boolean;
@ -36,11 +38,20 @@ type
function SetToResData(AnFpValue: TFpValue; AnResData: TLzDbgWatchDataIntf): Boolean;
function FloatToResData(AnFpValue: TFpValue; AnResData: TLzDbgWatchDataIntf): Boolean;
function ArrayToResData(AnFpValue: TFpValue; AnResData: TLzDbgWatchDataIntf): Boolean;
function StructToResData(AnFpValue: TFpValue; AnResData: TLzDbgWatchDataIntf): Boolean;
function DoWriteWatchResultData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf
): Boolean;
public
constructor Create(AContext: TFpDbgLocationContext);
function WriteWatchResultData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf
AnResData: TLzDbgWatchDataIntf;
ARepeatCount: Integer = 0
): Boolean;
property Context: TFpDbgLocationContext read FContext write FContext;
@ -73,7 +84,7 @@ begin
if ADeref and (t <> nil) then
t := t.TypeInfo;
if (t <> nil) and
GetTypeName(TpName, t, []) and
GetTypeName(TpName, t, [tnfNoSubstitute]) and
(TpName <> '')
then
AnResData.SetTypeName(TpName);
@ -134,7 +145,7 @@ begin
if DerefRes <> nil then begin
// In case of nested pointer MAX_RECURSE_LVL may already be reached. Make an exception here, to allow one more.
dec(FRecurseCnt);
WriteWatchResultData(DerefVal, DerefRes);
DoWriteWatchResultData(DerefVal, DerefRes);
inc(FRecurseCnt);
end;
end
@ -161,7 +172,7 @@ begin
// Nested Pointer
DerefRes := AnResData.SetDerefData;
if DerefRes <> nil then begin
WriteWatchResultData(DerefVal, DerefRes);
DoWriteWatchResultData(DerefVal, DerefRes);
end;
end;
// Currently do NOT deref for struct, array, ...
@ -275,13 +286,228 @@ begin
AddTypeNameToResData(AnFpValue, AnResData);
end;
constructor TFpWatchResultConvertor.Create(AContext: TFpDbgLocationContext);
function TFpWatchResultConvertor.ArrayToResData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf): Boolean;
var
Cnt, i, RecurseInst, OuterIdx: Integer;
LowBnd: Int64;
Addr: TDBGPtr;
ti: TFpSymbol;
EntryRes: TLzDbgWatchDataIntf;
MemberValue: TFpValue;
begin
inherited Create;
FContext := AContext;
Result := True;
if FRecurseCnt > NEST_PTR_RECURSE_LVL then
exit;
Cnt := AnFpValue.MemberCount;
RecurseInst := FRecurseInstanceCnt;
OuterIdx := FOuterArrayIdx;
if (AnFpValue.IndexTypeCount = 0) or (not AnFpValue.IndexType[0].GetValueLowBound(AnFpValue, LowBnd)) then
LowBnd := 0;
ti := AnFpValue.TypeInfo;
if (ti = nil) or (ti.Flags * [sfDynArray, sfStatArray] = []) then begin
EntryRes := AnResData.CreateArrayValue(datUnknown, Cnt, LowBnd);
end
else
if sfDynArray in ti.Flags then begin
EntryRes := AnResData.CreateArrayValue(datDynArray, Cnt, 0);
Addr := 0;
if AnFpValue.FieldFlags * [svfInteger, svfCardinal] <> [] then
Addr := AnFpValue.AsCardinal
else
if svfDataAddress in AnFpValue.FieldFlags then
Addr := AnFpValue.DataAddress.Address;
AnResData.SetDataAddress(Addr);
inc(FRecurseInstanceCnt);
end
else begin
EntryRes := AnResData.CreateArrayValue(datStatArray, Cnt, LowBnd);
end;
AddTypeNameToResData(AnFpValue, AnResData);
try
if Cnt <= 0 then
exit;
if (Context.MemManager.MemLimits.MaxArrayLen > 0) and (Cnt > Context.MemManager.MemLimits.MaxArrayLen) then
Cnt := Context.MemManager.MemLimits.MaxArrayLen;
If (FOuterArrayIdx < 0) and (FRepeatCount > 0) then Cnt := FRepeatCount
else if (FRecurseCnt > 1) and (FOuterArrayIdx < 5) and (Cnt > 5) then Cnt := 5
else if (FRecurseCnt > 1) and (Cnt > 3) then Cnt := 3
else if (FRecurseCnt > 0) and (FOuterArrayIdx < 25) and (Cnt > 50) then Cnt := 50
else if (FRecurseCnt > 0) and (FOuterArrayIdx < 100) and (Cnt > 10) then Cnt := 10
else if (FRecurseCnt > 0) and (Cnt > 5) then Cnt := 5
else if (Cnt > 1000) then Cnt := 1000;
/////////////////////
// add mem read cache ??
// Bound types
for i := 0 to Cnt - 1 do begin
if i > FOuterArrayIdx then
FOuterArrayIdx := i;
MemberValue := AnFpValue.Member[i+LowBnd];
EntryRes := AnResData.SetNextArrayData;
if MemberValue = nil then
EntryRes.CreateError('Error: Could not get member')
else
DoWriteWatchResultData(MemberValue, EntryRes);
MemberValue.ReleaseReference;
end;
finally
FRecurseInstanceCnt := RecurseInst;
FOuterArrayIdx := OuterIdx;
end
end;
function TFpWatchResultConvertor.WriteWatchResultData(AnFpValue: TFpValue;
function TFpWatchResultConvertor.StructToResData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf): Boolean;
type
TAnchestorMap = specialize TFPGMap<PtrUInt, TLzDbgWatchDataIntf>;
var
vt: TLzDbgStructType;
Cache: TFpDbgMemCacheBase;
AnchestorMap: TAnchestorMap;
i, j: Integer;
MemberValue: TFpValue;
ti, sym: TFpSymbol;
ResAnch, ResField, TopAnch, UnkAnch: TLzDbgWatchDataIntf;
MbName: String;
MBVis: TLzDbgFieldVisibility;
Addr: TDBGPtr;
begin
Result := True;
case AnFpValue.Kind of
skRecord: vt := dstRecord;
skObject: vt := dstObject;
skClass: vt := dstClass;
skInterface: vt := dstInterface;
else vt := dstUnknown;
end;
if not Context.MemManager.CheckDataSize(SizeToFullBytes(AnFpValue.DataSize)) then begin
AnResData.CreateError(ErrorHandler.ErrorAsString(Context.LastMemError));
exit;
end;
Addr := 0;
if (AnFpValue.Kind in [skClass, skInterface]) then begin
if AnFpValue.FieldFlags * [svfInteger, svfCardinal] <> [] then
Addr := AnFpValue.AsCardinal
else
if svfDataAddress in AnFpValue.FieldFlags then
Addr := AnFpValue.DataAddress.Address;
end;
AnResData.CreateStructure(vt, Addr);
AddTypeNameToResData(AnFpValue, AnResData);
if (AnFpValue.Kind in [skClass, skInterface]) and (Addr = 0) then
exit;
if Context.MemManager.CacheManager <> nil then
Cache := Context.MemManager.CacheManager.AddCache(AnFpValue.DataAddress.Address, SizeToFullBytes(AnFpValue.DataSize))
else
Cache := nil;
AnchestorMap := TAnchestorMap.Create;
if (AnFpValue.Kind in [skClass, skInterface]) then
inc(FRecurseInstanceCnt);
try
if (AnFpValue.Kind in [skClass, skObject]) and (FRecurseCnt > NEST_PTR_RECURSE_LVL) then
exit;
if (AnFpValue.Kind in [skClass, skInterface]) and (FRecurseInstanceCnt >= 2) then
exit;
TopAnch := AnResData;
UnkAnch := nil;
ti := AnFpValue.TypeInfo;
if ti <> nil then
ti := ti.InternalTypeInfo;
if ti <> nil then begin
AnchestorMap.Add(PtrUInt(ti), AnResData);
if (AnFpValue.Kind in [skObject, skClass, skInterface]) then begin
ti := ti.TypeInfo;
ResAnch := AnResData;
while ti <> nil do begin
ResAnch := ResAnch.SetAnchestor(ti.Name);
AnchestorMap.Add(PtrUInt(ti), ResAnch);
ti := ti.TypeInfo;
end;
TopAnch := ResAnch;
end;
end;
for i := 0 to AnFpValue.MemberCount-1 do begin
MemberValue := AnFpValue.Member[i];
if (MemberValue = nil) or (MemberValue.Kind in [skProcedure, skFunction]) then begin
MemberValue.ReleaseReference;
(* Has Field
- $vmt => Constructor or Destructor
- $vmt_aftercontstruction_local => Constructor
*)
continue;
end;
ResAnch := nil;
ti := MemberValue.ParentTypeInfo;
if ti <> nil then
ti := ti.InternalTypeInfo;
j := AnchestorMap.IndexOf(PtrUInt(ti));
if j >= 0 then begin
ResAnch := AnchestorMap.Data[j];
end
else
if UnkAnch <> nil then begin
ResAnch := UnkAnch;
end
else begin
UnkAnch := TopAnch.SetAnchestor('');
ResAnch := UnkAnch;
end;
sym := MemberValue.DbgSymbol;
if sym <> nil then begin
MbName := sym.Name;
case sym.MemberVisibility of
svPrivate: MBVis := dfvPrivate;
svProtected: MBVis := dfvProtected;
svPublic: MBVis := dfvPublic;
else MBVis := dfvUnknown;
end;
end
else begin
MbName := '';
MBVis := dfvUnknown;
end;
ResField := ResAnch.AddField(MbName, MBVis, []);
if not DoWriteWatchResultData(MemberValue, ResField) then
ResField.CreateError('Unknown');
MemberValue.ReleaseReference;
end;
finally
if (AnFpValue.Kind in [skClass, skInterface]) then
dec(FRecurseInstanceCnt);
AnchestorMap.Free;
if Cache <> nil then
Context.MemManager.CacheManager.RemoveCache(Cache)
end;
end;
function TFpWatchResultConvertor.DoWriteWatchResultData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf): Boolean;
begin
// FRecurseCnt should be handled by the caller
@ -289,6 +515,15 @@ begin
if Result then
exit;
Result := True;
if AnResData = nil then
exit;
if AnFpValue = nil then begin
AnResData.CreateError('No Data');
exit;
end;
Result := False;
inc(FRecurseCnt);
try
@ -306,7 +541,8 @@ begin
skRecord,
skObject,
skClass,
skInterface: ;
skInterface: Result := StructToResData(AnFpValue, AnResData);
skNone: ;
skType: ;
skInstance: ;
@ -322,7 +558,7 @@ begin
skEnum,
skEnumValue: Result := EnumToResData(AnFpValue, AnResData);
skSet: Result := SetToResData(AnFpValue, AnResData);
skArray: ;
skArray: Result := ArrayToResData(AnFpValue, AnResData);
skRegister: ;
skAddress: ;
end;
@ -333,5 +569,24 @@ begin
end;
end;
constructor TFpWatchResultConvertor.Create(AContext: TFpDbgLocationContext);
begin
inherited Create;
FContext := AContext;
end;
function TFpWatchResultConvertor.WriteWatchResultData(AnFpValue: TFpValue;
AnResData: TLzDbgWatchDataIntf; ARepeatCount: Integer): Boolean;
begin
if CheckError(AnFpValue, AnResData) then
exit;
FRepeatCount := ARepeatCount;
FRecurseCnt := -1;
FRecurseInstanceCnt := 0;
FOuterArrayIdx := -1;
Result := DoWriteWatchResultData(AnFpValue, AnResData);
end;
end.

9
components/lazdebuggers/lazdebuggerfp/fpdebugdebuggerworkthreads.pas
View File

@ -1021,13 +1021,12 @@ begin
exit;
end;
if (FWatchValue <> nil) and
(ResValue <> nil) and (not IsError(ResValue.LastError)) and
(ADispFormat <> wdfMemDump) and (FWatchValue.RepeatCount <= 0) // TODO
if (FWatchValue <> nil) and (ResValue <> nil) and
(ADispFormat <> wdfMemDump) // TODO
then begin
WatchResConv := TFpWatchResultConvertor.Create(FExpressionScope.LocationContext);
ResData := FWatchValue.ResData;
Result := WatchResConv.WriteWatchResultData(ResValue, ResData);
Result := WatchResConv.WriteWatchResultData(ResValue, ResData, FWatchValue.RepeatCount);
if Result and APasExpr.HasPCharIndexAccess and not IsError(ResValue.LastError) then begin
// TODO: Only dwarf 2
@ -1036,7 +1035,7 @@ begin
APasExpr.FixPCharIndexAccess := True;
APasExpr.ResetEvaluation;
ResValue := APasExpr.ResultValue;
WatchResConv.WriteWatchResultData(ResValue, ResData);
WatchResConv.WriteWatchResultData(ResValue, ResData, FWatchValue.RepeatCount);
end;
end;

46
components/lazdebuggers/lazdebuggerfp/test/LazDebFpTest.lpi
View File

@ -306,29 +306,29 @@
</CompilerOptions>
</Item17>
<SharedMatrixOptions Count="23">
<Item1 ID="892138315231" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O- opt,32 bit O- CRriot gh gt" Value="-O-"/>
<Item2 ID="942436582238" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O1 opt" Value="-O-1"/>
<Item3 ID="862987172568" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O2 CRriot Sa Si,O2 Sa Si,O2 opt" Value="-O-2"/>
<Item4 ID="065298354086" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O3 Sa Si,O3 opt" Value="-O-3"/>
<Item5 ID="450520149060" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-O-4"/>
<Item6 ID="707355750253" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,32 bit O- CRriot gh gt" Value="-Si-"/>
<Item7 ID="015770976638" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O1 Criot gh gtt Sa Si,O1 Criot Si,O2 CRriot Sa Si,O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Si"/>
<Item8 ID="829928402724" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O1 Criot Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Sa-"/>
<Item9 ID="741586091227" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O2 CRriot Sa Si,O2 Sa Si,O3 Sa Si,32 bit O- CRriot gh gt" Value="-Sa"/>
<Item10 ID="384346637257" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,32 bit O- CRriot gh gt" Value="-gh"/>
<Item11 ID="938629446379" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O1 Criot gh gt Sa,32 bit O- CRriot gh gt" Value="-gt"/>
<Item12 ID="083874750360" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gtt Sa,O1 Criot gh gtt Sa Si" Value="-gtt"/>
<Item13 ID="624937376596" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gttt Sa" Value="-gttt"/>
<Item14 ID="960178335680" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-CR-"/>
<Item15 ID="580833933537" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O2 CRriot Sa Si,32 bit O- CRriot gh gt" Value="-CR"/>
<Item16 ID="896975201702" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Cr- -Ci- -Co- -Ct-"/>
<Item17 ID="596749297552" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot Si,O1 Criot gh gtt Sa Si,O2 CRriot Sa Si,32 bit O- CRriot gh gt" Value="-Criot"/>
<Item18 ID="313431544377" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O2 CRriot Sa Si,O3 Sa Si,O2 Sa Si,O- opt,O1 opt,O2 opt,O4 opt,O3 opt,32 bit O- CRriot gh gt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-gw2 -godwarfsets -gl"/>
<Item19 ID="509503769266" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dLINUX_NO_PTRACE_ALIGN"/>
<Item20 ID="678633917513" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dFORCE_LAZLOGGER_DUMMY"/>
<Item21 ID="212328245069" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="32 bit O- CRriot gh gt,O2 opt,O1 opt,O- opt,O3 Sa Si,O2 Sa Si,O2 CRriot Sa Si,O1 Criot Si,O1 Criot gh gtt Sa Si,O1 Criot gh gt Sa,O- CRriot Sa,O- CRriot gh gttt Sa,O- CRriot gh gtt Sa,O- CRriot gh gt Sa" Value="-dFPDEBUG_THREAD_CHECK"/>
<Item22 ID="282360485400" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dTEST_FPDEBUG_SINGLE_THREAD"/>
<Item23 ID="285688265515" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf" Modes="O4 opt TEST_FPDEBUG_SINGLE_THREAD,O4 opt,O3 opt" Value="-uFPDEBUG_THREAD_CHECK"/>
<Item1 ID="892138315231" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O- opt,32 bit O- CRriot gh gt" Value="-O-"/>
<Item2 ID="942436582238" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O1 opt" Value="-O-1"/>
<Item3 ID="862987172568" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O2 CRriot Sa Si,O2 Sa Si,O2 opt" Value="-O-2"/>
<Item4 ID="065298354086" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O3 Sa Si,O3 opt" Value="-O-3"/>
<Item5 ID="450520149060" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-O-4"/>
<Item6 ID="707355750253" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,32 bit O- CRriot gh gt" Value="-Si-"/>
<Item7 ID="015770976638" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O1 Criot gh gtt Sa Si,O1 Criot Si,O2 CRriot Sa Si,O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Si"/>
<Item8 ID="829928402724" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O1 Criot Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Sa-"/>
<Item9 ID="741586091227" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O2 CRriot Sa Si,O2 Sa Si,O3 Sa Si,32 bit O- CRriot gh gt" Value="-Sa"/>
<Item10 ID="384346637257" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,32 bit O- CRriot gh gt" Value="-gh"/>
<Item11 ID="938629446379" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O1 Criot gh gt Sa,32 bit O- CRriot gh gt" Value="-gt"/>
<Item12 ID="083874750360" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gtt Sa,O1 Criot gh gtt Sa Si" Value="-gtt"/>
<Item13 ID="624937376596" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gttt Sa" Value="-gttt"/>
<Item14 ID="960178335680" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-CR-"/>
<Item15 ID="580833933537" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O2 CRriot Sa Si,32 bit O- CRriot gh gt" Value="-CR"/>
<Item16 ID="896975201702" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O2 Sa Si,O3 Sa Si,O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-Cr- -Ci- -Co- -Ct-"/>
<Item17 ID="596749297552" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot Si,O1 Criot gh gtt Sa Si,O2 CRriot Sa Si,32 bit O- CRriot gh gt" Value="-Criot"/>
<Item18 ID="313431544377" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- CRriot gh gt Sa,O- CRriot gh gtt Sa,O- CRriot gh gttt Sa,O- CRriot Sa,O1 Criot gh gt Sa,O1 Criot gh gtt Sa Si,O1 Criot Si,O2 CRriot Sa Si,O3 Sa Si,O2 Sa Si,O- opt,O1 opt,O2 opt,O4 opt,O3 opt,32 bit O- CRriot gh gt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-gw2 -godwarfsets -gl"/>
<Item19 ID="509503769266" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dLINUX_NO_PTRACE_ALIGN"/>
<Item20 ID="678633917513" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O- opt,O1 opt,O2 opt,O3 opt,O4 opt,O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dFORCE_LAZLOGGER_DUMMY"/>
<Item21 ID="212328245069" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="32 bit O- CRriot gh gt,O2 opt,O1 opt,O- opt,O3 Sa Si,O2 Sa Si,O2 CRriot Sa Si,O1 Criot Si,O1 Criot gh gtt Sa Si,O1 Criot gh gt Sa,O- CRriot Sa,O- CRriot gh gttt Sa,O- CRriot gh gtt Sa,O- CRriot gh gt Sa" Value="-dFPDEBUG_THREAD_CHECK"/>
<Item22 ID="282360485400" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O4 opt TEST_FPDEBUG_SINGLE_THREAD" Value="-dTEST_FPDEBUG_SINGLE_THREAD"/>
<Item23 ID="285688265515" Targets="#project,LazDebuggerFp,FpDebug,DebuggerIntf,IdeDebugger" Modes="O4 opt TEST_FPDEBUG_SINGLE_THREAD,O4 opt,O3 opt" Value="-uFPDEBUG_THREAD_CHECK"/>
</SharedMatrixOptions>
</BuildModes>
<PublishOptions>

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

@ -868,7 +868,7 @@ for i := StartIdx to t.Count-1 do
StartIdxClassConst := t.Count;
t.Add(AName, p+'FiveRec'+e, weMatch('a *=.*b *= *44',skRecord))
t.Add(AName, p+'FiveRec'+e, weMatch('a *:.*b *: *44',skRecord))
.SkipIf(ALoc = tlPointerAny);
t.Add(AName, p+'FiveRec'+e, weRecord([weInteger(-22-n).N('a'), weInteger(44).N('b')], 'TRecordFive'))
.SkipIf(ALoc = tlPointerAny);
@ -1011,7 +1011,7 @@ StartIdx := t.Count; // tlConst => Only eval the watch. No tests
t.Add(AName, p+'SomeFunc1Ref'+e, weMatch('\$[0-9A-F]+ = SomeFunc1: *function *\(SOMEVALUE, Foo: LONGINT; Bar: Word; x: Byte\): *BOOLEAN', skFunctionRef) );
t.Add(AName, '@'+p+'SomeFunc1Ref'+e, wePointer('^TFunc1') ).AddFlag(ehIgnPointerDerefData);
t.Add(AName, p+'SomeProc1Ref'+e, weMatch('\$[0-9A-F]+ = SomeProc1: *procedure *\(\) *$', skProcedureRef) );
t.Add(AName, p+'SomeMeth1Ref'+e, weMatch('TMeth1.*Proc *= *\$[0-9A-F]+ *= *TMyBaseClass\.SomeMeth1.*: *TMeth1;[\s\r\n]*Self.*=.*', skRecord) );
t.Add(AName, p+'SomeMeth1Ref'+e, weMatch('Proc *: *\$[0-9A-F]+ *= *TMyBaseClass\.SomeMeth1.*: *TMeth1;[\s\r\n]*Self.*:.*', skRecord) );
t.Add(AName, p+'SomeMeth1Ref'+e+'.Proc', weMatch('\$[0-9A-F]+ = TMyBaseClass\.SomeMeth1: *function *\(.*AVal.*\): *BOOLEAN', skFunctionRef) );
for i := StartIdx to t.Count-1 do
t.Tests[i].SkipIf(ALoc in [tlConst, tlPointerAny]);
@ -1993,19 +1993,19 @@ StartIdx := t.Count; // tlConst => Only eval the watch. No tests
v := t2.Tests[0]^.TstWatch.Values[Thread, 0].ResultData.AsQWord;
val := '$'+IntToHex(v, 16);
t.Add(AName+' Int', 'PtrUInt('+p+'Instance1'+e+')', weCardinal(v, 'PtrUInt', -1));
t.Add(AName+' TClass1', 'TClass1('+p+'Instance1_Int'+e+')', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1('+val+')', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1(Pointer('+p+'Instance1_Int'+e+'))', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1(Pointer('+val+'))', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1('+p+'Instance1_Int'+e+')', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1('+val+')', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1(Pointer('+p+'Instance1_Int'+e+'))', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' TClass1', 'TClass1(Pointer('+val+'))', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
if ALoc <> tlConst then
TestTrue('got rdkNum 1', t2.Tests[1]^.TstWatch.Values[Thread, 0].ResultData.ValueKind in [rdkSignedNumVal, rdkUnsignedNumVal]);
v := t2.Tests[1]^.TstWatch.Values[Thread, 0].ResultData.AsQWord;
val := '$'+IntToHex(v, 16);
t.Add(AName+' PTxInstance1', 'PTxInstance1(@'+p+'Instance1'+e+')^', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1('+val+')^', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1(Pointer(@'+p+'Instance1'+e+'))^', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1(Pointer('+val+'))^', weMatch('FAnsi *=[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1(@'+p+'Instance1'+e+')^', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1('+val+')^', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1(Pointer(@'+p+'Instance1'+e+'))^', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
t.Add(AName+' PTxInstance1', 'PTxInstance1(Pointer('+val+'))^', weMatch('FAnsi *:[ $0-9A-F()]*\^?:? *'''+AChr1+'T', skClass));
if ALoc <> tlConst then
@ -2069,14 +2069,14 @@ StartIdx := t.Count; // tlConst => Only eval the watch. No tests
TestTrue('got rdkNum 6', t2.Tests[6]^.TstWatch.Values[Thread, 0].ResultData.ValueKind in [rdkSignedNumVal, rdkUnsignedNumVal]);
v := t2.Tests[6]^.TstWatch.Values[Thread, 0].ResultData.AsQWord;
val := '$'+IntToHex(v, 16);
t.Add(AName, 'PTxFiveRec(@'+p+'FiveRec'+e+')^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec('+val+')^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(Pointer(@'+p+'FiveRec'+e+'))^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(Pointer('+val+'))^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(PtrUInt(@'+p+'FiveRec'+e+'))^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(PtrUInt('+val+'))^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(@'+p+'FiveRec'+e+')^', weMatch('a *:.*b *: *44',skRecord));
t.Add(AName, 'PTxFiveRec('+val+')^', weMatch('a *:.*b *: *44',skRecord));
t.Add(AName, 'PTxFiveRec(Pointer(@'+p+'FiveRec'+e+'))^', weMatch('a *:.*b *: *44',skRecord));
t.Add(AName, 'PTxFiveRec(Pointer('+val+'))^', weMatch('a *:.*b *: *44',skRecord));
t.Add(AName, 'PTxFiveRec(PtrUInt(@'+p+'FiveRec'+e+'))^', weMatch('a *:.*b *: *44',skRecord));
t.Add(AName, 'PTxFiveRec(PtrUInt('+val+'))^', weMatch('a *:.*b *: *44',skRecord));
if p='gv' then
t.Add(AName, 'PTxFiveRec(gvp_'+'FiveRec'+e+')^', weMatch('a *=.*b *= *44',skRecord));
t.Add(AName, 'PTxFiveRec(gvp_'+'FiveRec'+e+')^', weMatch('a *:.*b *: *44',skRecord));
for i := StartIdx to t.Count-1 do
t.Tests[i].SkipIf(ALoc = tlConst);
@ -2125,7 +2125,7 @@ end;
t.Add(AName+' Cardinal', 'Cardinal('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError();
t.Add(AName+' QWord', 'QWord('+p+'Rec3S'+e+')', weMatch('.', skSimple)).ExpectError();
t.Add(AName+' QWord', 'TRecord3QWord('+p+'Rec3S'+e+')', weMatch('a *=.*18446744073709551594.*b *=.*44.*c *= .', skRecord));
t.Add(AName+' QWord', 'TRecord3QWord('+p+'Rec3S'+e+')', weMatch('a *:.*18446744073709551594.*b *:.*44.*c *: .', skRecord));
end;

65
components/lazdebuggers/lazdebuggerintf/lazdebuggerintf.pas
View File

@ -104,14 +104,33 @@ type
TLzDbgFloatPrecission = (dfpSingle, dfpDouble, dfpExtended);
// TLzDbgSetData = bitpacked array [0..255] of boolean;
TLzDbgStructType = (dstUnknown, dstRecord, dstObject, dstClass, dstInterface);
TLzDbgArrayType = (datUnknown, datDynArray, datStatArray);
TLzDbgFieldVisibility = (dfvUnknown, dfvPrivate, dfvProtected, dfvPublic, dfvPublished);
TLzDbgFieldFlag = (dffClass, dffAbstract, dffVirtual, dffOverwritten, dffConstructor, dffDestructor);
TLzDbgFieldFlags = set of TLzDbgFieldFlag;
{ TLzDbgWatchDataIntf:
- Interface for providing result-data.
- The backend must call one of the "Create...." methods, before setting/adding
any other data.
- The backend must call exactly one of the "Create...." methods (one and only one).
Except for:
- CreateError may be called even if one of the non-erroc "Create..." had been called before
- REQUIREMENTS (for the backend)
** INIT with Create...." **
First call must be to one of the "Create...." methods.
Other data can only be set/added after that.
** INIT exactly ONCE **
Only one "Create...." method can be called.
The type can't be changed after that.
- Except for:
CreateError may be called even if one of the non-erroc "Create..." had been called before
** All ARRAY elements must have the same type **
- All entries of an array (added with "SetNextArrayData") must have the
same type (i.e., be initialized using the same "Create...." method)
- This includes all *nested* types (e.g. pointer deref)
** SetPCharShouldBeStringValue
- Like array elements: The 2nd value must have the same type as the first.
- Not allowed to be called on nested elements
- Adding nested data (calling any method returning a new TLzDbgWatchDataIntf)
The Frontend may return "nil" to indicate it does not want this particular data.
}
TLzDbgWatchDataIntf = interface
@ -124,8 +143,25 @@ type
procedure CreateFloatValue(AFloatValue: Extended; APrecission: TLzDbgFloatPrecission);
procedure CreateBoolValue(AnOrdBoolValue: QWord; AByteSize: Integer = 0);
procedure CreateEnumValue(ANumValue: QWord; AName: String; AByteSize: Integer = 0; AnIsEnumIdent: Boolean = False);
// //procedure CreateEnumValue(ANumValue: QWord; const ANames: TStringDynArray; const AOrdValues: TIntegerDynArray);
procedure CreateSetValue(const ANames: TStringDynArray); //; const AOrdValues: array of Integer);
// // CreateSetValue: "ASetVal" only has "length(ANames)" entries. Any higher value will be ignored / should be zero
// procedure CreateSetValue(const ASetVal: TLzDbgSetData; const ANames: TStringDynArray); //; const AOrdValues: array of Integer);
// Returns Intf for setting element-type => for empty array
function CreateArrayValue(AnArrayType: TLzDbgArrayType;
ATotalCount: Integer = 0;
ALowIdx: Integer = 0
): TLzDbgWatchDataIntf;
//procedure CreateDynArrayValue(ATotalCount: Integer = 0);
//procedure CreateStatArrayValue(ATotalCount: Integer = 0);
// low/high
procedure CreateStructure(AStructType: TLzDbgStructType;
ADataAddress: TDBGPtr = 0
//AOwnFieldCount: Integer = 0; // Fields declared in this structure (no anchestors)
//ARecurseFieldCount: Integer = 0 // Fields including anchestors
);
procedure CreateError(AVal: String);
// For all Values
@ -137,8 +173,27 @@ type
// For all Values (except error)
procedure SetTypeName(ATypeName: String);
// For Array
procedure SetDataAddress(AnAddr: TDbgPtr);
// For Pointers:
function SetDerefData: TLzDbgWatchDataIntf;
// For Arrays
(* - The returned TLzDbgWatchDataIntf is only valid until the next call of SetNextItemData.
For nested arrays, this includes calls to any outer arrays SetNextItemData.
- Type related (ASigned, AByteSize, APrecission, ...) are taken from the
proto-type or the first Item only. They are ignored on subsequent items
*)
function SetNextArrayData: TLzDbgWatchDataIntf;
// For structures:
function SetAnchestor(ATypeName: String): TLzDbgWatchDataIntf; // Only: object, class, interface
function AddField(AFieldName: String;
AVisibility: TLzDbgFieldVisibility;
AFlags: TLzDbgFieldFlags
// AnAnchestor: TLzDbgWatchDataIntf // nil => unknown
): TLzDbgWatchDataIntf;
end;
{ TWatchValueIntf }

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

@ -10,7 +10,7 @@ interface
uses
Classes, SysUtils, math, DbgIntfBaseTypes, DbgIntfDebuggerBase,
FpPascalBuilder, LazLoggerBase, Forms, IdeDebuggerBase, IdeDebuggerUtils,
IdeDebuggerWatchResult, RegExpr,
IdeDebuggerWatchResult, IdeDebuggerWatchResPrinter, RegExpr,
TestDbgTestSuites, TTestDebuggerClasses, TTestDbgExecuteables, TestDbgConfig,
LazDebuggerIntf, LazDebuggerIntfBaseTypes, TestOutputLogger;
@ -209,6 +209,7 @@ type
TWatchExpectationList = class
private
FWatchResultPrinter: TWatchResultPrinter;
FAcceptSkSimple: TDbgSymbolKinds;
FTest: TDBGTestCase;
FList: array of TWatchExpectation;
@ -260,7 +261,7 @@ type
function CheckResultRecord(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultClass(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultObject(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultInstance(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
function CheckResultInterface(AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean; virtual;
property Compiler: TTestDbgCompiler read GetCompiler;
property Debugger: TTestDbgDebugger read GetDebugger;
@ -1169,10 +1170,12 @@ begin
if AFoundCount < Length(Result) then
Result[AFoundCount] := copy(AVal, 1, i-1);
inc(AFoundCount);
while (i < length(AVal)) and (AVal[i+1] in [#1..#32]) do
inc(i);
delete(AVal, 1, i);
i := 1;
if (length(AVal) > 0) and (AVal[1] = ' ') then
delete(AVal, 1, 1);
//if (length(AVal) > 0) and (AVal[1] = ' ') then
// delete(AVal, 1, 1);
end;
end;
@ -1425,7 +1428,7 @@ begin
rkClass: Result := CheckResultClass(AContext, AnIgnoreRsn);
rkObject: Result := CheckResultObject(AContext, AnIgnoreRsn);
rkRecord: Result := CheckResultRecord(AContext, AnIgnoreRsn);
rkInterface: Result := CheckResultInstance(AContext, AnIgnoreRsn);
rkInterface: Result := CheckResultInterface(AContext, AnIgnoreRsn);
rkStatArray: Result := CheckResultArray(AContext, AnIgnoreRsn);
rkDynArray: Result := CheckResultArray(AContext, AnIgnoreRsn);
end;
@ -1569,7 +1572,7 @@ begin
Result := True;
Expect := AContext.Expectation;
Result := TestMatches('Data', Expect.ExpTextData, PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
Result := TestMatches('Data', Expect.ExpTextData, FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
end;
end;
@ -1591,7 +1594,7 @@ begin
else
s := IntToStr(Expect.expIntValue);
Result := TestEquals('Data', s, PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
Result := TestEquals('Data', s, FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
end
else begin
if IsCardinal then begin
@ -1624,7 +1627,7 @@ begin
Expect := AContext.Expectation;
WriteStr(s, Expect.ExpBoolValue);
v := PrintWatchValue(AContext.WatchRes, wdfDefault);
v := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
if AContext.Expectation.ExpResultKind = rkSizedBool then begin
i := pos('(', v);
if i > 1 then
@ -1645,7 +1648,7 @@ begin
Expect := AContext.Expectation;
if AContext.WatchRes.ValueKind = rdkPrePrinted then begin
Result := TestEquals('Data', FloatToStr(Expect.ExpFloatValue), PrintWatchValue(AContext.WatchRes, wdfDefault), EqIgnoreCase, AContext, AnIgnoreRsn);
Result := TestEquals('Data', FloatToStr(Expect.ExpFloatValue), FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault), EqIgnoreCase, AContext, AnIgnoreRsn);
end
else begin
Result := TestTrue('ValKind', AContext.WatchRes.ValueKind = rdkFloatVal, AContext, AnIgnoreRsn);
@ -1663,7 +1666,7 @@ begin
Result := True;
Expect := AContext.Expectation;
Result := TestEquals('Data', Expect.ExpTextData, PrintWatchValue(AContext.WatchRes, wdfDefault), not(Compiler.SymbolType in stDwarf2), AContext, AnIgnoreRsn);
Result := TestEquals('Data', Expect.ExpTextData, FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault), not(Compiler.SymbolType in stDwarf2), AContext, AnIgnoreRsn);
end;
end;
@ -1679,7 +1682,7 @@ begin
Result := True;
Expect := AContext.Expectation;
v := PrintWatchValue(AContext.WatchRes, wdfDefault);
v := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
if (v='') or (v[1] <> '[') or (v[length(v)] <> ']') then begin
Result := TestTrue('elements are in [...]', False, AContext, AnIgnoreRsn);
@ -1717,7 +1720,7 @@ begin
else
e := QuoteText(Expect.ExpTextData);
v := PrintWatchValue(AContext.WatchRes, wdfDefault);
v := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
if ehCharFromIndex in ehf then begin
if v <> e then begin
//AnIgnoreRsn := AnIgnoreRsn + 'char from index not implemented';
@ -1746,7 +1749,7 @@ begin
Expect := AContext.Expectation;
if AContext.WatchRes.ValueKind = rdkPrePrinted then begin
v := PrintWatchValue(AContext.WatchRes, wdfDefault);
v := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
// in dwarf 2 ansistring are pchar
@ -1833,7 +1836,7 @@ begin
else
e := QuoteText(Expect.ExpTextData);
Result := TestEquals('Data', e, PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
Result := TestEquals('Data', e, FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault), AContext, AnIgnoreRsn);
end
else begin
Result := TestTrue('ValueKind', AContext.WatchRes.ValueKind = rdkString, AContext, AnIgnoreRsn);
@ -1857,7 +1860,7 @@ begin
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
if AContext.WatchRes.ValueKind = rdkPrePrinted then begin
g := PrintWatchValue(AContext.WatchRes, wdfDefault);
g := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
e := '(\$[0-9a-fA-F]*|nil)';
tn := GetExpTypeNameAsRegEx(Expect);
@ -1990,7 +1993,7 @@ begin
Result := True;
Expect := AContext.Expectation;
v := PrintWatchValue(AContext.WatchRes, wdfDefault);
v := FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault);
debugln([' expect ',Expect.ExpFullArrayLen,' got "',v,'"' ]);
if CompareText(v, 'nil') = 0 then begin
@ -2033,28 +2036,24 @@ function TWatchExpectationList.CheckStructureFields(const AnIgnoreRsn: String;
var
Expect: TWatchExpectationResult;
ehf: TWatchExpErrorHandlingFlags;
i, j, e, a: Integer;
parsed: TStringArray;
i, j, a: Integer;
SubContext: TWatchExpTestCurrentData;
sr: TWatchExpectationResult;
n, v: String;
lastidx: integer;
begin
Result := True;
with AContext.WatchExp do begin
Expect := AContext.Expectation;
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
v := Trim(PrintWatchValue(AContext.WatchRes, wdfDefault));
v := Trim(FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault));
delete(v, 1, pos('(', v));
delete(v, length(v), 1);
parsed := ParseCommaList(v, e, -1, ';');
TestTrue('FieldParser len', e <= Length(parsed), AContext, AnIgnoreRsn);
e := min(e, Length(parsed));
n := FTest.TestBaseName;
SubContext := AContext;
lastidx := -1;
for i := 0 to length(Expect.ExpSubResults) - 1 do begin
sr := Expect.ExpSubResults[i];
if not TestTrue('field name ' + IntToStr(i), sr.ExpFieldName<>'', AContext, AnIgnoreRsn) then
@ -2076,31 +2075,37 @@ begin
TestTrue('EvalCallResDBGType has field '+sr.ExpFieldName, a >= 0, AContext, AnIgnoreRsn);
end;
j := parsed.IndexOfFieldName(sr.ExpFieldName, e);
if not TestTrue('field exists ' + IntToStr(i), j >= 0, AContext, AnIgnoreRsn) then
Continue;
v := LowerCase(sr.ExpFieldName);
j := AContext.WatchRes.FieldCount-1;
while (j >= 0) and (LowerCase(AContext.WatchRes.Fields[j].FieldName) <> v) do
dec(j);
TestTrue('found field '+v, j >= 0, AContext, AnIgnoreRsn);
(*
if not(ehNoFieldOrder in ehf) then begin
if ehMissingFields in ehf then begin
dec(e, j);
parsed.delete(0, j);
j := 0;
TestTrue('field in order ' + IntToStr(lastidx) + ' ' + IntToStr(j), j > lastidx, AContext, AnIgnoreRsn);
lastidx := j;
end
else begin
inc(lastidx);
TestTrue('field in order ' + IntToStr(lastidx) + ' ' + IntToStr(j), j = lastidx, AContext, AnIgnoreRsn);
end;
end;
*)
if not TestTrue('field in order ' + IntToStr(i) + ' ' + IntToStr(j), j = 0, AContext, AnIgnoreRsn) then
Continue;
if j >= 0 then begin
SubContext.WatchRes := TWatchResultDataPrePrinted.Create(
FWatchResultPrinter.PrintWatchValue(AContext.WatchRes.Fields[j].Field, wdfDefault)
);
FTest.TestBaseName := n + ' Idx=' + IntToStr(i);
SubContext.Expectation := sr;
Result := CheckData(SubContext, AnIgnoreRsn);
FreeAndNil(SubContext.WatchRes);
end;
SubContext.WatchRes := TWatchResultDataPrePrinted.Create(parsed.ValueOfFieldName(j));
FTest.TestBaseName := n + ' Idx=' + IntToStr(i);
dec(e);
parsed.delete(j, 1);
//SubContext.WatchExp.TstExpected := sr;
SubContext.Expectation := sr;
Result := CheckData(SubContext, AnIgnoreRsn);
FreeAndNil(SubContext.WatchRes);
end;
FTest.TestBaseName := n;
end;
@ -2109,27 +2114,16 @@ end;
function TWatchExpectationList.CheckResultRecord(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var
Expect: TWatchExpectationResult;
v, tn: String;
ehf: TWatchExpErrorHandlingFlags;
v: String;
begin
with AContext.WatchExp do begin
Result := True;
Expect := AContext.Expectation;
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
v := Trim(PrintWatchValue(AContext.WatchRes, wdfDefault));
debugln([' expect ',Expect.ExpFullArrayLen,' got "',v,'"' ]);
//if (LowerCase(v) = 'nil') then
v := Trim(FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault));
TestTrue('TODO / some text', v <> '', AContext, AnIgnoreRsn);
//if not TestMatches('Is record', '^record .* end$', v, False, AContext, AnIgnoreRsn) then
// exit;
//delete(v, 1, 7);
//delete(v, length(v)-2, 3);
tn := GetExpTypeNameAsRegEx(Expect);
if not TestMatches('Is record', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then
exit;
TestTrue('rdkStruct', AContext.WatchRes.ValueKind = rdkStruct, AContext, AnIgnoreRsn);
TestTrue('dstRecord', AContext.WatchRes.StructType = dstRecord, AContext, AnIgnoreRsn);
Result := CheckStructureFields(AnIgnoreRsn, AContext);
end;
@ -2138,21 +2132,16 @@ end;
function TWatchExpectationList.CheckResultClass(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var
v, tn: String;
ehf: TWatchExpErrorHandlingFlags;
Expect: TWatchExpectationResult;
v: String;
begin
with AContext.WatchExp do begin
Result := True;
Expect := AContext.Expectation;
ehf := Expect.ExpErrorHandlingFlags[Compiler.SymbolType];
v := Trim(PrintWatchValue(AContext.WatchRes, wdfDefault));
//if (LowerCase(v) = 'nil') then
v := Trim(FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault));
TestTrue('TODO / some text', v <> '', AContext, AnIgnoreRsn);
tn := GetExpTypeNameAsRegEx(Expect);
if not TestMatches('Is class ', '^'+tn+' *\(.*\)$', v, False, AContext, AnIgnoreRsn) then
exit;
TestTrue('rdkStruct', AContext.WatchRes.ValueKind = rdkStruct, AContext, AnIgnoreRsn);
TestTrue('dstClass', AContext.WatchRes.StructType = dstClass, AContext, AnIgnoreRsn);
Result := CheckStructureFields(AnIgnoreRsn, AContext);
end;
@ -2160,18 +2149,46 @@ end;
function TWatchExpectationList.CheckResultObject(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var
v: String;
begin
Result := CheckResultRecord(AContext, AnIgnoreRsn);
with AContext.WatchExp do begin
Result := True;
v := Trim(FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault));
TestTrue('TODO / some text', v <> '', AContext, AnIgnoreRsn);
TestTrue('rdkStruct', AContext.WatchRes.ValueKind = rdkStruct, AContext, AnIgnoreRsn);
if AContext.WatchRes.StructType in [dstClass, dstRecord] then
TestTrue('dstObject', AContext.WatchRes.StructType = dstObject, AContext, 'Ignored')
else
TestTrue('dstObject', AContext.WatchRes.StructType = dstObject, AContext, AnIgnoreRsn);
Result := CheckStructureFields(AnIgnoreRsn, AContext);
end;
end;
function TWatchExpectationList.CheckResultInstance(
function TWatchExpectationList.CheckResultInterface(
AContext: TWatchExpTestCurrentData; AnIgnoreRsn: String): Boolean;
var
v: String;
begin
Result := CheckResultClass(AContext, AnIgnoreRsn);
with AContext.WatchExp do begin
Result := True;
v := Trim(FWatchResultPrinter.PrintWatchValue(AContext.WatchRes, wdfDefault));
TestTrue('TODO / some text', v <> '', AContext, AnIgnoreRsn);
TestTrue('rdkStruct', AContext.WatchRes.ValueKind = rdkStruct, AContext, AnIgnoreRsn);
TestTrue('dstInterface', AContext.WatchRes.StructType = dstInterface, AContext, AnIgnoreRsn);
Result := CheckStructureFields(AnIgnoreRsn, AContext);
end;
end;
constructor TWatchExpectationList.Create(ATest: TDBGTestCase);
begin
FWatchResultPrinter := TWatchResultPrinter.Create;
FTest := ATest;
FTypeNameAliases := TStringList.Create;
inherited Create;
@ -2181,6 +2198,7 @@ destructor TWatchExpectationList.Destroy;
begin
Clear;
FTypeNameAliases.Free;
FWatchResultPrinter.Free;
inherited Destroy;
end;

9
debugger/watchesdlg.pp
View File

@ -45,7 +45,7 @@ uses
DebuggerTreeView, IdeDebuggerBase, DebuggerDlg, DbgIntfBaseTypes,
DbgIntfDebuggerBase, DbgIntfMiscClasses, SynEdit, laz.VirtualTrees,
LazDebuggerIntf, LazDebuggerIntfBaseTypes, BaseDebugManager, EnvironmentOpts,
StrUtils, IdeDebuggerWatchResult;
StrUtils, IdeDebuggerWatchResult, IdeDebuggerWatchResPrinter;
type
@ -152,6 +152,7 @@ type
procedure ContextChanged(Sender: TObject);
procedure SnapshotChanged(Sender: TObject);
private
FWatchPrinter: TWatchResultPrinter;
FWatchesInView: TIdeWatches;
FPowerImgIdx, FPowerImgIdxGrey: Integer;
FUpdateAllNeeded, FInEndUpdate: Boolean;
@ -221,6 +222,7 @@ end;
constructor TWatchesDlg.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FWatchPrinter := TWatchResultPrinter.Create;
FWatchesInView := nil;
FStateFlags := [];
nbInspect.Visible := False;
@ -299,6 +301,7 @@ begin
if FQueuedUnLockCommandProcessing then
DebugBoss.UnLockCommandProcessing;
FQueuedUnLockCommandProcessing := False;
FreeAndNil(FWatchPrinter);
inherited Destroy;
end;
@ -942,7 +945,7 @@ begin
InspectMemo.WordWrap := True;
if d.ResultData <> nil then
s := PrintWatchValue(d.ResultData, d.DisplayFormat)
s := FWatchPrinter.PrintWatchValue(d.ResultData, d.DisplayFormat)
else
s := d.Value;
InspectMemo.Text := DebugBoss.FormatValue(d.TypeInfo, s);
@ -1032,7 +1035,7 @@ begin
( (GetSelectedSnapshot = nil) or not(WatchValue.Validity in [ddsUnknown, ddsEvaluating, ddsRequested]) )
then begin
if (WatchValue.Validity = ddsValid) and (WatchValue.ResultData <> nil) then begin
WatchValueStr := PrintWatchValue(WatchValue.ResultData, WatchValue.DisplayFormat);
WatchValueStr := FWatchPrinter.PrintWatchValue(WatchValue.ResultData, WatchValue.DisplayFormat);
WatchValueStr := ClearMultiline(DebugBoss.FormatValue(WatchValue.TypeInfo, WatchValueStr));
if (WatchValue.TypeInfo <> nil) and
(WatchValue.TypeInfo.Attributes * [saArray, saDynArray] <> []) and

599
ide/packages/idedebugger/debugger.pp
View File

@ -38,7 +38,7 @@ unit Debugger;
interface
uses
TypInfo, Classes, SysUtils, math, Types,
TypInfo, Classes, SysUtils, math, Types, fgl,
// LazUtils
Laz2_XMLCfg, LazFileUtils, LazStringUtils, LazUtilities, LazLoggerBase,
LazClasses, Maps, LazMethodList,
@ -644,38 +644,87 @@ type
{ TCurrentResData }
TCurrentResData = class(TObject, TLzDbgWatchDataIntf)
private type
TCurrentResDataFlag = (
crfDone, crfWasDone, crfSubDataCreated,
crfFreeResData, crfFreeErrResData,
crfIsArrayEntry, crfArrayProtoSet,
crfIsAnchestor
);
TCurrentResDataFlags = set of TCurrentResDataFlag;
TCurrentResDataList = specialize TFPGObjectList<TCurrentResData>;
private
FNewResultData: TWatchResultDataEx;
FSubCurrentData, // Deref
FSubCurrentDataSecond, // String(in PCharOrString)
FOwnerCurrentData: TCurrentResData;
FStoredResultData, FStoredErrorResultData: TWatchResultDataEx;
procedure AfterDataCreated;
procedure AfterSubDataCreated;
FSubCurrentData, // Deref, Array-Element, PChar(in PCharOrString)
FSubCurrentDataSecond, // String(in PCharOrString)
FAnchestorCurrentData,
FOwnerCurrentData: TCurrentResData;
FCurrentFields: TCurrentResDataList;
FFLags: TCurrentResDataFlags;
FCurrentIdx, FArrayCount: Integer;
procedure BeforeCreateValue; inline; // Before creating any non-error
procedure BeforeCreateError; inline;
procedure AfterDataCreated; virtual;
procedure AfterSubDataCreated(ASubData: TCurrentResData);
procedure FinishCurrentArrayElement;
function InternalPCharShouldBeStringValue(APCharResult: TCurrentResData): TLzDbgWatchDataIntf;
procedure WriteFieldsToRes(AStartIdx: Integer; AClassResData: TWatchResultDataEx);
function CreateSubCurrentResData: TCurrentResData; inline;
procedure InitSubCurrentResData(ANewCurData: TCurrentResData); inline;
procedure MarkResDataAsUsedByOwner;
procedure FreeResultAndSubData;
procedure FreeResultAndSubDataAndDestroy;
public
destructor Destroy; override;
procedure Done;
function RootResultData: TCurrentResData;
property NewResultData: TWatchResultDataEx read FNewResultData;
procedure DebugPrint(AText: String);
public
procedure CreatePrePrinted(AVal: String); // ATypes: TLzDbgWatchDataTypes);
procedure CreateString(AVal: String);// AnEncoding // "pchar data"
procedure CreateWideString(AVal: WideString);
procedure CreateCharValue(ACharValue: QWord; AByteSize: Integer = 0);
procedure CreateNumValue(ANumValue: QWord; ASigned: Boolean; AByteSize: Integer = 0);
procedure CreatePointerValue(AnAddrValue: TDbgPtr);
procedure CreateFloatValue(AFloatValue: Extended; APrecission: TLzDbgFloatPrecission);
{%region ***** TLzDbgWatchDataIntf ***** }
procedure CreatePrePrinted(AVal: String); virtual; // ATypes: TLzDbgWatchDataTypes);
procedure CreateString(AVal: String); virtual;// AnEncoding // "pchar data"
procedure CreateWideString(AVal: WideString); virtual;
procedure CreateCharValue(ACharValue: QWord; AByteSize: Integer = 0); virtual;
procedure CreateNumValue(ANumValue: QWord; ASigned: Boolean; AByteSize: Integer = 0); virtual;
procedure CreatePointerValue(AnAddrValue: TDbgPtr); virtual;
procedure CreateFloatValue(AFloatValue: Extended; APrecission: TLzDbgFloatPrecission); virtual;
function CreateArrayValue(AnArrayType: TLzDbgArrayType;
ATotalCount: Integer = 0;
ALowIdx: Integer = 0
): TLzDbgWatchDataIntf; virtual;
procedure CreateBoolValue(AnOrdBoolValue: QWord; AByteSize: Integer = 0);
procedure CreateEnumValue(ANumValue: QWord; AName: String; AByteSize: Integer = 0; AnIsEnumIdent: Boolean = False);
// //procedure CreateEnumValue(ANumValue: QWord; const ANames: TStringDynArray; const AOrdValues: TIntegerDynArray);
procedure CreateSetValue(const ANames: TStringDynArray);
//procedure CreateSetValue(const ASetVal: TLzDbgSetData; const ANames: TStringDynArray); //; const AOrdValues: array of Integer);
procedure CreateStructure(AStructType: TLzDbgStructType;
ADataAddress: TDBGPtr = 0
//AOwnFieldCount: Integer = 0; // Fields declared in this structure (no anchestors)
//ARecurseFieldCount: Integer = 0 // Fields including anchestors
);
procedure CreateError(AVal: String);
procedure CreateError(AVal: String); virtual;
function SetPCharShouldBeStringValue: TLzDbgWatchDataIntf;
procedure SetTypeName(ATypeName: String);
function SetDerefData: TLzDbgWatchDataIntf;
procedure SetDataAddress(AnAddr: TDbgPtr);
function SetNextArrayData: TLzDbgWatchDataIntf;
function SetAnchestor(ATypeName: String): TLzDbgWatchDataIntf;
function AddField(AFieldName: String;
AVisibility: TLzDbgFieldVisibility;
AFlags: TLzDbgFieldFlags
// AnAnchestor: TLzDbgWatchDataIntf // nil => unknown
): TLzDbgWatchDataIntf;
{%endregion ***** TLzDbgWatchDataIntf ***** }
end;
{ TCurrentWatchValue }
@ -2076,7 +2125,7 @@ end;
function TDebuggerUnitInfo.GetLocationFullFile: String;
begin
Result := FLocationFullFile;;
Result := FLocationFullFile;
end;
function TDebuggerUnitInfo.GetLocationName: String;
@ -3045,7 +3094,7 @@ end;
function TIdeLocalsMonitor.GetCurrentLocalsList: TCurrentLocalsList;
begin
Result := TCurrentLocalsList(LocalsList);;
Result := TCurrentLocalsList(LocalsList);
end;
procedure TIdeLocalsMonitor.DoStateEnterPause;
@ -3157,18 +3206,87 @@ end;
{ TCurrentResData }
procedure TCurrentResData.AfterDataCreated;
procedure TCurrentResData.BeforeCreateValue;
begin
if FOwnerCurrentData <> nil then
FOwnerCurrentData.AfterSubDataCreated;
if (FNewResultData <> nil) and (FNewResultData.ValueKind = rdkError) then begin
assert(crfIsArrayEntry in FFLags, 'TCurrentResData.BeforeCreateValue: crfIsArrayEntry in FFLags');
assert((FStoredErrorResultData=nil) or (FStoredErrorResultData=FNewResultData), 'TCurrentResData.BeforeCreateValue: (FStoredErrorResultData=nil) or (FStoredErrorResultData=FNewResultData)');
FStoredErrorResultData := FNewResultData;
FNewResultData := FStoredResultData
end;
end;
procedure TCurrentResData.AfterSubDataCreated;
procedure TCurrentResData.BeforeCreateError;
begin
if crfIsArrayEntry in FFLags then begin
if (FNewResultData <> nil) and (FNewResultData.ValueKind <> rdkError) then begin
assert((FStoredResultData=nil) or (FStoredResultData=FNewResultData), 'TCurrentResData.BeforeCreateError: (FStoredResultData=nil) or (FStoredResultData=FNewResultData)');
FStoredResultData := FNewResultData;
FNewResultData := FStoredErrorResultData;
end;
end
else
if (FNewResultData <> nil) and (FNewResultData.ValueKind <> rdkError) then begin
FreeResultAndSubData;
end;
end;
procedure TCurrentResData.AfterDataCreated;
begin
if crfIsArrayEntry in FFLags then
Exclude(FFLags, crfDone);
assert(FFLags * [crfWasDone, crfIsArrayEntry] <> [crfWasDone], 'TCurrentResData.AfterDataCreated: FFLags * [crfWasDone, crfIsArrayEntry] <> [crfWasDone]');
assert((not (crfIsAnchestor in FFLags)) or (FNewResultData.ValueKind=rdkStruct), 'TCurrentResData.AfterDataCreated: (not (crfIsAnchestor in FFLags)) or (FNewResultData.ValueKind=rdkStruct)');
if FOwnerCurrentData <> nil then
FOwnerCurrentData.AfterSubDataCreated(Self);
end;
procedure TCurrentResData.AfterSubDataCreated(ASubData: TCurrentResData);
begin
assert(FNewResultData <> nil, 'TCurrentResData.AfterSubDataCreated: FNewResultData <> nil');
if FNewResultData is TWatchResultDataPointer then begin
TWatchResultDataPointer(FNewResultData).SetDerefData(FSubCurrentData.FNewResultData);
Include(FFLags, crfSubDataCreated);
end;
procedure TCurrentResData.FinishCurrentArrayElement;
begin
assert((FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray), 'TCurrentResData.FinishCurrentArrayElement: (FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray)');
assert((FSubCurrentData<>nil) and (FSubCurrentData is TCurrentResData), 'TCurrentResData.FinishCurrentArrayElement: (FSubCurrentData<>nil) and (FSubCurrentData is TCurrentResData)');
FSubCurrentData.Done;
if not (crfSubDataCreated in FFLags) then begin
// Empty array / No type-info set.
FNewResultData.SetEntryCount(0);
assert(FCurrentIdx < 0, 'TCurrentResData.FinishCurrentArrayElement: FCurrentIdx < 0');
exit;
end;
if (not(crfArrayProtoSet in FFLags)) and
(FSubCurrentData.FNewResultData <> nil)
then begin
assert(FCurrentIdx <= 0, 'TCurrentResData.FinishCurrentArrayElement: FCurrentIdx <= 0');
Include(FFLags, crfArrayProtoSet);
FNewResultData.SetEntryPrototype(FSubCurrentData.FNewResultData);
end;
if (FCurrentIdx = 0) and (FArrayCount > 0) then
FNewResultData.SetEntryCount(Min(FArrayCount, 1000));
if FCurrentIdx >= 0 then begin
if FCurrentIdx >= FNewResultData.Count then begin // XXXXX entrycount
FNewResultData.SetEntryCount(
FCurrentIdx +
Max(50, Min(FNewResultData.Count div 8, 500))
);
end;
FNewResultData.WriteValueToStorage(FCurrentIdx, FSubCurrentData.FNewResultData)
end;
Exclude(FFLags, crfSubDataCreated);
end;
function TCurrentResData.InternalPCharShouldBeStringValue(
@ -3180,24 +3298,142 @@ begin
// AfterDataCreated;
FSubCurrentData := APCharResult;
FSubCurrentData.FOwnerCurrentData := Self;
InitSubCurrentResData(FSubCurrentData);
FSubCurrentDataSecond := TCurrentResData.Create;
FSubCurrentDataSecond.FOwnerCurrentData := Self;
FSubCurrentDataSecond := CreateSubCurrentResData;
Result := FSubCurrentDataSecond;
end;
procedure TCurrentResData.WriteFieldsToRes(AStartIdx: Integer;
AClassResData: TWatchResultDataEx);
var
i: Integer;
begin
if FCurrentFields = nil then
exit;
FNewResultData.SetFieldCount(FCurrentFields.Count);
for i := 0 to FCurrentFields.Count - 1 do begin
AClassResData.SetFieldData(AStartIdx + i, TCurrentResData(FCurrentFields[i]).FNewResultData);
TCurrentResData(FCurrentFields[i]).Done;
TCurrentResData(FCurrentFields[i]).MarkResDataAsUsedByOwner;
end;
end;
function TCurrentResData.CreateSubCurrentResData: TCurrentResData;
begin
Result := TCurrentResData.Create;
InitSubCurrentResData(Result);
end;
procedure TCurrentResData.InitSubCurrentResData(ANewCurData: TCurrentResData);
begin
ANewCurData.FOwnerCurrentData := Self;
ANewCurData.FFLags := ANewCurData.FFLags +
FFLags * [crfIsArrayEntry] +
[crfFreeResData, crfFreeErrResData];
if (FNewResultData <> nil) and (FNewResultData.ValueKind = rdkArray) then
Include(ANewCurData.FFLags, crfIsArrayEntry);
end;
procedure TCurrentResData.MarkResDataAsUsedByOwner;
begin
assert(FNewResultData<>nil, 'TCurrentResData.MarkResDataAsUsedByOwner: FNewResultData<>nil');
if FNewResultData.ValueKind = rdkError then begin
Exclude(FFLags, crfFreeErrResData);
Include(FFLags, crfFreeResData);
end
else begin
Exclude(FFLags, crfFreeResData);
Include(FFLags, crfFreeErrResData);
end;
end;
procedure TCurrentResData.FreeResultAndSubData;
begin
if Self = nil then
exit;
if FStoredResultData = FNewResultData then
FStoredResultData := nil;
if FStoredErrorResultData = FNewResultData then
FStoredErrorResultData := nil;
FSubCurrentData.FreeResultAndSubDataAndDestroy;
FSubCurrentData := nil;
FSubCurrentDataSecond.FreeResultAndSubDataAndDestroy;
FSubCurrentDataSecond := nil;
FAnchestorCurrentData.FreeResultAndSubDataAndDestroy;
FAnchestorCurrentData := nil;
FreeAndNil(FCurrentFields);
if (FOwnerCurrentData = nil) or (crfFreeResData in FFLags) then
FreeAndNil(FStoredResultData);
if (FOwnerCurrentData = nil) or (crfFreeErrResData in FFLags) then
FreeAndNil(FStoredErrorResultData);
if ( (FNewResultData <> nil) and
( (FNewResultData.ValueKind = rdkError) and (crfFreeErrResData in FFLags) or
(FNewResultData.ValueKind <> rdkError) and (crfFreeResData in FFLags)
)
) or (FOwnerCurrentData = nil)
then
FreeAndNil(FNewResultData);
end;
procedure TCurrentResData.FreeResultAndSubDataAndDestroy;
begin
if Self = nil then
exit;
FreeResultAndSubData;
Destroy;
end;
destructor TCurrentResData.Destroy;
begin
// Do NOT destroy FNewResultData;
if FStoredResultData = FNewResultData then
FStoredResultData := nil;
if FStoredErrorResultData = FNewResultData then
FStoredErrorResultData := nil;
FSubCurrentData.Free;
FSubCurrentDataSecond.Free;
FAnchestorCurrentData.Free;
FCurrentFields.Free;
if crfFreeResData in FFLags then
FreeAndNil(FStoredResultData);
if crfFreeErrResData in FFLags then
FreeAndNil(FStoredErrorResultData);
if (FNewResultData <> nil) and
( (FNewResultData.ValueKind = rdkError) and (crfFreeErrResData in FFLags) or
(FNewResultData.ValueKind <> rdkError) and (crfFreeResData in FFLags)
)
then
FreeAndNil(FNewResultData);
inherited Destroy;
end;
procedure TCurrentResData.Done;
var
i: Integer;
begin
if crfDone in FFLags then
exit;
Include(FFLags, crfDone);
if FAnchestorCurrentData <> nil then
FAnchestorCurrentData.Done;
if FCurrentFields <> nil then
for i := 0 to FCurrentFields.Count-1 do
FCurrentFields[i].Done;
if (FNewResultData <> nil) then begin
Include(FFLags, crfWasDone);
if (FNewResultData is TWatchResultDataPCharOrString) then begin
FSubCurrentData.Done;
FSubCurrentDataSecond.Done;
@ -3207,10 +3443,31 @@ begin
TWatchResultDataPCharOrString(FNewResultData).WriteValueToStorage(0, FSubCurrentData.FNewResultData);
TWatchResultDataPCharOrString(FNewResultData).WriteValueToStorage(1, FSubCurrentDataSecond.FNewResultData);
FreeAndNil(FSubCurrentData.FNewResultData);
FreeAndNil(FSubCurrentDataSecond.FNewResultData);
// FreeAndNil(FSubCurrentData.FNewResultData);
// FreeAndNil(FSubCurrentDataSecond.FNewResultData);
FNewResultData.SetSelectedIndex(0);
end
else
if FNewResultData is TWatchResultDataPointer then begin
if FSubCurrentData <> nil then begin
FSubCurrentData.Done;
FNewResultData.SetDerefData(FSubCurrentData.FNewResultData);
FSubCurrentData.MarkResDataAsUsedByOwner;
//if not (crfIsArrayEntry in FSubCurrentData.FFLags) then
// FSubCurrentData.FNewResultData := nil;
end;
end
else
if (FNewResultData.ValueKind = rdkArray) then begin
FinishCurrentArrayElement;
if (FCurrentIdx >= 0) and (FNewResultData.Count > FCurrentIdx + 1) then
FNewResultData.SetEntryCount(FCurrentIdx + 1);
end
else
if (FNewResultData.ValueKind in [rdkStruct]) then begin
WriteFieldsToRes(0, FNewResultData);
end;
end;
end;
@ -3224,91 +3481,234 @@ begin
Result := Result.FOwnerCurrentData;
end;
procedure TCurrentResData.DebugPrint(AText: String);
begin
if Self = nil then exit;
DebugLnEnter(['>> ',AText]);
debugln(['Flags: ', dbghex(longint(FFLags))]);
if FNewResultData <> nil then
debugln(['NewRes: ', dbghex(ptrint(FNewResultData)),' ',DbgSName(FNewResultData), ' >> ', FNewResultData.TypeName, ' > ',FNewResultData.AsString]);
if FStoredResultData <> nil then
debugln(['Stored: ', dbghex(ptrint(FStoredResultData)),' ',DbgSName(FStoredResultData), ' >> ', FStoredResultData.TypeName, ' > ',FStoredResultData.AsString]);
if FStoredErrorResultData <> nil then
debugln(['St-Err: ', dbghex(ptrint(FStoredErrorResultData)),' ',DbgSName(FNewResultData), ' >> ', FNewResultData.TypeName, ' > ',FNewResultData.AsString]);
debugln(['Owner: ', dbghex(ptrint(FOwnerCurrentData))]);
FSubCurrentData.DebugPrint('SubCurrent');
FSubCurrentDataSecond.DebugPrint('SubCurrent Second');
FAnchestorCurrentData.DebugPrint('Anchestor');
DebugLnExit(['<<']);
end;
procedure TCurrentResData.CreatePrePrinted(AVal: String);
begin
FNewResultData.Free; // ONLY TEMP: fallback for unsuported types // This frees: FOwnerCurrentData.FNewResultData.DerefData
//assert(FNewResultData=nil, 'TCurrentResData.SetPrePrinted: FNewResultData=nil');
FNewResultData := TWatchResultDataPrePrinted.Create(AVal);
//// TEMP: fallback for unsuported types // This frees: FOwnerCurrentData.FNewResultData.DerefData
if FOwnerCurrentData = nil then FreeResultAndSubData;
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkPrePrinted), 'TCurrentResData.CreatePrePrinted: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkPrePrinted)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataPrePrinted.Create(AVal)
else
TWatchResultDataPrePrinted(FNewResultData).Create(AVal);
AfterDataCreated;
end;
procedure TCurrentResData.CreateString(AVal: String);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateString: FNewResultData=nil');
FNewResultData := TWatchResultDataString.Create(AVal);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkString), 'TCurrentResData.CreateString: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkString)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataString.Create(AVal)
else
TWatchResultDataString(FNewResultData).Create(AVal);
AfterDataCreated;
end;
procedure TCurrentResData.CreateWideString(AVal: WideString);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateWideString: FNewResultData=nil');
FNewResultData := TWatchResultDataWideString.Create(AVal);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkWideString), 'TCurrentResData.CreateWideString: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkString)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataWideString.Create(AVal)
else
TWatchResultDataWideString(FNewResultData).Create(AVal);
AfterDataCreated;
end;
procedure TCurrentResData.CreateCharValue(ACharValue: QWord; AByteSize: Integer);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateCharValue: FNewResultData=nil');
FNewResultData := TWatchResultDataChar.Create(ACharValue, AByteSize);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkChar), 'TCurrentResData.CreateCharValue: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkString)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataChar.Create(ACharValue, AByteSize)
else
TWatchResultDataChar(FNewResultData).Create(ACharValue, AByteSize);
AfterDataCreated;
end;
procedure TCurrentResData.CreateNumValue(ANumValue: QWord; ASigned: Boolean;
AByteSize: Integer);
begin
assert(FNewResultData=nil, 'TCurrentResData.SetNumValue: FNewResultData=nil');
if ASigned then
FNewResultData := TWatchResultDataSignedNum.Create(Int64(ANumValue), AByteSize)
else
FNewResultData := TWatchResultDataUnSignedNum.Create(ANumValue, AByteSize);
BeforeCreateValue;
assert((FNewResultData = nil) or (FNewResultData.ValueKind in [rdkSignedNumVal, rdkUnsignedNumVal]), 'TCurrentResData.CreateNumValue: (FNewResultData = nil) or (FNewResultData.ValueKind in [rdkSignedNumVal, rdkUnsignedNumVal])');
if FNewResultData = nil then begin
if ASigned then
FNewResultData := TWatchResultDataSignedNum.Create(Int64(ANumValue), AByteSize)
else
FNewResultData := TWatchResultDataUnSignedNum.Create(ANumValue, AByteSize);
end
else begin
if ASigned then
TWatchResultDataSignedNum(FNewResultData).Create(Int64(ANumValue), AByteSize)
else
TWatchResultDataUnSignedNum(FNewResultData).Create(ANumValue, AByteSize);
end;
AfterDataCreated;
end;
procedure TCurrentResData.CreatePointerValue(AnAddrValue: TDbgPtr);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreatePointerValue: FNewResultData=nil');
FNewResultData := TWatchResultDataPointer.Create(AnAddrValue);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkPointerVal), 'TCurrentResData.CreatePointerValue: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkPointerVal)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataPointer.Create(AnAddrValue)
else
TWatchResultDataPointer(FNewResultData).Create(AnAddrValue);
AfterDataCreated;
end;
procedure TCurrentResData.CreateFloatValue(AFloatValue: Extended;
APrecission: TLzDbgFloatPrecission);
begin
assert(FNewResultData=nil, 'TCurrentResData.SetFloatValue: FNewResultData=nil');
FNewResultData := TWatchResultDataFloat.Create(AFloatValue, APrecission);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkFloatVal), 'TCurrentResData.CreateFloatValue: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkString)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataFloat.Create(AFloatValue, APrecission)
else
TWatchResultDataFloat(FNewResultData).Create(AFloatValue, APrecission);
AfterDataCreated;
end;
procedure TCurrentResData.CreateBoolValue(AnOrdBoolValue: QWord;
AByteSize: Integer);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateBoolValue: FNewResultData=nil');
FNewResultData := TWatchResultDataBoolean.Create(AnOrdBoolValue, AByteSize);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkBool), 'TCurrentResData.CreateBoolValue: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkString)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataBoolean.Create(AnOrdBoolValue, AByteSize)
else
TWatchResultDataBoolean(FNewResultData).Create(AnOrdBoolValue, AByteSize);
AfterDataCreated;
end;
procedure TCurrentResData.CreateEnumValue(ANumValue: QWord; AName: String;
AByteSize: Integer; AnIsEnumIdent: Boolean);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateEnumValue: FNewResultData=nil');
if AnIsEnumIdent then
FNewResultData := TWatchResultDataEnumVal.Create(ANumValue, AName, AByteSize)
else
FNewResultData := TWatchResultDataEnum.Create(ANumValue, AName, AByteSize);
BeforeCreateValue;
if AnIsEnumIdent then begin
assert((FNewResultData=nil) or (FNewResultData.ValueKind = rdkEnumVal), 'TCurrentResData.CreateEnumValue: (FNewResultData=nil) or (FNewResultData.ValueKind = rdkEnumVal]');
if FNewResultData = nil then
FNewResultData := TWatchResultDataEnumVal.Create(ANumValue, AName, AByteSize)
else
TWatchResultDataEnumVal(FNewResultData).Create(ANumValue, AName, AByteSize);
end
else begin
assert((FNewResultData=nil) or (FNewResultData.ValueKind = rdkEnum), 'TCurrentResData.CreateEnumValue: (FNewResultData=nil) or (FNewResultData.ValueKind = rdkEnum]');
if FNewResultData = nil then
FNewResultData := TWatchResultDataEnum.Create(ANumValue, AName, AByteSize)
else
TWatchResultDataEnum(FNewResultData).Create(ANumValue, AName, AByteSize);
end;
AfterDataCreated;
end;
procedure TCurrentResData.CreateSetValue(const ANames: TStringDynArray);
begin
assert(FNewResultData=nil, 'TCurrentResData.CreateSetValue: FNewResultData=nil');
FNewResultData := TWatchResultDataSet.Create(ANames);
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkSet), 'TCurrentResData.CreateSetValue: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkPointerVal)');
if FNewResultData = nil then
FNewResultData := TWatchResultDataSet.Create(ANames)
else
TWatchResultDataSet(FNewResultData).Create(ANames);
AfterDataCreated;
end;
procedure TCurrentResData.CreateStructure(AStructType: TLzDbgStructType;
ADataAddress: TDBGPtr);
begin
BeforeCreateValue;
assert((FNewResultData=nil) or (FNewResultData.ValueKind=rdkStruct), 'TCurrentResData.CreateStructure: (FNewResultData=nil) or (FNewResultData.ValueKind=rdkPointerVal)');
if FNewResultData = nil then begin
if AStructType in [dstClass, dstInterface] then
FNewResultData := TWatchResultDataRefStruct.Create(AStructType, ADataAddress)
else
FNewResultData := TWatchResultDataStruct.Create(AStructType);
end
else begin
if AStructType in [dstClass, dstInterface] then
TWatchResultDataRefStruct(FNewResultData).Create(AStructType, ADataAddress)
else
TWatchResultDataStruct(FNewResultData).Create(AStructType);
end;
FCurrentIdx := 0;
AfterDataCreated;
end;
function TCurrentResData.CreateArrayValue(AnArrayType: TLzDbgArrayType;
ATotalCount: Integer; ALowIdx: Integer): TLzDbgWatchDataIntf;
begin
BeforeCreateValue;
assert((FNewResultData=nil) or ((FNewResultData=nil) or (FNewResultData.ValueKind=rdkArray)), 'TCurrentResData.CreateArrayValue: (FNewResultData=nil) or ((FNewResultData=nil) or (FNewResultData.ValueKind=rdkArray))');
if FNewResultData = nil then begin
assert(FSubCurrentData=nil, 'TCurrentResData.CreateArrayValue: FSubCurrentData=nil');
assert(FFLags*[crfSubDataCreated]=[], 'TCurrentResData.CreateArrayValue: FFLags*[crfSubDataCreated]=[]');
assert((AnArrayType<>datDynArray) or (ALowIdx=0), 'TCurrentResData.CreateArrayValue: (AnArrayType<>datDynArray) or (ALowIdx=0)');
case AnArrayType of
datUnknown: FNewResultData := TWatchResultDataArray.Create(ATotalCount, ALowIdx);
datDynArray: FNewResultData := TWatchResultDataDynArray.Create(ATotalCount);
datStatArray: FNewResultData := TWatchResultDataStatArray.Create(ATotalCount, ALowIdx);
end;
FCurrentIdx := -1; // xxxxxxxxx lowbound
FArrayCount := ATotalCount;
FSubCurrentData := CreateSubCurrentResData;
end
else begin
case AnArrayType of
datUnknown: begin
assert(FNewResultData is TWatchResultDataArray, 'TCurrentResData.CreateArrayValue: FNewResultData is TWatchResultDataArray');
TWatchResultDataArray(FNewResultData).Create(ATotalCount, ALowIdx);
end;
datDynArray: begin
assert(FNewResultData is TWatchResultDataDynArray, 'TCurrentResData.CreateArrayValue: FNewResultData is TWatchResultDataDynArray');
TWatchResultDataDynArray(FNewResultData).Create(ATotalCount);
end;
datStatArray: begin
assert(FNewResultData is TWatchResultDataStatArray, 'TCurrentResData.CreateArrayValue: FNewResultData is TWatchResultDataStatArray');
assert(ATotalCount=FArrayCount, 'TCurrentResData.CreateArrayValue: ATotalCount=FArrayCount');
TWatchResultDataStatArray(FNewResultData).Create(ATotalCount, ALowIdx);
end;
end;
FCurrentIdx := -1; // xxxxxxxxx lowbound
FArrayCount := ATotalCount;
end;
AfterDataCreated;
Result := FSubCurrentData;
end;
procedure TCurrentResData.CreateError(AVal: String);
begin
FNewResultData.Free; // This frees: FOwnerCurrentData.FNewResultData.DerefData
FNewResultData := TWatchResultDataError.Create(AVal);
BeforeCreateError;
if FNewResultData = nil then
FNewResultData := TWatchResultDataError.Create(AVal)
else
TWatchResultDataError(FNewResultData).Create(AVal);
AfterDataCreated;
end;
@ -3330,13 +3730,86 @@ end;
function TCurrentResData.SetDerefData: TLzDbgWatchDataIntf;
begin
assert((FNewResultData<>nil) and (FNewResultData is TWatchResultDataPointer), 'TCurrentResData.SetDerefData: (FNewResultData<>nil) and (FNewResultData is TWatchResultDataPointer)');
if FSubCurrentData = nil then begin
FSubCurrentData := TCurrentResData.Create;
FSubCurrentData.FOwnerCurrentData := Self;
end;
if FSubCurrentData = nil then
FSubCurrentData := CreateSubCurrentResData;
Result := FSubCurrentData;
end;
procedure TCurrentResData.SetDataAddress(AnAddr: TDbgPtr);
begin
assert((FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray), 'TCurrentResData.SetDataAddress: (FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray)');
FNewResultData.SetDataAddress(AnAddr);
end;
function TCurrentResData.SetNextArrayData: TLzDbgWatchDataIntf;
begin
assert((FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray), 'TCurrentResData.SetNextArrayData: (FNewResultData<>nil) and (FNewResultData.ValueKind=rdkArray)');
FinishCurrentArrayElement;
inc(FCurrentIdx);
Result := FSubCurrentData;
end;
function TCurrentResData.SetAnchestor(ATypeName: String): TLzDbgWatchDataIntf;
begin
assert((FNewResultData<>nil) and (FNewResultData.ValueKind in [rdkStruct]), 'TCurrentResData.SetAnchestor: (FNewResultData<>nil) and (FNewResultData.ValueKind in [rdkStruct])');
assert(FSubCurrentData=nil, 'TCurrentResData.SetAnchestor: FSubCurrentData=nil');
if (FAnchestorCurrentData <> nil) then begin
assert(crfIsArrayEntry in FFLags, 'TCurrentResData.BeforeCreateValue: crfIsArrayEntry in FFLags');
FAnchestorCurrentData.CreateStructure(FNewResultData.StructType);
Result := FAnchestorCurrentData;
exit;
end;
assert(FAnchestorCurrentData=nil, 'TCurrentResData.SetAnchestor: FAnchestorCurrentData=nil');
FAnchestorCurrentData := CreateSubCurrentResData;
Include(FAnchestorCurrentData.FFLags, crfIsAnchestor);
if crfIsAnchestor in FFLags then
FAnchestorCurrentData.FOwnerCurrentData := FOwnerCurrentData; // Top level parent
FAnchestorCurrentData.CreateStructure(FNewResultData.StructType);
FAnchestorCurrentData.SetTypeName(ATypeName);
FNewResultData.SetAnchestor(FAnchestorCurrentData.FNewResultData);
FAnchestorCurrentData.MarkResDataAsUsedByOwner;
Result := FAnchestorCurrentData;
end;
function TCurrentResData.AddField(AFieldName: String;
AVisibility: TLzDbgFieldVisibility; AFlags: TLzDbgFieldFlags
): TLzDbgWatchDataIntf;
var
NewField: TCurrentResData;
begin
Result := nil;
assert((FNewResultData<>nil) and (FNewResultData.ValueKind in [rdkStruct]), 'TCurrentResData.AddField: (FNewResultData<>nil) and (FNewResultData.ValueKind in [rdkStruct])');
if FCurrentFields = nil then begin
FCurrentFields := TCurrentResDataList.Create(True);
Exclude(FFLags, crfWasDone);
end;
if FCurrentIdx < FCurrentFields.Count then begin
Result := FCurrentFields[FCurrentIdx];
inc(FCurrentIdx);
exit;
end;
NewField := CreateSubCurrentResData;
FCurrentFields.Add(NewField);
if FCurrentIdx >= FNewResultData.DirectFieldCount then
FNewResultData.SetFieldCount(FCurrentIdx+50);
FNewResultData.SetField(FCurrentIdx, AFieldName, AVisibility, AFlags, nil);
inc(FCurrentIdx);
Result := NewField;
end;
{ TCurrentWatchValue }
procedure TCurrentWatchValue.BeginUpdate;
@ -3395,6 +3868,7 @@ end;
function TCurrentWatchValue.ResData: TLzDbgWatchDataIntf;
begin
assert(FUpdateCount > 0, 'TCurrentWatchValue.ResData: FUpdateCount > 0');
if FCurrentResData = nil then
FCurrentResData := TCurrentResData.Create;
Result := FCurrentResData;
@ -3464,7 +3938,10 @@ destructor TCurrentWatchValue.Destroy;
var
e: TMethodList;
begin
assert(FUpdateCount=0, 'TCurrentWatchValue.Destroy: FUpdateCount=0');
FCurrentResData := FCurrentResData.RootResultData;
if (FCurrentResData <> nil) and (FResultData = nil) then
FCurrentResData.FreeResultAndSubData;
FCurrentResData.Free;
for e in FEvents do
e.Free;

4
ide/packages/idedebugger/idedebugger.lpk
View File

@ -52,6 +52,10 @@
<Filename Value="idedebuggerwatchresult.pas"/>
<UnitName Value="IdeDebuggerWatchResult"/>
</Item>
<Item>
<Filename Value="idedebuggerwatchresprinter.pas"/>
<UnitName Value="idedebuggerwatchresprinter"/>
</Item>
</Files>
<RequiredPkgs>
<Item>

3
ide/packages/idedebugger/idedebuggerpackage.pas
View File

@ -9,7 +9,8 @@ interface
uses
IdeDebuggerBase, Debugger, ProcessDebugger, ProcessList, DebuggerTreeView,
IdeDebuggerUtils, IdeDebuggerWatchResult, LazarusPackageIntf;
IdeDebuggerUtils, IdeDebuggerWatchResult, IdeDebuggerWatchResPrinter,
LazarusPackageIntf;
implementation

378
ide/packages/idedebugger/idedebuggerwatchresprinter.pas Normal file
View File

@ -0,0 +1,378 @@
unit IdeDebuggerWatchResPrinter;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, IdeDebuggerWatchResult, IdeDebuggerUtils, LazDebuggerIntf,
LazUTF8, StrUtils;
type
{ TWatchResultPrinter }
TWatchResultPrinter = class
protected const
MAX_ALLOWED_NEST_LVL = 100;
protected
function PrintNumber(ANumValue: TWatchResultData; AnIsPointer: Boolean; ADispFormat: TWatchDisplayFormat): String;
function PrintArray(AResValue: TWatchResultData; ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
function PrintStruct(AResValue: TWatchResultData; ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
function PrintWatchValueEx(AResValue: TWatchResultData; ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
public
function PrintWatchValue(AResValue: TWatchResultData; ADispFormat: TWatchDisplayFormat): String;
end;
implementation
{ TWatchResultPrinter }
function TWatchResultPrinter.PrintNumber(ANumValue: TWatchResultData;
AnIsPointer: Boolean; ADispFormat: TWatchDisplayFormat): String;
var
num: QWord;
n, i, j: Integer;
begin
case ADispFormat of
//wdfString: // get pchar(num)^ ?
wdfChar: begin
num := ANumValue.AsQWord;
Result := '';
while num <> 0 do begin
Result := chr(num and $ff) + Result;
num := num >> 8;
end;
if Result <> '' then begin
i := 1;
while i <= length(Result) do begin
j := UTF8CodepointStrictSize(@Result[i]);
if j = 0 then begin
Result := copy(Result, 1, i-1) + '''#$'+ IntToHex(byte(Result[i]), 2) + '''' + copy(Result, i + 6, 99);
inc(i, 6);
end
else
inc(i, j);
end;
Result := '''' + Result + '''';
end
else
Result := '#$00';
end;
wdfUnsigned: begin
Result := IntToStr(ANumValue.AsQWord)
end;
wdfHex: begin
n := HexDigicCount(ANumValue.AsQWord, ANumValue.ByteSize, AnIsPointer);
Result := '$'+IntToHex(ANumValue.AsQWord, n);
end;
wdfBinary: begin
n := HexDigicCount(ANumValue.AsQWord, ANumValue.ByteSize, AnIsPointer);
Result := '%'+IntToBin(Int64(ANumValue.AsQWord), n*4); // Don't get any extra leading 1
end;
wdfPointer: begin
n := HexDigicCount(ANumValue.AsQWord, ANumValue.ByteSize, True);
Result := '$'+IntToHex(ANumValue.AsQWord, n);
end;
else begin // wdfDecimal
Result := IntToStr(ANumValue.AsInt64);
end;
end;
end;
function TWatchResultPrinter.PrintArray(AResValue: TWatchResultData;
ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
var
i: Integer;
sep, tn: String;
begin
if (AResValue.ArrayType = datDynArray) then begin
tn := AResValue.TypeName;
if (AResValue.Count = 0) and (AResValue.DataAddress = 0) then begin
if (ADispFormat = wdfStructure) then
Result := AResValue.TypeName + '(nil)'
else
Result := 'nil';
exit;
end;
if (ADispFormat = wdfPointer) then begin
Result := '$'+IntToHex(AResValue.DataAddress, HexDigicCount(AResValue.DataAddress, 4, True));
if tn <> '' then
Result := tn + '(' + Result + ')';
exit;
end;
end;
if ANestLvl = 0 then
sep := ',' + LineEnding
else
sep := ', ';
Result := '';
for i := 0 to AResValue.Count - 1 do begin
if Result <> '' then
Result := Result + sep;
AResValue.SetSelectedIndex(i);
Result := Result + PrintWatchValueEx(AResValue.SelectedEntry, ADispFormat, ANestLvl);
end;
if AResValue.Count < AResValue.ArrayLength then
Result := Result + sep +'...';
Result := '(' + Result +')';
end;
function TWatchResultPrinter.PrintStruct(AResValue: TWatchResultData;
ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
const
VisibilityNames: array [TLzDbgFieldVisibility] of string = (
'', 'private', 'protected', 'public', 'published'
);
var
i: Integer;
FldInfo: TWatchResultDataFieldInfo;
FldOwner: TWatchResultData;
vis, indent, sep, tn: String;
begin
Result := '';
if (AResValue.StructType in [dstClass, dstInterface])
then begin
tn := AResValue.TypeName;
if (AResValue.DataAddress = 0) and (tn <> '') then begin
if (ADispFormat = wdfStructure) then
Result := AResValue.TypeName + '(nil)'
else
Result := 'nil';
exit;
end;
if (ADispFormat = wdfPointer) then begin
Result := '$'+IntToHex(AResValue.DataAddress, HexDigicCount(AResValue.DataAddress, 4, True));
if tn <> '' then
Result := tn + '(' + Result + ')';
exit;
end;
end;
indent := StringOfChar(' ', (ANestLvl+1)*2); // TODO: first line should only be indented, if it starts on new line...
if ANestLvl < 2 then
sep := LineEnding
else
sep := ' ';
FldOwner := nil;
vis := '';
for i := 0 to AResValue.FieldCount - 1 do begin
FldInfo := AResValue.Fields[i];
if FldOwner <> FldInfo.Owner then begin
FldOwner := FldInfo.Owner;
vis := '';
if (ADispFormat = wdfStructure) and (FldOwner <> nil) and (FldOwner.DirectFieldCount > 0) then begin
if (Length(Result) > 0) then
Result := Result + sep;
Result := Result + indent + '{' + FldOwner.TypeName + '}';
end;
end;
if (ADispFormat = wdfStructure) then begin
if vis <> VisibilityNames[FldInfo.FieldVisibility] then begin
vis := VisibilityNames[FldInfo.FieldVisibility];
if (Length(Result) > 0) then
Result := Result + sep;
Result := Result + indent + vis;
end;
end;
if (Length(Result) > 0) then
Result := Result + sep;
Result := Result + indent + FldInfo.FieldName + ': ' +
PrintWatchValueEx(FldInfo.Field, wdfDefault, ANestLvl) + ';';
end;
if Result = '' then
Result := '()'
else begin
Result[ANestLvl*2+1] := '(';
Result[Length(Result)] := ')';
//Delete(Result, Length(Result), 1)
//Result := Result + sep + ')';
end;
end;
function TWatchResultPrinter.PrintWatchValueEx(AResValue: TWatchResultData;
ADispFormat: TWatchDisplayFormat; ANestLvl: Integer): String;
function PrintChar: String;
begin
if ADispFormat in [wdfDecimal, wdfUnsigned, wdfHex, wdfBinary] then begin
Result := '#' + PrintNumber(AResValue, False, ADispFormat);
exit;
end;
case AResValue.ByteSize of
//1: Result := QuoteText(SysToUTF8(char(Byte(AResValue.AsQWord))));
1: Result := QuoteText(char(Byte(AResValue.AsQWord)));
2: Result := QuoteWideText(WideChar(Word(AResValue.AsQWord)));
else Result := '#' + PrintNumber(AResValue, False, wdfDecimal);
end;
end;
function PrintBool: String;
var
c: QWord;
begin
c := AResValue.AsQWord;
if c = 0 then
Result := 'False'
else
Result := 'True';
if (ADispFormat in [wdfDecimal, wdfUnsigned, wdfHex, wdfBinary]) then
Result := Result + '(' + PrintNumber(AResValue, False, ADispFormat) + ')'
else
if (c > 1) then
Result := Result + '(' + PrintNumber(AResValue, False, wdfDecimal) + ')';
end;
function PrintEnum: String;
begin
if (ADispFormat = wdfDefault) and (AResValue.ValueKind = rdkEnumVal) then
ADispFormat := wdfStructure;
case ADispFormat of
wdfStructure:
Result := AResValue.AsString + ' = ' + PrintNumber(AResValue, False, wdfDecimal);
wdfUnsigned,
wdfDecimal,
wdfHex,
wdfBinary:
Result := PrintNumber(AResValue, False, ADispFormat);
else
Result := AResValue.AsString;
end;
end;
function PrintSet: String;
var
i: Integer;
begin
Result := '';
for i := 0 to AResValue.Count - 1 do
Result := Result + ',' + AResValue.ElementName[i];
if Result = '' then
Result := '[]'
else begin
Result[1] := '[';
Result := Result + ']'
end;
end;
var
PointerValue: TWatchResultDataPointer absolute AResValue;
ResTypeName: String;
PtrDeref: TWatchResultData;
i: Integer;
begin
inc(ANestLvl);
if ANestLvl > MAX_ALLOWED_NEST_LVL then
exit('...');
if AResValue = nil then
exit('???');
Result := '';
case AResValue.ValueKind of
rdkError:
Result := 'Error: ' + AResValue.AsString;
rdkUnknown:
Result := 'Error: Unknown';
rdkPrePrinted: begin
Result := AResValue.AsString;
end;
rdkSignedNumVal,
rdkUnsignedNumVal: begin
if (ADispFormat = wdfPointer) and (AResValue.AsQWord = 0) then begin
Result := 'nil';
end
else begin
if (AResValue.ValueKind = rdkUnsignedNumVal) and (ADispFormat = wdfDecimal) then
ADispFormat := wdfUnsigned
else
if not (ADispFormat in [wdfDecimal, wdfUnsigned, wdfHex, wdfBinary, wdfPointer]) then begin
//wdfDefault, wdfStructure, wdfChar, wdfString, wdfFloat
if AResValue.ValueKind = rdkUnsignedNumVal then
ADispFormat := wdfUnsigned
else
ADispFormat := wdfDecimal;
end;
Result := PrintNumber(AResValue, False, ADispFormat);
end;
end;
rdkPointerVal: begin
ResTypeName := '';
if (ADispFormat = wdfStructure) or
((ADispFormat = wdfDefault) and (PointerValue.DerefData = nil))
then
ResTypeName := AResValue.TypeName;
if (ADispFormat in [wdfDefault, wdfStructure, wdfPointer]) and (AResValue.AsQWord = 0)
then begin
Result := 'nil';
end
else begin
if not (ADispFormat in [wdfDecimal, wdfUnsigned, wdfHex, wdfBinary, wdfPointer]) then
//wdfDefault, wdfStructure, wdfChar, wdfString, wdfFloat
ADispFormat := wdfPointer;
Result := PrintNumber(AResValue, True, ADispFormat);
end;
if ResTypeName <> '' then
Result := ResTypeName + '(' + Result + ')';
PtrDeref := PointerValue.DerefData;
if PtrDeref <> nil then begin
while (PtrDeref.ValueKind = rdkPointerVal) and (PtrDeref.DerefData <> nil) do begin
Result := Result + '^';
PtrDeref := PtrDeref.DerefData;
end;
Result := Result + '^: ' + PrintWatchValueEx(PointerValue.DerefData, wdfDefault, ANestLvl);
end;
end;
rdkFloatVal: begin
case AResValue.FloatPrecission of
dfpSingle: Result := FloatToStrF(AResValue.AsFloat, ffGeneral, 8, 0);
dfpDouble: Result := FloatToStrF(AResValue.AsFloat, ffGeneral, 12, 0);
dfpExtended: Result := FloatToStrF(AResValue.AsFloat, ffGeneral, 15, 0);
end;
end;
rdkChar: Result := PrintChar;
rdkString: Result := QuoteText(AResValue.AsString);
rdkWideString: Result := QuoteWideText(AResValue.AsWideString);
rdkBool: Result := PrintBool;
rdkEnum, rdkEnumVal:
Result := PrintEnum;
rdkSet: Result := PrintSet;
rdkPCharOrString: begin
AResValue.SetSelectedIndex(0); // pchar res
Result := 'PChar: ' + PrintWatchValueEx(AResValue.SelectedEntry, ADispFormat, ANestLvl);
AResValue.SetSelectedIndex(1); // string res
Result := Result + LineEnding
+ 'String: ' + PrintWatchValueEx(AResValue.SelectedEntry, ADispFormat, ANestLvl);
end;
rdkArray: Result := PrintArray(AResValue, ADispFormat, ANestLvl);
rdkStruct: Result := PrintStruct(AResValue, ADispFormat, ANestLvl);
end;
end;
function TWatchResultPrinter.PrintWatchValue(AResValue: TWatchResultData;
ADispFormat: TWatchDisplayFormat): String;
begin
Result := PrintWatchValueEx(AResValue, ADispFormat, -1);
end;
end.

1462
ide/packages/idedebugger/idedebuggerwatchresult.pas
View File

File diff suppressed because it is too large Load Diff

160
ide/packages/idedebugger/test/TestIdeDebugger.lpi Normal file
View File

@ -0,0 +1,160 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="TestIdeDebugger"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
<Item Name="full test -O3">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="TestIdeDebugger"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
</Item>
<Item Name="no assert/check -O3 -gh">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="TestIdeDebugger"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
</Item>
<SharedMatrixOptions Count="7">
<Item1 ID="512719448339" Targets="IdeDebugger" Modes="Default,full test -O3" Value="-Sa"/>
<Item2 ID="026959990514" Targets="IdeDebugger" Modes="Default,full test -O3" Value="-Criot"/>
<Item3 ID="149801562947" Targets="IdeDebugger" Modes="Default,full test -O3" Value="-gt"/>
<Item4 ID="337989334087" Targets="IdeDebugger" Modes="Default,full test -O3" Value="-O-1"/>
<Item5 ID="351599647225" Targets="IdeDebugger" Modes="no assert/check -O3 -gh,full test -O3" Value="-O3"/>
<Item6 ID="654923802929" Targets="IdeDebugger" Modes="no assert/check -O3 -gh" Value="-Sa- -Cr- -Ci- -Co- -Ct-"/>
<Item7 ID="342603141025" Targets="IdeDebugger" Modes="no assert/check -O3 -gh" Value="-Si"/>
</SharedMatrixOptions>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages>
<Item>
<PackageName Value="IdeDebugger"/>
</Item>
<Item>
<PackageName Value="fpcunittestrunner"/>
</Item>
<Item>
<PackageName Value="LCL"/>
</Item>
<Item>
<PackageName Value="FCL"/>
</Item>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="TestIdeDebugger.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="testwatchresult.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TestWatchResult"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="TestIdeDebugger"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

15
ide/packages/idedebugger/test/TestIdeDebugger.lpr Normal file
View File

@ -0,0 +1,15 @@
program TestIdeDebugger;
{$mode objfpc}{$H+}
uses
Interfaces, Forms, GuiTestRunner, TestWatchResult;
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TGuiTestRunner, TestRunner);
Application.Run;
end.

2066
ide/packages/idedebugger/test/testwatchresult.pas Normal file
View File

File diff suppressed because it is too large Load Diff