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

Debugger: Improve array watches / Improve tests

Browse Source 
git-svn-id: trunk@30263 -
This commit is contained in:
martin 2011-04-11 01:28:29 +00:00
parent 1581cce771
commit f724c04b0b
14 changed files with 1416 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2718,6 +2718,7 @@ debugger/frames/debugger_language_exceptions_options.pas svneol=native#text/pasc
debugger/frames/debugger_signals_options.lfm svneol=native#text/plain
debugger/frames/debugger_signals_options.pas svneol=native#text/pascal
debugger/gdbmidebugger.pp svneol=native#text/pascal
debugger/gdbmimiscclasses.pp svneol=native#text/pascal
debugger/gdbtypeinfo.pp svneol=native#text/pascal
debugger/inspectdlg.lfm svneol=native#text/plain
debugger/inspectdlg.pas svneol=native#text/pascal
@ -2746,6 +2747,8 @@ debugger/test/Gdbmi/rungdbmiform.lfm svneol=native#text/plain
debugger/test/Gdbmi/rungdbmiform.pas svneol=native#text/pascal
debugger/test/Gdbmi/testbase.pas svneol=native#text/pascal
debugger/test/Gdbmi/testexception.pas svneol=native#text/pascal
debugger/test/Gdbmi/testgdbmicontrol.lfm svneol=native#text/plain
debugger/test/Gdbmi/testgdbmicontrol.pas svneol=native#text/pascal
debugger/test/Gdbmi/testgdbtype.pas svneol=native#text/pascal
debugger/test/Gdbmi/testwatches.pas svneol=native#text/pascal
debugger/test/debugtest.lpi svneol=native#text/plain

440
debugger/gdbmidebugger.pp
View File

@ -47,7 +47,7 @@ uses
{$IFDEF UNIX}
Unix,BaseUnix,termio,
{$ENDIF}
BaseDebugManager;
BaseDebugManager, GDBMIMiscClasses;
type
TGDBMIProgramInfo = record
@ -71,17 +71,6 @@ type
);
TGDBMICommandFlags = set of TGDBMICommandFlag;
TGDBMIResultFlags = set of (
rfNoMI // flag is set if the output is not MI formatted
// some MI functions return normal output
// some normal functions return MI output
);
TGDBMIExecResult = record
State: TDBGState;
Values: String;
Flags: TGDBMIResultFlags
end;
TGDBMICallback = procedure(const AResult: TGDBMIExecResult; const ATag: PtrInt) of object;
TGDBMIPauseWaitState = (pwsNone, pwsInternal, pwsExternal);
@ -233,7 +222,9 @@ type
function GetChar(const AExpression: String; const AValues: array of const): String; overload;
function GetFloat(const AExpression: String; const AValues: array of const): String;
function GetWideText(const ALocation: TDBGPtr): String;
function GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False): TGDBType;
function GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False;
AFlags: TGDBTypeCreationFlags = [];
AFormat: TWatchDisplayFormat = wdfDefault): TGDBType;
function GetClassName(const AClass: TDBGPtr): String; overload;
function GetClassName(const AExpression: String; const AValues: array of const): String; overload;
function GetInstanceClassName(const AInstance: TDBGPtr): String; overload;
@ -417,46 +408,6 @@ type
{%region ***** TGDBMINameValueList and Parsers ***** }
PGDBMINameValue = ^TGDBMINameValue;
TGDBMINameValue = record
Name: TPCharWithLen;
Value: TPCharWithLen;
end;
{ TGDBMINameValueList }
TGDBMINameValueList = class(TObject)
private
FText: String;
FCount: Integer;
FIndex: array of TGDBMINameValue;
FUseTrim: Boolean;
function Find(const AName : string): PGDBMINameValue;
function GetItem(const AIndex: Integer): PGDBMINameValue;
function GetString(const AIndex: Integer): string;
function GetValue(const AName : string): string;
function GetValuePtr(const AName: string): TPCharWithLen;
public
constructor Create(const AResultValues: String); overload;
constructor Create(const AResultValues: TPCharWithLen); overload;
constructor Create(AResult: TGDBMIExecResult); overload;
constructor Create(const AResultValues: String; const APath: array of String); overload;
constructor Create(AResult: TGDBMIExecResult; const APath: array of String); overload;
procedure Delete(AIndex: Integer);
procedure Init(const AResultValues: String);
procedure Init(AResultValues: PChar; ALength: Integer);
procedure Init(const AResultValues: TPCharWithLen);
procedure SetPath(const APath: String); overload;
procedure SetPath(const APath: array of String); overload;
function IndexOf(const AName: string): Integer;
property Count: Integer read FCount;
property Items[const AIndex: Integer]: PGDBMINameValue read GetItem;
property Values[const AName: string]: string read GetValue;
property ValuesPtr[const AName: string]: TPCharWithLen read GetValuePtr;
property UseTrim: Boolean read FUseTrim write FUseTrim;
end;
{ TGDBMINameValueBasedList }
TGDBMINameValueBasedList = class
@ -4228,316 +4179,6 @@ begin
(* DoEvaluationFinished may be called immediately at this point *)
end;
{ TGDBMINameValueList }
constructor TGDBMINameValueList.Create(const AResultValues: String);
begin
inherited Create;
Init(AResultValues);
end;
constructor TGDBMINameValueList.Create(const AResultValues: TPCharWithLen);
begin
inherited Create;
Init(AResultValues);
end;
constructor TGDBMINameValueList.Create(const AResultValues: String; const APath: array of String);
begin
inherited Create;
Init(AResultValues);
SetPath(APath);
end;
constructor TGDBMINameValueList.Create(AResult: TGDBMIExecResult);
begin
inherited Create;
Init(AResult.Values);
end;
constructor TGDBMINameValueList.Create(AResult: TGDBMIExecResult; const APath: array of String);
begin
inherited Create;
Init(AResult.Values);
SetPath(APath);
end;
procedure TGDBMINameValueList.Delete(AIndex: Integer);
begin
if AIndex < 0 then Exit;
if AIndex >= FCount then Exit;
Dec(FCount);
Move(FIndex[AIndex + 1], FIndex[AIndex], SizeOf(FIndex[0]) * (FCount - AIndex));
end;
function TGDBMINameValueList.Find(const AName: string): PGDBMINameValue;
var
n: Integer;
begin
n := IndexOf(AName);
if n < 0 then Exit(nil);
Result := @FIndex[n];
end;
function TGDBMINameValueList.GetItem(const AIndex: Integer): PGDBMINameValue;
begin
if AIndex < 0 then Exit(nil);
if AIndex >= FCount then Exit(nil);
Result := @FIndex[AIndex];
end;
function TGDBMINameValueList.GetString(const AIndex : Integer) : string;
var
len: Integer;
item: PGDBMINameValue;
begin
Result := '';
if (AIndex < 0) or (AIndex >= FCount) then Exit;
item := @FIndex[AIndex];
if item = nil then Exit;
len := Item^.Name.Len;
if Item^.Value.Ptr <> nil then begin
if (Item^.Value.Ptr-1) = '"' then inc(len, 2);
len := len + 1 + Item^.Value.Len;
end;
SetLength(Result, len);
Move(Item^.Name.Ptr^, Result[1], len);
end;
function TGDBMINameValueList.GetValue(const AName: string): string;
var
item: PGDBMINameValue;
begin
Result := '';
if FCount = 0 then Exit;
item := Find(AName);
if item = nil then Exit;
SetLength(Result, Item^.Value.Len);
Move(Item^.Value.Ptr^, Result[1], Item^.Value.Len);
end;
function TGDBMINameValueList.GetValuePtr(const AName: string): TPCharWithLen;
var
item: PGDBMINameValue;
begin
Result.Ptr := nil;
Result.Len := 0;
if FCount = 0 then Exit;
item := Find(AName);
if item = nil then Exit;
Result := item^.Value;
end;
procedure TGDBMINameValueList.Init(AResultValues: PChar; ALength: Integer);
function FindNextQuote(ACurPtr, AEndPtr: PChar): PChar;
begin
Result := ACurPtr;
while Result <= AEndPtr do
begin
case Result^ of
'\': Inc(Result, 2);
'"': Break;
else
Inc(Result);
end;
end;
end;
function FindClosingBracket(ACurPtr, AEndPtr: PChar): PChar;
var
deep: Integer;
begin
deep := 1;
Result := ACurPtr;
while Result <= AEndPtr do
begin
case Result^ of
'\': Inc(Result);
'"': Result := FindNextQuote(Result + 1, AEndPtr);
'[', '{': Inc(deep);
']', '}': begin
Dec(deep);
if deep = 0 then break;
end;
end;
Inc(Result);
end;
end;
procedure Add(AStartPtr, AEquPtr, AEndPtr: PChar);
var
Item: PGDBMINameValue;
begin
if AEndPtr <= AStartPtr then Exit;
// check space
if Length(FIndex) <= FCount
then SetLength(FIndex, FCount + 16);
Item := @FIndex[FCount];
if AEquPtr < AStartPtr
then begin
// trim spaces
if UseTrim then
begin
while (AStartPtr < AEndPtr) and (AStartPtr^ = #32) do
inc(AStartPtr);
while (AEndPtr > AStartPtr) and (AEndPtr^ = #32) do
dec(AEndPtr);
end;
// only name, no value
Item^.Name.Ptr := AStartPtr;
Item^.Name.Len := PtrUInt(AEndPtr) - PtrUInt(AStartPtr) + 1;
Item^.Value.Ptr := nil;
Item^.Value.Len := 0;
end
else begin
// trim surrounding spaces
if UseTrim then
begin
while (AStartPtr < AEquPtr) and (AStartPtr^ = #32) do
inc(AStartPtr);
while (AEndPtr > AEquPtr) and (AEndPtr^ = #32) do
dec(AEndPtr);
end;
Item^.Name.Ptr := AStartPtr;
Item^.Name.Len := PtrUInt(AEquPtr) - PtrUInt(AStartPtr);
// trim name spaces
if UseTrim then
while (Item^.Name.Len > 0) and (Item^.Name.Ptr[Item^.Name.Len - 1] = #32) do
dec(Item^.Name.Len);
if (AEquPtr < AEndPtr - 1) and (AEquPtr[1] = '"') and (AEndPtr^ = '"')
then begin
// strip surrounding "
Item^.Value.Ptr := AEquPtr + 2;
Item^.Value.Len := PtrUInt(AEndPtr) - PtrUInt(AEquPtr) - 2;
end
else begin
Item^.Value.Ptr := AEquPtr + 1;
Item^.Value.Len := PtrUInt(AEndPtr) - PtrUInt(AEquPtr)
end;
// trim value spaces
if UseTrim then
while (Item^.Value.Len > 0) and (Item^.Value.Ptr[0] = #32) do
begin
inc(Item^.Value.Ptr);
dec(Item^.Value.Len);
end;
end;
Inc(FCount);
end;
var
CurPtr, StartPtr, EquPtr, EndPtr: PChar;
begin
// clear
FCount := 0;
if AResultValues = nil then Exit;
if ALength <= 0 then Exit;
EndPtr := AResultValues + ALength - 1;
// strip surrounding '[]' OR '{}' first
case AResultValues^ of
'[': begin
if EndPtr^ = ']'
then begin
Inc(AResultValues);
Dec(EndPtr);
end;
end;
'{': begin
if EndPtr^ = '}'
then begin
Inc(AResultValues);
Dec(EndPtr);
end;
end;
end;
StartPtr := AResultValues;
CurPtr := AResultValues;
EquPtr := nil;
while CurPtr <= EndPtr do
begin
case CurPtr^ of
'\': Inc(CurPtr); // skip escaped char
'"': CurPtr := FindNextQuote(CurPtr + 1, EndPtr);
'[',
'{': CurPtr := FindClosingBracket(CurPtr + 1, EndPtr);
'=': EquPtr := CurPtr;
',': begin
Add(StartPtr, EquPtr, CurPtr - 1);
Inc(CurPtr);
StartPtr := CurPtr;
Continue;
end;
end;
Inc(CurPtr);
end;
if StartPtr <= EndPtr
then Add(StartPtr, EquPtr, EndPtr);
end;
procedure TGDBMINameValueList.Init(const AResultValues: TPCharWithLen);
begin
Init(AResultValues.Ptr, AResultValues.Len)
end;
procedure TGDBMINameValueList.Init(const AResultValues: String);
begin
FText := AResultValues;
Init(PChar(FText), Length(FText));
end;
procedure TGDBMINameValueList.SetPath(const APath: String);
begin
SetPath([APath]);
end;
procedure TGDBMINameValueList.SetPath(const APath: array of String);
var
i: integer;
Item: PGDBMINameValue;
begin
for i := low(APath) to High(APath) do
begin
item := Find(APath[i]);
if item = nil
then begin
FCount := 0;
Exit;
end;
Init(Item^.Value);
end;
end;
function TGDBMINameValueList.IndexOf(const AName: string): Integer;
var
len: Integer;
begin
len := Length(AName);
Result := 0;
while Result < FCount do begin
if (FIndex[Result].Name.Len = len)
and (strlcomp(FIndex[Result].Name.Ptr, PChar(AName), len) = 0)
then exit;
inc(Result);
end;
Result := -1;
end;
{ =========================================================================== }
{ TGDBMIDebuggerProperties }
@ -8545,11 +8186,12 @@ begin
Result := UTF8Encode(WStr);
end;
function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False): TGDBType;
function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String;
FullTypeInfo: Boolean = False; AFlags: TGDBTypeCreationFlags = [];
AFormat: TWatchDisplayFormat = wdfDefault): TGDBType;
var
R: TGDBMIExecResult;
f: Boolean;
flags: TGDBTypeCreationFlags;
AReq: PGDBPTypeRequest;
begin
(* Analyze what type is in AExpression
@ -8614,20 +8256,30 @@ begin
*)
flags := [];
if tfClassIsPointer in TargetInfo^.TargetFlags
then flags := [gtcfClassIsPointer];
then AFlags := AFlags + [gtcfClassIsPointer];
if FullTypeInfo
then flags := [gtcfFullTypeInfo];
Result := TGdbType.CreateForExpression(AExpression, flags);
then AFlags := AFlags + [gtcfFullTypeInfo];
Result := TGdbType.CreateForExpression(AExpression, AFlags);
while not Result.ProcessExpression do begin
if Result.EvalError
then break;
AReq := Result.EvalRequest;
while AReq <> nil do begin;
while AReq <> nil do begin
if (dcsCanceled in SeenStates) then begin
FreeAndNil(Result);
exit;
end;
f := ExecuteCommand(AReq^.Request, R);
if f and (R.State <> dsError) then
AReq^.Result := ParseTypeFromGdb(R.Values)
if f and (R.State <> dsError) then begin
if AReq^.ReqType = gcrtPType
then AReq^.Result := ParseTypeFromGdb(R.Values)
else begin
AReq^.Result.GdbDescription := R.Values;
AReq^.Result.Kind := ptprkSimple;
end;
end
else
AReq^.Error := R.Values;
AReq := AReq^.Next;
@ -10013,7 +9665,10 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
else // wdfDefault
begin
Result := False;
FTypeInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags);
FTypeInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags, [gtcfExprEvaluate], FDisplayFormat);
if (dcsCanceled in SeenStates)
then exit;
if FTypeInfo = nil
then begin
ResultList := TGDBMINameValueList.Create(LastExecResult.Values);
@ -10021,39 +9676,16 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
FreeAndNil(ResultList);
exit;
end;
if (dcsCanceled in SeenStates)
then exit;
if (saInternalPointer in FTypeInfo.Attributes)
then begin
Result := ExecuteCommand('-data-evaluate-expression %s%s', [AnExpression, '^'], R);
Result := Result and (R.State <> dsError);
if FTypeInfo.HasExprEvaluatedAsText then begin
FTextValue := FTypeInfo.ExprEvaluatedAsText;
FTextValue := DeleteEscapeChars(FTextValue);
Result := True;
FixUpResult(AnExpression, FTypeInfo);
exit;
end;
if (not Result)
and (saRefParam in FTypeInfo.Attributes) and (FTypeInfo.InternalTypeName <> '')
then begin
Result := ExecuteCommand('-data-evaluate-expression %s(%s)', [FTypeInfo.InternalTypeName, AnExpression], R);
Result := Result and (R.State <> dsError);
end;
if (not Result)
then Result := ExecuteCommand('-data-evaluate-expression %s', [AnExpression], R);
Result := Result and (R.State <> dsError);
if (not Result) and (not StoreError)
then exit;
ResultList := TGDBMINameValueList.Create(R.Values);
if Result
then FTextValue := ResultList.Values['value']
else FTextValue := ResultList.Values['msg'];
FTextValue := DeleteEscapeChars(FTextValue);
ResultList.Free;
if Result
then FixUpResult(AnExpression, FTypeInfo);
debugln('############# Not expected to be here');
FTextValue := 'ERROR';
end;
end;
{$IFDEF DBG_WITH_TIMEOUT}

405
debugger/gdbmimiscclasses.pp Normal file
View File

@ -0,0 +1,405 @@
{ ----------------------------------------------
GDBMIMiscClasses.pp - Debugger helper class
----------------------------------------------
This unit contains a helper class for decoding GDB output.
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
unit GDBMIMiscClasses;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Debugger, DebugUtils;
type
TGDBMIResultFlags = set of (
rfNoMI // flag is set if the output is not MI formatted
// some MI functions return normal output
// some normal functions return MI output
);
TGDBMIExecResult = record
State: TDBGState;
Values: String;
Flags: TGDBMIResultFlags
end;
PGDBMINameValue = ^TGDBMINameValue;
TGDBMINameValue = record
Name: TPCharWithLen;
Value: TPCharWithLen;
end;
{ TGDBMINameValueList }
TGDBMINameValueList = class(TObject)
private
FText: String;
FCount: Integer;
FIndex: array of TGDBMINameValue;
FUseTrim: Boolean;
function Find(const AName : string): PGDBMINameValue;
function GetItem(const AIndex: Integer): PGDBMINameValue;
function GetValue(const AName : string): string;
function GetValuePtr(const AName: string): TPCharWithLen;
public
function GetString(const AIndex: Integer): string;
public
constructor Create(const AResultValues: String); overload;
constructor Create(const AResultValues: TPCharWithLen); overload;
constructor Create(AResult: TGDBMIExecResult); overload;
constructor Create(const AResultValues: String; const APath: array of String); overload;
constructor Create(AResult: TGDBMIExecResult; const APath: array of String); overload;
procedure Delete(AIndex: Integer);
procedure Init(const AResultValues: String);
procedure Init(AResultValues: PChar; ALength: Integer);
procedure Init(const AResultValues: TPCharWithLen);
procedure SetPath(const APath: String); overload;
procedure SetPath(const APath: array of String); overload;
function IndexOf(const AName: string): Integer;
property Count: Integer read FCount;
property Items[const AIndex: Integer]: PGDBMINameValue read GetItem;
property Values[const AName: string]: string read GetValue;
property ValuesPtr[const AName: string]: TPCharWithLen read GetValuePtr;
property UseTrim: Boolean read FUseTrim write FUseTrim;
end;
implementation
{ TGDBMINameValueList }
constructor TGDBMINameValueList.Create(const AResultValues: String);
begin
inherited Create;
Init(AResultValues);
end;
constructor TGDBMINameValueList.Create(const AResultValues: TPCharWithLen);
begin
inherited Create;
Init(AResultValues);
end;
constructor TGDBMINameValueList.Create(const AResultValues: String; const APath: array of String);
begin
inherited Create;
Init(AResultValues);
SetPath(APath);
end;
constructor TGDBMINameValueList.Create(AResult: TGDBMIExecResult);
begin
inherited Create;
Init(AResult.Values);
end;
constructor TGDBMINameValueList.Create(AResult: TGDBMIExecResult; const APath: array of String);
begin
inherited Create;
Init(AResult.Values);
SetPath(APath);
end;
procedure TGDBMINameValueList.Delete(AIndex: Integer);
begin
if AIndex < 0 then Exit;
if AIndex >= FCount then Exit;
Dec(FCount);
Move(FIndex[AIndex + 1], FIndex[AIndex], SizeOf(FIndex[0]) * (FCount - AIndex));
end;
function TGDBMINameValueList.Find(const AName: string): PGDBMINameValue;
var
n: Integer;
begin
n := IndexOf(AName);
if n < 0 then Exit(nil);
Result := @FIndex[n];
end;
function TGDBMINameValueList.GetItem(const AIndex: Integer): PGDBMINameValue;
begin
if AIndex < 0 then Exit(nil);
if AIndex >= FCount then Exit(nil);
Result := @FIndex[AIndex];
end;
function TGDBMINameValueList.GetString(const AIndex : Integer) : string;
var
len: Integer;
item: PGDBMINameValue;
begin
Result := '';
if (AIndex < 0) or (AIndex >= FCount) then Exit;
item := @FIndex[AIndex];
if item = nil then Exit;
len := Item^.Name.Len;
if Item^.Value.Ptr <> nil then begin
if (Item^.Value.Ptr-1) = '"' then inc(len, 2);
len := len + 1 + Item^.Value.Len;
end;
SetLength(Result, len);
Move(Item^.Name.Ptr^, Result[1], len);
end;
function TGDBMINameValueList.GetValue(const AName: string): string;
var
item: PGDBMINameValue;
begin
Result := '';
if FCount = 0 then Exit;
item := Find(AName);
if item = nil then Exit;
SetLength(Result, Item^.Value.Len);
Move(Item^.Value.Ptr^, Result[1], Item^.Value.Len);
end;
function TGDBMINameValueList.GetValuePtr(const AName: string): TPCharWithLen;
var
item: PGDBMINameValue;
begin
Result.Ptr := nil;
Result.Len := 0;
if FCount = 0 then Exit;
item := Find(AName);
if item = nil then Exit;
Result := item^.Value;
end;
procedure TGDBMINameValueList.Init(AResultValues: PChar; ALength: Integer);
function FindNextQuote(ACurPtr, AEndPtr: PChar): PChar;
begin
Result := ACurPtr;
while Result <= AEndPtr do
begin
case Result^ of
'\': Inc(Result, 2);
'"': Break;
else
Inc(Result);
end;
end;
end;
function FindClosingBracket(ACurPtr, AEndPtr: PChar): PChar;
var
deep: Integer;
begin
deep := 1;
Result := ACurPtr;
while Result <= AEndPtr do
begin
case Result^ of
'\': Inc(Result);
'"': Result := FindNextQuote(Result + 1, AEndPtr);
'[', '{': Inc(deep);
']', '}': begin
Dec(deep);
if deep = 0 then break;
end;
end;
Inc(Result);
end;
end;
procedure Add(AStartPtr, AEquPtr, AEndPtr: PChar);
var
Item: PGDBMINameValue;
begin
if AEndPtr <= AStartPtr then Exit;
// check space
if Length(FIndex) <= FCount
then SetLength(FIndex, FCount + 16);
Item := @FIndex[FCount];
if AEquPtr < AStartPtr
then begin
// trim spaces
if UseTrim then
begin
while (AStartPtr < AEndPtr) and (AStartPtr^ = #32) do
inc(AStartPtr);
while (AEndPtr > AStartPtr) and (AEndPtr^ = #32) do
dec(AEndPtr);
end;
// only name, no value
Item^.Name.Ptr := AStartPtr;
Item^.Name.Len := PtrUInt(AEndPtr) - PtrUInt(AStartPtr) + 1;
Item^.Value.Ptr := nil;
Item^.Value.Len := 0;
end
else begin
// trim surrounding spaces
if UseTrim then
begin
while (AStartPtr < AEquPtr) and (AStartPtr^ = #32) do
inc(AStartPtr);
while (AEndPtr > AEquPtr) and (AEndPtr^ = #32) do
dec(AEndPtr);
end;
Item^.Name.Ptr := AStartPtr;
Item^.Name.Len := PtrUInt(AEquPtr) - PtrUInt(AStartPtr);
// trim name spaces
if UseTrim then
while (Item^.Name.Len > 0) and (Item^.Name.Ptr[Item^.Name.Len - 1] = #32) do
dec(Item^.Name.Len);
if (AEquPtr < AEndPtr - 1) and (AEquPtr[1] = '"') and (AEndPtr^ = '"')
then begin
// strip surrounding "
Item^.Value.Ptr := AEquPtr + 2;
Item^.Value.Len := PtrUInt(AEndPtr) - PtrUInt(AEquPtr) - 2;
end
else begin
Item^.Value.Ptr := AEquPtr + 1;
Item^.Value.Len := PtrUInt(AEndPtr) - PtrUInt(AEquPtr)
end;
// trim value spaces
if UseTrim then
while (Item^.Value.Len > 0) and (Item^.Value.Ptr[0] = #32) do
begin
inc(Item^.Value.Ptr);
dec(Item^.Value.Len);
end;
end;
Inc(FCount);
end;
var
CurPtr, StartPtr, EquPtr, EndPtr: PChar;
begin
// clear
FCount := 0;
if AResultValues = nil then Exit;
if ALength <= 0 then Exit;
EndPtr := AResultValues + ALength - 1;
// strip surrounding '[]' OR '{}' first
case AResultValues^ of
'[': begin
if EndPtr^ = ']'
then begin
Inc(AResultValues);
Dec(EndPtr);
end;
end;
'{': begin
if EndPtr^ = '}'
then begin
Inc(AResultValues);
Dec(EndPtr);
end;
end;
end;
StartPtr := AResultValues;
CurPtr := AResultValues;
EquPtr := nil;
while CurPtr <= EndPtr do
begin
case CurPtr^ of
'\': Inc(CurPtr); // skip escaped char
'"': CurPtr := FindNextQuote(CurPtr + 1, EndPtr);
'[',
'{': CurPtr := FindClosingBracket(CurPtr + 1, EndPtr);
'=': EquPtr := CurPtr;
',': begin
Add(StartPtr, EquPtr, CurPtr - 1);
Inc(CurPtr);
StartPtr := CurPtr;
Continue;
end;
end;
Inc(CurPtr);
end;
if StartPtr <= EndPtr
then Add(StartPtr, EquPtr, EndPtr);
end;
procedure TGDBMINameValueList.Init(const AResultValues: TPCharWithLen);
begin
Init(AResultValues.Ptr, AResultValues.Len)
end;
procedure TGDBMINameValueList.Init(const AResultValues: String);
begin
FText := AResultValues;
Init(PChar(FText), Length(FText));
end;
procedure TGDBMINameValueList.SetPath(const APath: String);
begin
SetPath([APath]);
end;
procedure TGDBMINameValueList.SetPath(const APath: array of String);
var
i: integer;
Item: PGDBMINameValue;
begin
for i := low(APath) to High(APath) do
begin
item := Find(APath[i]);
if item = nil
then begin
FCount := 0;
Exit;
end;
Init(Item^.Value);
end;
end;
function TGDBMINameValueList.IndexOf(const AName: string): Integer;
var
len: Integer;
begin
len := Length(AName);
Result := 0;
while Result < FCount do begin
if (FIndex[Result].Name.Len = len)
and (strlcomp(FIndex[Result].Name.Ptr, PChar(AName), len) = 0)
then exit;
inc(Result);
end;
Result := -1;
end;
end.

525
debugger/gdbtypeinfo.pp
View File

@ -34,7 +34,7 @@ unit GDBTypeInfo;
interface
uses
Classes, SysUtils, Debugger, LclProc, DebugUtils;
Classes, SysUtils, Debugger, LclProc, DebugUtils, GDBMIMiscClasses;
(*
ptype = {
@ -136,6 +136,8 @@ type
ptprfPointer,
ptprfNoStructure, // for Class or Record: no full class declaration, type ends after class keyword; DWARF "whatis TFoo"
// includes "record {...}"
ptprfDynArray,
ptprfNoBounds, // no bounds for array found
ptprfEmpty
);
TGDBPTypeResultFlags = set of TGDBPTypeResultFlag;
@ -148,12 +150,17 @@ type
Flags: TGDBPTypeResultFlags;
Kind: TGDBPTypeResultKind;
Name, BaseName: TPCharWithLen; // BaseName is without ^&
Declaration: TPCharWithLen;
SubName, BaseSubName: TPCharWithLen; // type of array entry, or set-enum
BoundLow, BoundHigh: TPCharWithLen;
Declaration, BaseDeclaration: TPCharWithLen; // BaseDeclaration only for Array and Set types
end;
TGDBCommandRequestType = (gcrtPType, gcrtEvalExpr);
PGDBPTypeRequest = ^TGDBPTypeRequest;
TGDBPTypeRequest = record
Request: string;
ReqType: TGDBCommandRequestType;
Result: TGDBPTypeResult;
Error: string;
Next: PGDBPTypeRequest;
@ -168,18 +175,25 @@ type
{ TGDBType }
TGDBTypeCreationFlag = (gtcfClassIsPointer, gtcfFullTypeInfo, gtcfExprIsType);
TGDBTypeCreationFlag = (gtcfClassIsPointer,
gtcfFullTypeInfo,
gtcfSkipTypeName,
gtcfExprIsType,
gtcfExprEvaluate);
TGDBTypeCreationFlags = set of TGDBTypeCreationFlag;
TGDBTypeProcessState =
(gtpsInitial,
(gtpsInitial, gtpsInitialSimple,
gtpsSimplePointer,
gtpsClass, gtpsClassPointer, gtpsClassAncestor,
gtpsArray, gtpsArrayEntry,
gtpsEvalExpr,
gtpsFinished
);
TGDBTypeProcessRequest =
(gptrPTypeExpr, gptrWhatisExpr, gptrPTypeOfWhatis,
gptrPTypeExprDeRef, gptrPTypeExprDeDeRef // "Foo^", "Foo^^" for Foo=Object, or &Object
gptrPTypeExprDeRef, gptrPTypeExprDeDeRef, // "Foo^", "Foo^^" for Foo=Object, or &Object
gptrEvalExpr, gptrEvalExprDeRef, gptrEvalExprCast
);
TGDBTypeProcessRequests = set of TGDBTypeProcessRequest;
@ -187,28 +201,48 @@ type
private
FInternalTypeName: string;
private
FEvalError: boolean;
FEvalRequest: PGDBPTypeRequest;
FExpression: string;
FExpression, FOrigExpression: string;
FCreationFlags: TGDBTypeCreationFlags;
// Value-Eval
FExprEvaluatedAsText: String;
FHasExprEvaluatedAsText: Boolean;
FExprEvaluateFormat: TWatchDisplayFormat;
// Sub-Types (FNext is managed by creator / linked list)
FFirstProcessingSubType, FNextProcessingSubType: TGDBType;
FTypeInfoAncestor: TGDBType;
FTypeInfoArrayExpression: TGDBType;
// Gdb-Requests
FEvalError: boolean;
FEvalRequest, FLastEvalRequest: PGDBPTypeRequest;
FProcessState: TGDBTypeProcessState;
FProccesReuestsMade: TGDBTypeProcessRequests;
FReqResults: Array [TGDBTypeProcessRequest] of TGDBPTypeRequest;
FArrayEntryIndexExpr: String;
procedure AddTypeReq(var AReq :TGDBPTypeRequest; const ACmd: string = '');
procedure AddSubType(ASubType :TGDBType);
function GetIsFinished: Boolean;
function RequireRequests(ARequired: TGDBTypeProcessRequests): Boolean;
function IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
protected
procedure Init; override;
public
constructor CreateForExpression(const AnExpression: string;
const AFlags: TGDBTypeCreationFlags);
const AFlags: TGDBTypeCreationFlags;
AFormat: TWatchDisplayFormat = wdfDefault);
destructor Destroy; override;
function ProcessExpression: Boolean;
property EvalRequest: PGDBPTypeRequest read FEvalRequest;
property EvalError: boolean read FEvalError;
property IsFinished: Boolean read GetIsFinished;
property HasExprEvaluatedAsText: Boolean read FHasExprEvaluatedAsText;
property ExprEvaluatedAsText: String read FExprEvaluatedAsText;
public
// InternalTypeName: include ^ for TObject, if needed
property InternalTypeName: string read FInternalTypeName;
@ -484,8 +518,18 @@ begin
Result.Name.Len := 0;
Result.BaseName.Ptr := nil;
Result.BaseName.Len := 0;
Result.SubName.Ptr := nil;
Result.SubName.Len := 0;
Result.BaseSubName.Ptr := nil;
Result.BaseSubName.Len := 0;
Result.Declaration.Ptr := nil;
Result.Declaration.Len := 0;
Result.BaseDeclaration.Ptr := nil;
Result.BaseDeclaration.Len := 0;
Result.BoundLow.Ptr := nil;
Result.BoundLow.Len := 0;
Result.BoundHigh.Ptr := nil;
Result.BoundHigh.Len := 0;
If ATypeText = '' then exit;
(* // Clean the gdb outpu, remove ~"...."; replace \n by #13
@ -558,7 +602,8 @@ begin
if CurPtr^ = '=' then begin
// un-nmaed type
// type = |= ...
// un-named type
inc(CurPtr);
SkipSpaces(CurPtr);
@ -568,6 +613,8 @@ begin
Result.Kind := ptprkEnum;
Result.Declaration.Ptr := CurPtr;
Result.Declaration.Len := i;
Result.BaseDeclaration.Ptr := CurPtr;
Result.BaseDeclaration.Len := i;
exit;
end;
@ -582,12 +629,19 @@ begin
else
begin
HelpPtr2 := EndPtr;
if CurPtr^ = '(' then begin
// type in brackets, eg ^(array...)
inc(CurPtr);
if HelpPtr2^ = ')' then dec(HelpPtr2)
end;
SkipSpaces(CurPtr); // shouldn'tever happen
HelpPtr := CurPtr;
while HelpPtr^ in ['&', '^'] do inc(DeclPtr); // shouldn't happen
Result.BaseDeclaration.Ptr := HelpPtr;
Result.BaseDeclaration.Len := HelpPtr2 - HelpPtr + 1;
Result.Kind := CheckKeyword;
if Result.Kind = ptprkSimple then begin
// we may have type = NAME = ....
@ -616,6 +670,8 @@ begin
Result.Kind := ptprkEnum;
Result.Declaration.Ptr := CurPtr;
Result.Declaration.Len := i;
Result.BaseDeclaration.Ptr := CurPtr;
Result.BaseDeclaration.Len := i;
exit;
end;
@ -631,6 +687,8 @@ begin
while EndPtr^ = ' ' do dec(EndPtr);
Result.Declaration.Ptr := CurPtr;
Result.Declaration.Len := EndPtr - CurPtr + 1;
Result.BaseDeclaration.Ptr := CurPtr;
Result.BaseDeclaration.Len := EndPtr - CurPtr + 1;
exit;
end;
end;
@ -661,11 +719,68 @@ begin
if CurPtr^ <> '<' then begin;
Result.Declaration.Ptr := DeclPtr;
Result.Declaration.Len := EndPtr - DeclPtr + 1;
CurPtr := Result.BaseDeclaration.Ptr + 3;
SkipSpaces(CurPtr);
if (CurPtr^ in ['o', 'O']) and ((CurPtr+1)^ in ['f', 'F']) then begin
CurPtr := CurPtr + 2;
SkipSpaces(CurPtr);
if (CurPtr^ = '=') then begin
CurPtr := CurPtr + 1;
SkipSpaces(CurPtr);
end;
HelpPtr2 := Result.BaseDeclaration.Ptr + Result.BaseDeclaration.Len;
Result.BaseSubName.Ptr := CurPtr;
Result.BaseSubName.Len := HelpPtr2 - CurPtr;
while (CurPtr^ in ['^', '&']) and (CurPtr < EndPtr) do inc(CurPtr);
Result.SubName.Ptr := CurPtr;
Result.SubName.Len := HelpPtr2 - CurPtr;
end;
end
else begin
Result.BaseDeclaration.Ptr := nil;
Result.BaseDeclaration.Len := 0;
end;
end;
ptprkArray: begin
Result.Declaration.Ptr := DeclPtr;
Result.Declaration.Len := EndPtr - DeclPtr + 1;
CurPtr := Result.BaseDeclaration.Ptr + 5;
SkipSpaces(CurPtr);
include(Result.Flags, ptprfNoBounds);
include(Result.Flags, ptprfDynArray);
if CurPtr^ = '[' then begin
inc(CurPtr);
HelpPtr := CurPtr;
while (HelpPtr^ in ['-', '0'..'9']) and (HelpPtr < EndPtr - 3) do inc (HelpPtr);
if (HelpPtr > CurPtr) and (HelpPtr^ = '.') and ((HelpPtr+1)^ = '.') then begin
HelpPtr2 := HelpPtr + 2;
while (HelpPtr2^ in ['-', '0'..'9']) and (HelpPtr2 < EndPtr - 1) do inc (HelpPtr2);
if (HelpPtr2 > HelpPtr) and (HelpPtr2^ = ']') then begin
exclude(Result.Flags, ptprfNoBounds);
Result.BoundLow.Ptr := CurPtr;
Result.BoundLow.Len := HelpPtr - CurPtr;
Result.BoundHigh.Ptr := HelpPtr + 2;
Result.BoundHigh.Len := HelpPtr2 - (HelpPtr + 2);
if (HelpPtr2 - CurPtr <> 5) or (strlcomp(Result.BoundLow.Ptr, PChar('0..-1'), 5) <> 0) then
exclude(Result.Flags, ptprfDynArray);
CurPtr := HelpPtr2 + 1;
end;
end;
end;
SkipSpaces(CurPtr);
if (CurPtr^ in ['o', 'O']) and ((CurPtr+1)^ in ['f', 'F']) then begin
CurPtr := CurPtr + 2;
SkipSpaces(CurPtr);
//HelpPtr := CurPtr;
//while (not (HelpPtr^ in [#0..#31, ' '])) and (HelpPtr < EndPtr) do inc(HelpPtr);
HelpPtr2 := Result.BaseDeclaration.Ptr + Result.BaseDeclaration.Len;
Result.BaseSubName.Ptr := CurPtr;
Result.BaseSubName.Len := HelpPtr2 - CurPtr;
while (CurPtr^ in ['^', '&']) and (CurPtr < EndPtr) do inc(CurPtr);
Result.SubName.Ptr := CurPtr;
Result.SubName.Len := HelpPtr2 - CurPtr;
end;
end;
ptprkProcedure, ptprkFunction: begin
Result.Declaration.Ptr := DeclPtr;
@ -683,6 +798,21 @@ begin
AReq.Error := '';
AReq.Next := FEvalRequest;
FEvalRequest := @AReq;
if FLastEvalRequest = nil then
FLastEvalRequest := @AReq;
end;
procedure TGDBType.AddSubType(ASubType: TGDBType);
begin
if ASubType.ProcessExpression then
exit;
ASubType.FNextProcessingSubType := FFirstProcessingSubType;
FFirstProcessingSubType := ASubType;
end;
function TGDBType.GetIsFinished: Boolean;
begin
Result := FProcessState = gtpsFinished;
end;
function TGDBType.RequireRequests(ARequired: TGDBTypeProcessRequests): Boolean;
@ -701,8 +831,23 @@ function TGDBType.RequireRequests(ARequired: TGDBTypeProcessRequests): Boolean;
Result := '(' + Result + ')';
end;
function GetReqText(AReq: TGDBTypeProcessRequest): String;
begin
case areq of
gptrPTypeExpr: Result := 'ptype ' + FExpression;
gptrWhatisExpr: Result := 'whatis ' + FExpression;
gptrPTypeOfWhatis: Result := 'ptype ' + PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName);
gptrPTypeExprDeRef: Result := 'ptype ' + ApplyBrackets(FExpression) + '^';
gptrPTypeExprDeDeRef: Result := 'ptype ' + ApplyBrackets(FExpression) + '^^';
gptrEvalExpr: Result := '-data-evaluate-expression '+FExpression;
gptrEvalExprDeRef: Result := '-data-evaluate-expression '+FExpression+'^';
gptrEvalExprCast: Result := '-data-evaluate-expression '+InternalTypeName+'('+FExpression+')';
end;
end;
var
NeededReq: TGDBTypeProcessRequests;
i: TGDBTypeProcessRequest;
begin
NeededReq := ARequired - FProccesReuestsMade;
Result := NeededReq = [];
@ -715,21 +860,13 @@ begin
end;
FProccesReuestsMade := FProccesReuestsMade + NeededReq;
if gptrPTypeExpr in NeededReq then
AddTypeReq(FReqResults[gptrPTypeExpr], 'ptype ' + FExpression);
if gptrWhatisExpr in NeededReq then
AddTypeReq(FReqResults[gptrWhatisExpr], 'whatis ' + FExpression);
if gptrPTypeExprDeRef in NeededReq then
AddTypeReq(FReqResults[gptrPTypeExprDeRef], 'ptype ' + ApplyBrackets(FExpression) + '^');
if gptrPTypeExprDeDeRef in NeededReq then
AddTypeReq(FReqResults[gptrPTypeExprDeDeRef], 'ptype ' + ApplyBrackets(FExpression) + '^^');
if gptrPTypeOfWhatis in NeededReq then
AddTypeReq(FReqResults[gptrPTypeOfWhatis], 'ptype ' + PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName));
for i := low(TGDBTypeProcessRequest) to high(TGDBTypeProcessRequest) do
if i in NeededReq then begin
AddTypeReq(FReqResults[i], GetReqText(i));
if i in [gptrEvalExpr, gptrEvalExprDeRef, gptrEvalExprCast]
then FReqResults[i].ReqType := gcrtEvalExpr
else FReqResults[i].ReqType := gcrtPType;
end;
end;
function TGDBType.IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
@ -746,26 +883,35 @@ begin
end;
constructor TGDBType.CreateForExpression(const AnExpression: string;
const AFlags: TGDBTypeCreationFlags);
const AFlags: TGDBTypeCreationFlags; AFormat: TWatchDisplayFormat = wdfDefault);
begin
Create(skSimple, ''); // initialize
FInternalTypeName := '';
FEvalError := False;
FExpression := AnExpression;
FOrigExpression := FExpression;
FCreationFlags := AFlags;
FExprEvaluateFormat := AFormat;
FEvalRequest := nil;
FFirstProcessingSubType := nil;
FNextProcessingSubType := nil;
FProcessState := gtpsInitial;
FHasExprEvaluatedAsText := False;
end;
destructor TGDBType.Destroy;
begin
inherited Destroy;
FreeAndNil(FTypeInfoAncestor);
FreeAndNil(FTypeInfoArrayExpression);
end;
function TGDBType.ProcessExpression: Boolean;
var
Lines: TStringList;
procedure ProcessInitialSimple; forward;
procedure ProcessSimplePointer; forward;
function ClearAmpersand(s: string): string;
var i: Integer;
@ -1007,36 +1153,22 @@ var
procedure ProcessClassAncestor;
var
r: PGDBPTypeRequest;
i: Integer;
begin
FProcessState := gtpsClassAncestor;
If FTypeInfoAncestor = nil then begin
FTypeInfoAncestor := TGDBType.CreateForExpression(FAncestor, FCreationFlags + [gtcfExprIsType]);
AddSubType(FTypeInfoAncestor);
end;
if not FTypeInfoAncestor.IsFinished then
exit;
if FTypeInfoAncestor.ProcessExpression then begin
// add ancestor
if FTypeInfoAncestor.FFields <> nil then
for i := 0 to FTypeInfoAncestor.FFields.Count - 1 do
FFields.Add(FTypeInfoAncestor.FFields[i]);
Result := True;
end
else begin
if FTypeInfoAncestor.EvalError then begin
debugln('TGDBType: EvaleError in ancestor');
Result := True; // unable to get ancestor
exit;
end;
if (EvalRequest = nil) then
FEvalRequest := FTypeInfoAncestor.EvalRequest
else begin
r := FEvalRequest;
while r^.Next <> nil do r := r^.Next;
r^.Next := FTypeInfoAncestor.EvalRequest;
end;
end;
// add ancestor
if FTypeInfoAncestor.FFields <> nil then
for i := 0 to FTypeInfoAncestor.FFields.Count - 1 do
FFields.Add(FTypeInfoAncestor.FFields[i]);
Result := True;
end;
procedure ProcessClass;
@ -1081,6 +1213,79 @@ var
end;
{%endregion * Class * }
{%region * Array * }
procedure ProcessArray;
var
PTypeResult: TGDBPTypeResult;
begin
FProcessState := gtpsArray;
PTypeResult := FReqResults[gptrPTypeExpr].Result;
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
if (not IsReqError(gptrPTypeExprDeRef)) then
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result
end;
if (ptprfDynArray in PTypeResult.Flags)
then include(FAttributes, saInternalPointer);
if (saInternalPointer in FAttributes) then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
end;
if (saInternalPointer in FAttributes) and (not IsReqError(gptrPTypeExprDeRef)) then
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result
else
PTypeResult := FReqResults[gptrPTypeExpr].Result;
if ptprfPointer in PTypeResult.Flags then begin
ProcessSimplePointer;
exit;
end;
FKind := skSimple;
if not(gtcfSkipTypeName in FCreationFlags) then begin
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True);
end;
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
Result := True;
// ====> DONE
end;
{%endregion * Array * }
{%region * ArrayEntry * }
procedure ProcessArrayEntryInit(PosIndexStart, PosIndexEnd: Integer);
begin
FProcessState := gtpsArrayEntry;
FTypeInfoArrayExpression := TGDBType.CreateForExpression
(copy(FExpression, 1, PosIndexStart-1),
FCreationFlags * [gtcfClassIsPointer] + [gtcfSkipTypeName]);
AddSubType(FTypeInfoArrayExpression);
// include []
FArrayEntryIndexExpr := Copy(FExpression, PosIndexStart, PosIndexEnd - PosIndexStart + 1);
end;
procedure ProcessArrayEntry;
begin
FProcessState := gtpsArrayEntry;
if not FTypeInfoArrayExpression.IsFinished then exit;
if saInternalPointer in FTypeInfoArrayExpression.FAttributes
then begin
FExpression := FTypeInfoArrayExpression.FExpression + '^' + FArrayEntryIndexExpr;
end;
ProcessInitialSimple;
end;
{%endregion * ArrayEntry * }
{%region * Simple * }
procedure ProcessSimplePointer;
begin
@ -1106,19 +1311,97 @@ var
end;
{%endregion * Simple * }
procedure ProcessInitial;
var
i: Integer;
{%region * EvaluateExpression * }
procedure EvaluateExpression;
procedure ParseFromResult(AGdbDesc, AField: String);
var
ResultList: TGDBMINameValueList;
begin
ResultList := TGDBMINameValueList.Create(AGdbDesc);
FExprEvaluatedAsText := ResultList.Values['value'];
FHasExprEvaluatedAsText := True;
//FTextValue := DeleteEscapeChars(FTextValue);
ResultList.Free;
end;
begin
if FReqResults[gptrPTypeExpr].Error <> '' then begin
FEvalError := True;
FProcessState := gtpsEvalExpr;
if not(gtcfExprEvaluate in FCreationFlags) then begin
Result := True;
exit;
end;
if FExprEvaluateFormat <> wdfDefault then begin;
Result := True;
exit;
end;
if (ptprfParamByRef in FReqResults[gptrPTypeExpr].Result.Flags) then
if (saInternalPointer in FAttributes) then begin
if not RequireRequests([gptrEvalExprDeRef]) then exit;
if not IsReqError(gptrEvalExprDeRef, False) then begin
ParseFromResult(FReqResults[gptrEvalExprDeRef].Result.GdbDescription, 'value');
Result := True;
exit;
end;
end;
if (saRefParam in FAttributes) then begin
if not RequireRequests([gptrEvalExprCast]) then exit;
if not IsReqError(gptrEvalExprCast, False) then begin
ParseFromResult(FReqResults[gptrEvalExprCast].Result.GdbDescription, 'value');
Result := True;
exit;
end;
end;
if not RequireRequests([gptrEvalExpr]) then exit;
if not IsReqError(gptrEvalExpr, False) then begin
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'value');
Result := True;
exit;
end;
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'msg');
Result := True;
end;
{%endregion * EvaluateExpression * }
procedure ProcessInitialSimple;
var
i: Integer;
PTypeResult: TGDBPTypeResult;
wi: TGDBTypeProcessRequests;
begin
FProcessState := gtpsInitialSimple;
if (gtcfFullTypeInfo in FCreationFlags)
and not (gtcfExprIsType in FCreationFlags)
then wi := [gptrWhatisExpr]
else wi := [];
if not RequireRequests([gptrPTypeExpr]+wi)
then exit;
if IsReqError(gptrPTypeExpr) then begin
FEvalError := True;
exit;
end;
PTypeResult := FReqResults[gptrPTypeExpr].Result;
if (ptprfParamByRef in PTypeResult.Flags) then
include(FAttributes, saRefParam);
case FReqResults[gptrPTypeExpr].Result.Kind of
// In DWARF, some Dynamic Array, are pointer to there base type
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
if (not IsReqError(gptrPTypeExprDeRef)) and
(FReqResults[gptrPTypeExprDeRef].Result.Kind = ptprkArray)
then begin
ProcessArray;
exit;
end;
end;
case PTypeResult.Kind of
//ptprkError: ;
//ptprkSimple: ;
ptprkClass: begin
@ -1128,25 +1411,26 @@ var
//ptprkRecord: ;
//ptprkEnum: ;
//ptprkSet: ;
//ptprkArray: ;
ptprkArray: begin
ProcessArray;
exit;
end;
//ptprkProcedure: ;
//ptprkFunction: ;
end;
if (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
and ( (FReqResults[gptrPTypeExpr].Result.Kind in
[ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
or ( (gtcfClassIsPointer in FCreationFlags)
and (FReqResults[gptrPTypeExpr].Result.Kind in [ptprkProcedure, ptprkFunction]) )
if (ptprfPointer in PTypeResult.Flags)
and ( (PTypeResult.Kind in [ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
or ( (gtcfClassIsPointer in FCreationFlags) and
(PTypeResult.Kind in [ptprkProcedure, ptprkFunction]) )
)
then begin
ProcessSimplePointer;
exit;
end;
if (ptprfParamByRef in FReqResults[gptrPTypeExpr].Result.Flags)
and not (FReqResults[gptrPTypeExpr].Result.Kind in [ptprkError])
if (ptprfParamByRef in PTypeResult.Flags)
and not (PTypeResult.Kind in [ptprkError])
then begin
// could be a pointer // need ptype of whatis
if not RequireRequests([gptrWhatisExpr])
@ -1169,7 +1453,7 @@ var
end;
end;
case FReqResults[gptrPTypeExpr].Result.Kind of
case PTypeResult.Kind of
ptprkError: begin
// could be empty pointer @ArgProcedure
Result := True; // nothing to be done, keep simple type, no name
@ -1184,6 +1468,10 @@ var
Result := True;
// ====> DONE
end;
ptprkClass: begin
Assert(False, 'GDBTypeInfo Class: Should be handled before');
ProcessClass;
end;
ptprkRecord: begin
SetTypNameFromReq(gptrWhatisExpr, True);
DoRecord;
@ -1192,7 +1480,7 @@ var
end;
ptprkEnum: begin
SetTypNameFromReq(gptrWhatisExpr, True);
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
DoEnum;
Result := True;
// ====> DONE
@ -1203,7 +1491,7 @@ var
SetTypNameFromReq(gptrWhatisExpr, True);
// TODO: resolve enum-name (set of SomeEnum) if mode-full ?
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
i := pos('set of = ', FTypeDeclaration);
if i > 0 then delete(FTypeDeclaration, i+7, 3);
DoSet;
@ -1211,19 +1499,13 @@ var
// ====> DONE
end;
ptprkArray: begin
if not RequireRequests([gptrWhatisExpr])
then exit;
FKind := skSimple;
SetTypNameFromReq(gptrWhatisExpr, True);
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
Result := True;
// ====> DONE
Assert(False, 'GDBTypeInfo Array: Should be handled before');
ProcessArray;
end;
ptprkProcedure: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
and (ptprfPointer in PTypeResult.Flags)
then begin
ProcessSimplePointer;
exit;
@ -1240,7 +1522,7 @@ var
ptprkFunction: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
and (ptprfPointer in PTypeResult.Flags)
then begin
ProcessSimplePointer;
exit;
@ -1257,37 +1539,108 @@ var
end;
end;
procedure ProcessInitial;
var
p, p1: PChar;
begin
if FExpression = '' then begin;
ProcessInitialSimple;
exit;
end;
// parse expression
// Array entry ?
p := @FExpression[length(FExpression)];
while (p^ in [#9, #32]) and (p > @FExpression[1]) do dec(p);
if p^ = ']' then begin
p1 := p;
while (not (p1^ = '[')) and (p1 > @FExpression[1]) do dec(p1);
ProcessArrayEntryInit(p1 - @FExpression[1]+1, p - @FExpression[1]+1);
exit;
end;
ProcessInitialSimple;
end;
procedure MergeSubProcessRequests;
var
SubType: TGDBType;
begin
SubType := FFirstProcessingSubType;
while SubType <> nil do begin
if (FEvalRequest = nil)
then FEvalRequest := SubType.FEvalRequest
else FLastEvalRequest^.Next := SubType.FEvalRequest;;
FLastEvalRequest := SubType.FLastEvalRequest;
SubType := SubType.FNextProcessingSubType;
end;
end;
function ProcessSubProcessRequests: Boolean;
var
SubType, PrevSubType: TGDBType;
begin
Result := False;
PrevSubType := nil;
SubType := FFirstProcessingSubType;
Result := SubType = nil;
while SubType <> nil do begin
if SubType.ProcessExpression then begin
Result := True;
if PrevSubType = nil
then FFirstProcessingSubType := SubType.FNextProcessingSubType
else PrevSubType.FNextProcessingSubType := SubType.FNextProcessingSubType;
end;
PrevSubType := SubType;
SubType := SubType.FNextProcessingSubType;
end;
end;
var
OldProcessState: TGDBTypeProcessState;
OldReqMade: TGDBTypeProcessRequests;
wi: TGDBTypeProcessRequests;
begin
Result := False;
FEvalRequest := nil;
FLastEvalRequest := nil;
Lines := nil;
if FFirstProcessingSubType <> nil then begin
if not ProcessSubProcessRequests then begin
MergeSubProcessRequests;
exit;
end;
end;
OldProcessState := FProcessState;
OldReqMade := FProccesReuestsMade;
if (gtcfFullTypeInfo in FCreationFlags)
and not (gtcfExprIsType in FCreationFlags)
then wi := [gptrWhatisExpr]
else wi := [];
if not RequireRequests([gptrPTypeExpr]+wi)
then exit;
case FProcessState of
gtpsInitial: ProcessInitial;
gtpsInitialSimple: ProcessInitialSimple;
gtpsSimplePointer: ProcessSimplePointer;
gtpsClass: ProcessClass;
gtpsClassPointer: ProcessClassPointer;
gtpsClassAncestor: ProcessClassAncestor;
gtpsArray: ProcessArray;
gtpsArrayEntry: ProcessArrayEntry;
gtpsEvalExpr: EvaluateExpression;
end;
FreeAndNil(Lines);
if Result and not(FProcessState = gtpsEvalExpr)
then begin
Result := False;
EvaluateExpression;
end;
if Result
then FProcessState := gtpsFinished;
if FFirstProcessingSubType <> nil then
MergeSubProcessRequests
else
if (FProcessState = OldProcessState) and (FProccesReuestsMade = OldReqMade)
and (not Result) and (FEvalRequest = nil)
then begin

97
debugger/test/Gdbmi/TestApps/WatchesPrgArray.inc
View File

@ -6,32 +6,125 @@
{$IFDEF FooFunc_Local}
//var
VarArrayHelperI: Integer;
VarDynIntArray: TDynIntArray;
VarDynIntArrayP: ^TDynIntArray;
VarStatIntArray: TStatIntArray;
VarPDynIntArray: PDynIntArray;
VarPStatIntArray: PStatIntArray;
VarDynIntArrayA: Array of Integer;
VarStatIntArrayA: Array [5..9] of Integer;
VarDynObjArray: TDynObjArray;
VarStatObjArray: TStatObjArray;
VarPDynObjArray: PDynObjArray;
VarPStatObjArray: PStatObjArray;
VarDynObjArrayA: Array of TObjectInArray;
VarStatObjArrayA: Array [5..9] of TObjectInArray;
VarDynRecArray: TDynRecArray;
VarStatRecArray: TStatRecArray;
VarPDynRecArray: PDynRecArray;
VarPStatRecArray: PStatRecArray;
VarDynRecArrayA: Array of TRecordInArray;
VarStatRecArrayA: Array [5..9] of TRecordInArray;
VarDynIntArray2: TDynIntArray2;
VarDynIntArray2A: Array of TDynIntArray;
VarStatIntArray2A: Array [5..9] of TDynIntArray;
VarDynIntArray2P: Array of PDynIntArray;
VarStatIntArray2P: Array [5..9] of PDynIntArray;
{$ENDIF}
{$IFDEF FooFunc_Body}
//begin
SetLength(VarDynIntArray,2);
SetLength(VarDynIntArrayA,2);
VarStatIntArray[5] := 1;
VarStatIntArrayA[5] := 1;
VarPDynIntArray := @VarDynIntArray;
VarPStatIntArray := @VarStatIntArray;
VarDynIntArrayP := @VarDynIntArray;
for VarArrayHelperI := low(VarDynIntArray) to high (VarDynIntArray) do
VarDynIntArray[VarArrayHelperI] := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarStatIntArray) to high (VarStatIntArray) do
VarStatIntArray[VarArrayHelperI] := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarDynIntArrayA) to high (VarDynIntArrayA) do
VarDynIntArrayA[VarArrayHelperI] := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarStatIntArrayA) to high (VarStatIntArrayA) do
VarStatIntArrayA[VarArrayHelperI] := 2 * VarArrayHelperI;
SetLength(VarDynObjArray,2);
SetLength(VarDynObjArrayA,2);
VarPDynObjArray := @VarDynObjArray;
VarPStatObjArray := @VarStatObjArray;
for VarArrayHelperI := low(VarDynObjArray) to high (VarDynObjArray) do begin
VarDynObjArray[VarArrayHelperI] := TObjectInArray.Create;
VarDynObjArray[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
end;
for VarArrayHelperI := low(VarStatObjArray) to high (VarStatObjArray) do begin
VarStatObjArray[VarArrayHelperI] := TObjectInArray.Create;
VarStatObjArray[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
end;
for VarArrayHelperI := low(VarDynObjArrayA) to high (VarDynObjArrayA) do begin
VarDynObjArrayA[VarArrayHelperI] := TObjectInArray.Create;
VarDynObjArrayA[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
end;
for VarArrayHelperI := low(VarStatObjArrayA) to high (VarStatObjArrayA) do begin
VarStatObjArrayA[VarArrayHelperI] := TObjectInArray.Create;
VarStatObjArrayA[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
end;
SetLength(VarDynObjArray,2);
SetLength(VarDynObjArrayA,2);
VarPDynObjArray := @VarDynObjArray;
VarPStatObjArray := @VarStatObjArray;
for VarArrayHelperI := low(VarDynObjArray) to high (VarDynObjArray) do
VarDynObjArray[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarStatObjArray) to high (VarStatObjArray) do
VarStatObjArray[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarDynObjArrayA) to high (VarDynObjArrayA) do
VarDynObjArrayA[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
for VarArrayHelperI := low(VarStatObjArrayA) to high (VarStatObjArrayA) do
VarStatObjArrayA[VarArrayHelperI].Foo := 2 * VarArrayHelperI;
SetLength(VarDynIntArray2, 2);
SetLength(VarDynIntArray2[0], 3);
SetLength(VarDynIntArray2A, 2);
SetLength(VarDynIntArray2A[0], 3);
SetLength(VarStatIntArray2A[5], 3);
SetLength(VarDynIntArray2p, 2);
VarDynIntArray2p[0] := @VarDynIntArray;
VarStatIntArray2P[5] := @VarDynIntArray;
{$ENDIF}
{%endregion FooFunc}
{%region GLOBAL}
{$IFDEF Global_Types}
//type
TObjectInArray = class public foo: Integer; end;
TRecordInArray = record foo: Integer; end;
TDynIntArray = Array of Integer;
PDynIntArray = ^TDynIntArray;
TStatIntArray = Array [5..9] of Integer;
PStatIntArray = ^TStatIntArray;
TDynObjArray = Array of TObjectInArray;
PDynObjArray = ^TDynIntArray;
TStatObjArray = Array [5..9] of TObjectInArray;
PStatObjArray = ^TStatIntArray;
TDynRecArray = Array of TRecordInArray;
PDynRecArray = ^TDynIntArray;
TStatRecArray = Array [5..9] of TRecordInArray;
PStatRecArray = ^TStatIntArray;
TDynIntArray2 = Array of TDynIntArray;
{$ENDIF}
{$IFDEF Global_Var}

3
debugger/test/Gdbmi/TestGdbmi.lpr
View File

@ -4,7 +4,7 @@ program TestGdbmi;
uses
Interfaces, Forms, GuiTestRunner, CompileHelpers,
TestGdbType,
TestGdbType, TestGDBMIControl,
TestBase, TestException, Testwatches;
{$R *.res}
@ -12,6 +12,7 @@ uses
begin
Application.Initialize;
Application.CreateForm(TGuiTestRunner, TestRunner);
Application.CreateForm(TTestControlForm, TestControlForm);
Application.Run;
end.

4
debugger/test/Gdbmi/rungdbmiform.lfm
View File

@ -1,7 +1,7 @@
object Form1: TForm1
Left = 422
Left = 511
Height = 463
Top = 231
Top = 232
Width = 599
Caption = 'Form1'
ClientHeight = 463

9
debugger/test/Gdbmi/rungdbmiform.pas
View File

@ -55,6 +55,8 @@ type
TRunner = class(TGDBTestCase)
private
FTesting: Boolean;
procedure dobrk(ADebugger: TDebugger; ABreakPoint: TBaseBreakPoint;
var ACanContinue: Boolean);
published
procedure DoDbgOut(Sender: TObject; const AText: String);
procedure DoRun;
@ -62,6 +64,12 @@ type
{ TRunner }
procedure TRunner.dobrk(ADebugger: TDebugger; ABreakPoint: TBaseBreakPoint;
var ACanContinue: Boolean);
begin
ACanContinue := False;
end;
procedure TRunner.DoDbgOut(Sender: TObject; const AText: String);
begin
if not FTesting then exit;
@ -98,6 +106,7 @@ begin
try
dbg := TGDBMIDebugger.Create(DebuggerInfo.ExeName);
dbg.OnDbgOutput := @DoDbgOut;
dbg.OnBreakPointHit := @dobrk;
;
(* Add breakpoints *)

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

@ -169,18 +169,27 @@ type
TGDBTestCase = class(TTestCase)
private
FParent: TGDBTestsuite;
FTestErrors, FIgnoredErrors: String;
FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String;
FCurrentPrgName, FCurrentExename: String;
FLogFile: TextFile;
function GetCompilerInfo: TCompilerInfo;
function GetDebuggerInfo: TDebuggerInfo;
function GetSymbolType: TSymbolType;
protected
function GetLogActive: Boolean;
procedure SetUp; override;
procedure TearDown; override;
procedure DoDbgOutPut(Sender: TObject; const AText: String);
function StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;
procedure ClearTestErrors;
procedure AddTestError(s: string; MinGdbVers: Integer = 0);
procedure TestEquals(Expected, Got: string);
procedure TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0);
procedure TestEquals(Expected, Got: integer);
procedure TestEquals(Name: string; Expected, Got: integer; MinGdbVers: Integer = 0);
procedure AddTestSuccess(s: string; MinGdbVers: Integer = 0);
function TestEquals(Expected, Got: string): Boolean;
function TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0): Boolean;
function TestEquals(Expected, Got: integer): Boolean;
function TestEquals(Name: string; Expected, Got: integer; MinGdbVers: Integer = 0): Boolean;
function TestTrue(Name: string; Got: Boolean; MinGdbVers: Integer = 0): Boolean;
function TestFalse(Name: string; Got: Boolean; MinGdbVers: Integer = 0): Boolean;
procedure AssertTestErrors;
property TestErrors: string read FTestErrors;
public
@ -201,6 +210,8 @@ procedure RegisterDbgTest(ATestClass: TTestCaseClass);
var
AppDir: String;
ConfDir: String;
Logdir: String;
WriteLog: Boolean;
implementation
@ -257,6 +268,13 @@ end;
{ TGDBTestCase }
procedure TGDBTestCase.DoDbgOutPut(Sender: TObject; const AText: String);
begin
if GetLogActive then begin
writeln(FLogFile, AText);
end;
end;
function TGDBTestCase.GetCompilerInfo: TCompilerInfo;
begin
Result := Parent.CompilerInfo;
@ -272,6 +290,44 @@ begin
Result := Parent.SymbolType;
end;
function TGDBTestCase.GetLogActive: Boolean;
begin
Result := WriteLog;
end;
procedure TGDBTestCase.SetUp;
var
name: String;
i: Integer;
dir: String;
begin
if GetLogActive then begin
name := TestName
+ '_' + GetCompilerInfo.Name
+ '_' + SymbolTypeNames[GetSymbolType]
+ '_' + GetDebuggerInfo.Name
+ '.log';
dir := ConfDir;
if DirectoryExistsUTF8(Logdir) then
dir := Logdir;
for i := 1 to length(name) do
if name[i] in ['/', '\', '*', '?', ':'] then
name[i] := '_';
AssignFile(FLogFile, Dir + name);
Rewrite(FLogFile);
end;
inherited SetUp;
end;
procedure TGDBTestCase.TearDown;
begin
inherited TearDown;
if GetLogActive then begin
CloseFile(FLogFile);
end;
end;
function TGDBTestCase.StartGDB(AppDir, TestExeName: String): TGDBMIDebugger;
begin
Result := TGDBMIDebugger.Create(DebuggerInfo.ExeName);
@ -282,6 +338,7 @@ begin
Result.FileName := TestExeName;
Result.Arguments := '';
Result.ShowConsole := True;
Result.OnDbgOutput := @DoDbgOutPut;
end;
procedure TGDBTestCase.ClearTestErrors;
@ -306,32 +363,59 @@ begin
FTestErrors := FTestErrors + s + LineEnding;
end;
procedure TGDBTestCase.TestEquals(Expected, Got: string);
procedure TGDBTestCase.AddTestSuccess(s: string; MinGdbVers: Integer);
var
i: Integer;
begin
try AssertEquals(Expected, Got);
except on e: exception do AddTestError(e.Message);
if MinGdbVers > 0 then begin
i := GetDebuggerInfo.Version;
if (i > 0) and (i < MinGdbVers) then
FUnexpectedSuccess := FUnexpectedSuccess + s
+ 'GDB ('+IntToStr(i)+') to old, required:'+IntToStr(MinGdbVers)
+ LineEnding;
end;
end;
procedure TGDBTestCase.TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0);
function TGDBTestCase.TestEquals(Expected, Got: string): Boolean;
begin
try AssertEquals(Name, Expected, Got);
except on e: exception do AddTestError(e.Message, MinGdbVers);
end;
Result := TestEquals('', Expected, Got);
end;
procedure TGDBTestCase.TestEquals(Expected, Got: integer);
function TGDBTestCase.TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0): Boolean;
begin
try AssertEquals(Expected, Got);
except on e: exception do AddTestError(e.Message);
end;
Result := Got = Expected;
if Result
then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "'+Got+'"', MinGdbVers)
else AddTestError(Name + ': Expected "'+Expected+'", Got "'+Got+'"', MinGdbVers);
end;
procedure TGDBTestCase.TestEquals(Name: string; Expected, Got: integer; MinGdbVers: Integer = 0);
function TGDBTestCase.TestEquals(Expected, Got: integer): Boolean;
begin
try AssertEquals(Name, Expected, Got);
except on e: exception do AddTestError(e.Message, MinGdbVers);
end;
Result := TestEquals('', Expected, Got);
end;
function TGDBTestCase.TestEquals(Name: string; Expected, Got: integer; MinGdbVers: Integer = 0): Boolean;
begin
Result := Got = Expected;
if Result
then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "'+IntToStr(Got)+'"', MinGdbVers)
else AddTestError(Name + ': Expected "'+IntToStr(Expected)+'", Got "'+IntToStr(Got)+'"', MinGdbVers);
end;
function TGDBTestCase.TestTrue(Name: string; Got: Boolean; MinGdbVers: Integer): Boolean;
begin
Result := Got;
if Result
then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "True"', MinGdbVers)
else AddTestError(Name + ': Expected "True", Got "False"', MinGdbVers);
end;
function TGDBTestCase.TestFalse(Name: string; Got: Boolean; MinGdbVers: Integer): Boolean;
begin
Result := not Got;
if Result
then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "False"', MinGdbVers)
else AddTestError(Name + ': Expected "False", Got "True"', MinGdbVers);
end;
procedure TGDBTestCase.AssertTestErrors;
@ -340,13 +424,29 @@ var
begin
s := FTestErrors;
FTestErrors := '';
if s <> '' then Fail(s);
if GetLogActive then begin
writeln(FLogFile, '================= Failed:'+LineEnding);
writeln(FLogFile, s);
writeln(FLogFile, '================= Ignored'+LineEnding);
writeln(FLogFile, FIgnoredErrors);
writeln(FLogFile, '================= Unexpected Success'+LineEnding);
writeln(FLogFile, FUnexpectedSuccess);
writeln(FLogFile, '================='+LineEnding);
end;
if s <> '' then begin
Fail(s);
end;
end;
procedure TGDBTestCase.TestCompile(const PrgName: string; out ExeName: string;
NamePostFix: String=''; ExtraArgs: String='');
begin
if GetLogActive then begin
writeln(FLogFile, LineEnding+LineEnding+'******************* compile '+PrgName + ' ' + ExtraArgs +LineEnding);
end;
Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs);
FCurrentPrgName := PrgName;
FCurrentExename := ExeName;
end;
{ TBaseList }
@ -759,6 +859,7 @@ initialization
ConfDir := AppDir;
AppDir := AppendPathDelim(AppDir + 'TestApps');
EnvironmentOptions := TEnvironmentOptions.Create;
with EnvironmentOptions do
begin

3
debugger/test/Gdbmi/testexception.pas
View File

@ -5,7 +5,7 @@ unit TestException;
interface
uses
Classes, fpcunit, testutils, testregistry,
Classes, fpcunit, testutils, testregistry, TestGDBMIControl,
TestBase, Debugger, GDBMIDebugger, LCLProc;
type
@ -52,6 +52,7 @@ var
TestExeName, TstName: string;
dbg: TGDBMIDebugger;
begin
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
ClearTestErrors;
TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '', '');

75
debugger/test/Gdbmi/testgdbmicontrol.lfm Normal file
View File

@ -0,0 +1,75 @@
object TestControlForm: TTestControlForm
Left = 1189
Height = 240
Top = 158
Width = 320
BorderIcons = []
Caption = 'Test Control'
ClientHeight = 240
ClientWidth = 320
OnShow = FormShow
LCLVersion = '0.9.31'
Visible = True
object Panel1: TPanel
Left = 0
Height = 44
Top = 0
Width = 320
Align = alTop
AutoSize = True
ClientHeight = 44
ClientWidth = 320
TabOrder = 0
object CheckWriteLogs: TCheckBox
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideRight.Control = Panel1
AnchorSideRight.Side = asrBottom
Left = 1
Height = 19
Top = 1
Width = 318
Anchors = [akTop, akLeft, akRight]
Caption = 'Write Logs'
OnChange = CheckWriteLogsChange
TabOrder = 0
end
object Label1: TLabel
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = EditLogDir
Left = 1
Height = 16
Top = 20
Width = 42
Align = alCustom
BorderSpacing.Right = 5
Caption = 'Log Dir:'
ParentColor = False
end
object EditLogDir: TEdit
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = CheckWriteLogs
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Panel1
AnchorSideRight.Side = asrBottom
Left = 48
Height = 23
Top = 20
Width = 271
Anchors = [akTop, akLeft, akRight]
OnChange = EditLogDirChange
TabOrder = 1
Text = 'EditLogDir'
end
end
object CheckListBox1: TCheckListBox
Left = 0
Height = 196
Top = 44
Width = 320
Align = alClient
ItemHeight = 0
TabOrder = 1
end
end

73
debugger/test/Gdbmi/testgdbmicontrol.pas Normal file
View File

@ -0,0 +1,73 @@
unit TestGDBMIControl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
CheckLst, testregistry, fpcunit;
type
{ TTestControlForm }
TTestControlForm = class(TForm)
CheckListBox1: TCheckListBox;
CheckWriteLogs: TCheckBox;
EditLogDir: TEdit;
Label1: TLabel;
Panel1: TPanel;
procedure CheckWriteLogsChange(Sender: TObject);
procedure EditLogDirChange(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
TestControlForm: TTestControlForm;
implementation
uses GuiTestRunner, TestBase;
{$R *.lfm}
{ TTestControlForm }
procedure TTestControlForm.FormShow(Sender: TObject);
var
j: Integer;
begin
OnShow := nil;
Top := TestRunner.Top;
Left := TestRunner.Left + TestRunner.Width;
if DirectoryExistsUTF8(ConfDir+'logs') then
EditLogDir.Text := ConfDir+'logs'+DirectorySeparator
else if DirectoryExistsUTF8(ConfDir+'log') then
EditLogDir.Text := ConfDir+'log'+DirectorySeparator
else
EditLogDir.Text := ConfDir;
j := CheckListBox1.Items.Add('TTestExceptionOne');
CheckListBox1.Checked[j] := True;
j := CheckListBox1.Items.Add('TTestWatch');
CheckListBox1.Checked[j] := True;
end;
procedure TTestControlForm.EditLogDirChange(Sender: TObject);
begin
Logdir := EditLogDir.Text;
end;
procedure TTestControlForm.CheckWriteLogsChange(Sender: TObject);
begin
WriteLog := CheckWriteLogs.Checked;
end;
end.

90
debugger/test/Gdbmi/testgdbtype.pas
View File

@ -10,6 +10,8 @@ uses
type
TTestGdbType = class(TTestCase)
private
FIgnoreBaseDeclaration: Boolean;
published
procedure TestPTypeParser;
end;
@ -35,6 +37,8 @@ const
0: Result := Result + 'ptprfParamByRef, ';
1: Result := Result + 'ptprfPointer, ';
2: Result := Result + 'ptprfNoStructure, ';
3: Result := Result + 'ptprfDynArray, ';
4: Result := Result + 'ptprNoBounds, ';
else Result := Result + IntToStr(ord(i)) + ', ';
end
end;
@ -43,20 +47,36 @@ const
procedure CheckResult(TestName: string; TestRes: TGDBPTypeResult;
ExpKind: TGDBPTypeResultKind;
ExpHasFlags, ExpIgnoreFlags: TGDBPTypeResultFlags;
ExpName, ExpDecl: string);
ExpName, ExpDecl: string;
ExpSubName: String = '';
ExpLow: String = '';
ExpHigh: String = '';
ExpBaseDecl: String = ''
);
begin
AssertEquals(TestName + ' Kind', KindNames[ExpKind], KindNames[TestRes.Kind]);
AssertEquals(TestName + ' Has Flags', FlagsToString(ExpHasFlags), FlagsToString(TestRes.Flags * (AllFlags - ExpIgnoreFlags)));
AssertEquals(TestName + ' Name', ExpName, PCLenToString(TestRes.Name));
AssertEquals(TestName + ' SubName', ExpSubName, PCLenToString(TestRes.SubName));
AssertEquals(TestName + ' Decl', ExpDecl, PCLenToString(TestRes.Declaration));
AssertEquals(TestName + ' Low', ExpLow, PCLenToString(TestRes.BoundLow));
AssertEquals(TestName + ' High', ExpHigh, PCLenToString(TestRes.BoundHigh));
while (ExpName <> '') and (ExpName[1] in ['^', '&']) do Delete(ExpName, 1, 1);
while (ExpSubName <> '') and (ExpSubName[1] in ['^', '&']) do Delete(ExpSubName, 1, 1);
while (ExpDecl <> '') and (ExpDecl[1] in ['(', '^', '&']) do Delete(ExpDecl, 1, 1);
while (ExpDecl <> '') and (ExpDecl[length(ExpDecl)] in [')']) do Delete(ExpDecl, length(ExpDecl), 1);
AssertEquals(TestName + ' BaseName', ExpName, PCLenToString(TestRes.BaseName));
AssertEquals(TestName + ' BaseSubName', ExpSubName, PCLenToString(TestRes.BaseSubName));
if FIgnoreBaseDeclaration then exit;
if ExpBaseDecl <> '' then ExpDecl := ExpBaseDecl;
AssertEquals(TestName + ' BaseDecl', ExpDecl, PCLenToString(TestRes.BaseDeclaration));
end;
var
R: TGDBPTypeResult;
begin
(* Test with data captured from gdb *)
FIgnoreBaseDeclaration := true;
// dummy data
R := ParseTypeFromGdb('type = char');
@ -93,57 +113,92 @@ begin
(* array *)
FIgnoreBaseDeclaration := False;
// <whatis VarDynIntArrayA> type = array [0..-1] of LONGINT
r := ParseTypeFromGdb('type = array [0..-1] of LONGINT'+LN);
CheckResult('type = array [0..-1] of LONGINT', R, ptprkArray, [], [], '', 'array [0..-1] of LONGINT');
CheckResult('type = array [0..-1] of LONGINT', R, ptprkArray, [ptprfDynArray], [],
'', 'array [0..-1] of LONGINT', 'LONGINT', '0', '-1');
r := ParseTypeFromGdb('type = array [0..0] of LONGINT'+LN);
CheckResult('type = array [0..0] of LONGINT', R, ptprkArray, [], [], '',
'array [0..0] of LONGINT', 'LONGINT', '0', '0');
r := ParseTypeFromGdb('type = array [0..2] of LONGINT'+LN);
CheckResult('type = array [0..2] of LONGINT', R, ptprkArray, [], [], '',
'array [0..2] of LONGINT', 'LONGINT', '0', '2');
r := ParseTypeFromGdb('type = array [2..2] of TFOO'+LN);
CheckResult('type = array [2..2] of TFOO', R, ptprkArray, [], [], '',
'array [2..2] of TFOO', 'TFOO', '2', '2');
r := ParseTypeFromGdb('type = array of LONGINT'+LN);
CheckResult('type = array of LONGINT', R, ptprkArray, [ptprfDynArray, ptprfNoBounds], [], '',
'array of LONGINT', 'LONGINT', '', '');
// <whatis VarDynIntArrayA> type = ^(array [0..-1] of LONGINT)
r := ParseTypeFromGdb('type = ^(array [0..-1] of LONGINT)'+LN);
CheckResult('type = ^(array [0..-1] of LONGINT)', R, ptprkArray, [ptprfPointer], [], '', '^(array [0..-1] of LONGINT)');
CheckResult('type = ^(array [0..-1] of LONGINT)', R, ptprkArray, [ptprfPointer, ptprfDynArray], [],
'', '^(array [0..-1] of LONGINT)', 'LONGINT', '0', '-1');
r := ParseTypeFromGdb('type = ^(array [0..1] of LONGINT)'+LN);
CheckResult('type = ^(array [0..1] of LONGINT)', R, ptprkArray, [ptprfPointer], [], '',
'^(array [0..1] of LONGINT)', 'LONGINT', '0', '1');
r := ParseTypeFromGdb('type = ^(array of LONGINT)'+LN);
CheckResult('type = ^(array of )', R, ptprkArray, [ptprfPointer, ptprfDynArray, ptprfNoBounds], [],
'', '^(array of LONGINT)', 'LONGINT', '', '');
(* enum *)
// <whatis ArgEnum> type = TENUM = (ONE, TWO, THREE)
r := ParseTypeFromGdb('type = TENUM = (ONE, TWO, THREE)'+LN);
CheckResult('type = TENUM = (ONE, TWO, THREE)', R, ptprkEnum, [], [], 'TENUM', '(ONE, TWO, THREE)');
CheckResult('type = TENUM = (ONE, TWO, THREE)', R, ptprkEnum, [], [],
'TENUM', '(ONE, TWO, THREE)', '', '' ,'', '(ONE, TWO, THREE)');
// <whatis ArgEnum> type = ^TENUM = (ONE, TWO, THREE)
r := ParseTypeFromGdb('type = ^TENUM = (ONE, TWO, THREE)'+LN);
CheckResult('type = ^TENUM = (ONE, TWO, THREE)', R, ptprkEnum, [ptprfPointer], [], '^TENUM', '(ONE, TWO, THREE)');
CheckResult('type = ^TENUM = (ONE, TWO, THREE)', R, ptprkEnum, [ptprfPointer], [],
'^TENUM', '(ONE, TWO, THREE)', '', '' ,'', '(ONE, TWO, THREE)');
// <whatis VarEnumA> type = = (E1, E2, E3)
r := ParseTypeFromGdb('type = = (E1, E2, E3)'+LN);
CheckResult('type = = (E1, E2, E3)', R, ptprkEnum, [], [], '', '(E1, E2, E3)');
CheckResult('type = = (E1, E2, E3)', R, ptprkEnum, [], [],
'', '(E1, E2, E3)', '', '' ,'', '(E1, E2, E3)');
// <whatis VarEnumA> type = ^ = (E1, E2, E3)
r := ParseTypeFromGdb('type = ^ = (E1, E2, E3)'+LN);
CheckResult('type = ^ = (E1, E2, E3)', R, ptprkEnum, [ptprfPointer], [], '', '(E1, E2, E3)');
CheckResult('type = ^ = (E1, E2, E3)', R, ptprkEnum, [ptprfPointer], [],
'', '(E1, E2, E3)', '', '' ,'', '(E1, E2, E3)');
(* set *)
// type = set of TENUM
r := ParseTypeFromGdb('type = set of TENUM'+LN);
CheckResult('type = set of TENUM', R, ptprkSet, [], [], '', 'set of TENUM');
CheckResult('type = set of TENUM', R, ptprkSet, [], [], '', 'set of TENUM', 'TENUM');
// type = ^set of TENUM
r := ParseTypeFromGdb('type = ^set of TENUM'+LN);
CheckResult('type = ^set of TENUM', R, ptprkSet, [ptprfPointer], [], '', '^set of TENUM');
CheckResult('type = ^set of TENUM', R, ptprkSet, [ptprfPointer], [], '', '^set of TENUM', 'TENUM');
// type = set of = (...)
r := ParseTypeFromGdb('type = set of = (...)'+LN);
CheckResult('type = set of = (...)', R, ptprkSet, [], [], '', 'set of = (...)');
CheckResult('type = set of = (...)', R, ptprkSet, [], [],
'', 'set of = (...)', '(...)', '', '', 'set of = (...)');
// type = ^set of = (...)
r := ParseTypeFromGdb('type = ^set of = (...)'+LN);
CheckResult('type = ^set of = (...)', R, ptprkSet, [ptprfPointer], [], '', '^set of = (...)');
CheckResult('type = ^set of = (...)', R, ptprkSet, [ptprfPointer], [],
'', '^set of = (...)', '(...)', '', '', 'set of = (...)');
// type = set of = (ALPHA, BETA, GAMMA)
r := ParseTypeFromGdb('type = set of = (ALPHA, BETA, GAMMA)'+LN);
CheckResult('type = set of = (ALPHA, BETA, GAMMA)', R, ptprkSet, [], [], '', 'set of = (ALPHA, BETA, GAMMA)');
CheckResult('type = set of = (ALPHA, BETA, GAMMA)', R, ptprkSet, [], [],
'', 'set of = (ALPHA, BETA, GAMMA)', '(ALPHA, BETA, GAMMA)', '', '', 'set of = (ALPHA, BETA, GAMMA)');
// type = ^set of = (ALPHA, BETA, GAMMA)
r := ParseTypeFromGdb('type = ^set of = (ALPHA, BETA, GAMMA)'+LN);
CheckResult('type = ^set of = (ALPHA, BETA, GAMMA)', R, ptprkSet, [ptprfPointer], [], '', '^set of = (ALPHA, BETA, GAMMA)');
CheckResult('type = ^set of = (ALPHA, BETA, GAMMA)', R, ptprkSet, [ptprfPointer], [],
'', '^set of = (ALPHA, BETA, GAMMA)', '(ALPHA, BETA, GAMMA)', '', '', 'set of = (ALPHA, BETA, GAMMA)');
// type = <invalid unnamed pascal type code 8> ## Dwarf no sets
r := ParseTypeFromGdb('type = <invalid unnamed pascal type code 8>'+LN);
@ -154,19 +209,20 @@ begin
// 'type = set of ONE..THREE'+LN ## Dwarf gdb 7.0
r := ParseTypeFromGdb('type = set of ONE..THREE'+LN);
CheckResult('type = set of ONE..THREE'+LN, R, ptprkSet, [], [], '', 'set of ONE..THREE');
CheckResult('type = set of ONE..THREE'+LN, R, ptprkSet, [], [], '', 'set of ONE..THREE', 'ONE..THREE');
// 'type = ^set of ONE..THREE'+LN
r := ParseTypeFromGdb('type = ^set of ONE..THREE'+LN);
CheckResult('type = ^set of ONE..THREE'+LN, R, ptprkSet, [ptprfPointer], [], '', '^set of ONE..THREE');
CheckResult('type = ^set of ONE..THREE'+LN, R, ptprkSet, [ptprfPointer], [], '', '^set of ONE..THREE', 'ONE..THREE');
// 'type = &set of ONE..THREE'+LN
r := ParseTypeFromGdb('type = &set of ONE..THREE'+LN);
CheckResult('type = &set of ONE..THREE'+LN, R, ptprkSet, [ptprfParamByRef], [], '', '&set of ONE..THREE');
CheckResult('type = &set of ONE..THREE'+LN, R, ptprkSet, [ptprfParamByRef], [], '', '&set of ONE..THREE', 'ONE..THREE');
// 'type = ^&set of ONE..THREE'+LN
r := ParseTypeFromGdb('type = ^&set of ONE..THREE'+LN);
CheckResult('type = ^&set of ONE..THREE'+LN, R, ptprkSet, [ptprfPointer, ptprfParamByRef], [], '', '^&set of ONE..THREE');
CheckResult('type = ^&set of ONE..THREE'+LN, R, ptprkSet, [ptprfPointer, ptprfParamByRef], [], '', '^&set of ONE..THREE', 'ONE..THREE');
(* record *)
FIgnoreBaseDeclaration := true;
// type = TREC = record
r := ParseTypeFromGdb('type = TREC = record '+LN + ' VALINT : LONGINT;'+LN + ' VALFOO : TFOO;'+LN + 'end'+LN);

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

@ -5,7 +5,7 @@ unit TestWatches;
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry,
Classes, SysUtils, fpcunit, testutils, testregistry, TestGDBMIControl,
TestBase, Debugger, GDBMIDebugger, LCLProc, SynRegExpr, Forms, StdCtrls, Controls;
const
@ -54,7 +54,7 @@ type
FWatches: TBaseWatches;
FDbgOutPut: String;
FDbgOutPutEnable: Boolean;
procedure DoDbgOutput(Sender: TObject; const AText: String);
procedure DoDbgOutput(Sender: TObject; const AText: String); reintroduce;
public
procedure DebugInteract(dbg: TGDBMIDebugger);
@ -118,7 +118,9 @@ const
(Exp: '-data-evaluate-expression sizeof(ArgTFoo^)'; Fmt: wdfDefault; Mtch: 'value="\d\d+"|(parse|syntax) error in expression'; Kind: skClass; TpNm: ''; Flgs: [])//,
);
ExpectBrk1NoneNil: Array [1..121] of TWatchExpectation = (
(* ***** ***** ***** ***** ***** ***** ***** *)
ExpectBrk1NoneNil: Array [1..133] of TWatchExpectation = (
{%region * records * }
(Exp: 'ArgTRec'; Fmt: wdfDefault; Mtch: Match_ArgTRec; Kind: skRecord; TpNm: 'TRec'; Flgs: []),
@ -250,7 +252,7 @@ const
//(Exp: 'ArgTFoo=nil'; Fmt: wdfDefault; Mtch: 'False'; Kind: skSimple; TpNm: 'bool'; Flgs: []),
//(Exp: 'not(ArgTFoo=nil)'; Fmt: wdfDefault; Mtch: 'True'; Kind: skSimple; TpNm: 'bool'; Flgs: []),
//(Exp: 'ArgTFoo<>nil'; Fmt: wdfDefault; Mtch: 'True'; Kind: skSimple; TpNm: 'bool'; Flgs: []),
{%endendregion * Classes * }
{%endregion * Classes * }
{%region * Strings * }
{ strings }
@ -382,6 +384,49 @@ const
(Exp: 'VarSetA'; Fmt: wdfDefault; Mtch: '^\[s2\]$'; Kind: skSet; TpNm: ''; Flgs: [fnoDwrfNoSet]),
{%endregion * Enum/Set * }
{%region * Array * }
//TODO: DynArray, decide what to display
// TODO {} fixup array => replace with []
(Exp: 'VarDynIntArray'; Fmt: wdfDefault; Mtch: Match_Pointer+'|\{\}|0,[\s\r\n]+2';
Kind: skSimple; TpNm: 'TDynIntArray';
Flgs: []) ,
//TODO add () around list
(Exp: 'VarStatIntArray'; Fmt: wdfDefault; Mtch: '10,[\s\r\n]+12,[\s\r\n]+14,[\s\r\n]+16,[\s\r\n]+18';
Kind: skSimple; TpNm: 'TStatIntArray';
Flgs: []) ,
(Exp: 'VarPDynIntArray'; Fmt: wdfDefault; Mtch: Match_Pointer;
Kind: skPointer; TpNm: 'PDynIntArray';
Flgs: []) ,
(Exp: 'VarPStatIntArray'; Fmt: wdfDefault; Mtch: Match_Pointer;
Kind: skPointer; TpNm: 'PStatIntArray';
Flgs: []) ,
(Exp: 'VarDynIntArrayA'; Fmt: wdfDefault; Mtch: Match_Pointer+'|\{\}|0,[\s\r\n]+2';
Kind: skSimple; TpNm: '';
Flgs: []) ,
(Exp: 'VarStatIntArrayA'; Fmt: wdfDefault; Mtch: '10,[\s\r\n]+12,[\s\r\n]+14,[\s\r\n]+16,[\s\r\n]+18';
Kind: skSimple; TpNm: '';
Flgs: []) ,
(Exp: 'VarDynIntArray[1]'; Fmt: wdfDefault; Mtch: '2';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]) ,
(Exp: 'VarStatIntArray[6]'; Fmt: wdfDefault; Mtch: '12';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]) ,
(Exp: 'VarPDynIntArray^[1]'; Fmt: wdfDefault; Mtch: '2';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]) ,
(Exp: 'VarPStatIntArray^[6]'; Fmt: wdfDefault; Mtch: '12';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]) ,
(Exp: 'VarDynIntArrayA[1]'; Fmt: wdfDefault; Mtch: '2';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]) ,
(Exp: 'VarStatIntArrayA[6]'; Fmt: wdfDefault; Mtch: '12';
Kind: skSimple; TpNm: 'Integer|LongInt';
Flgs: [fTpMtch]),
{%endregion * Array * }
{%region * Variant * }
(Exp: 'ArgVariantInt'; Fmt: wdfDefault; Mtch: '^5$'; Kind: skVariant; TpNm: 'Variant'; Flgs: []),
@ -428,7 +473,6 @@ const
{ TTestWatch }
procedure TTestWatch.DoChanged;
@ -477,6 +521,7 @@ end;
procedure TTestWatches.DoDbgOutput(Sender: TObject; const AText: String);
begin
inherited DoDbgOutput(Sender, AText);
if FDbgOutPutEnable then
FDbgOutPut := FDbgOutPut + AText;
if DbgLog and (DbgMemo <> nil) then
@ -514,47 +559,43 @@ procedure TTestWatches.TestWatches;
var
rx: TRegExpr;
s: String;
flag: Boolean;
begin
rx := nil;
Name := Name + ' ' + Data.Exp + ' (' + TWatchDisplayFormatNames[Data.Fmt] + ')';
try
if AWatch <> nil then begin;
AWatch.Master.Value; // trigger read
AssertTrue (Name+ ' (HasValue)', AWatch.HasValue);
AssertFalse (Name+ ' (One Value)', AWatch.HasMultiValue);
s := AWatch.Value;
end
else
s := WatchValue;
flag := AWatch <> nil;
if flag then begin;
AWatch.Master.Value; // trigger read
flag := flag and TestTrue (Name+ ' (HasValue)', AWatch.HasValue);
flag := flag and TestFalse (Name+ ' (One Value)', AWatch.HasMultiValue);
s := AWatch.Value;
end
else
s := WatchValue;
if flag then begin
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Data.Mtch;
if Data.Mtch <> ''
then AssertTrue(Name + ' Matches "'+Data.Mtch + '", but was "' + s + '"', rx.Exec(s));
except
on e: Exception do
AddTestError(e.Message);
then TestTrue(Name + ' Matches "'+Data.Mtch + '", but was "' + s + '"', rx.Exec(s));
end;
try
if (AWatch <> nil) and (Data.TpNm <> '') then begin
AssertTrue(Name + ' has typeinfo', AWatch.TypeInfo <> nil);
AssertEquals(Name + ' kind', KindName[Data.Kind], KindName[AWatch.TypeInfo.Kind]);
if fTpMtch in Data.Flgs
then begin
FreeAndNil(rx);
s := AWatch.TypeInfo.TypeName;
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Data.TpNm;
AssertTrue(Name + ' TypeName matches '+Data.TpNm+' but was '+AWatch.TypeInfo.TypeName, rx.Exec(s))
end
else AssertEquals(Name + ' TypeName', LowerCase(Data.TpNm), LowerCase(AWatch.TypeInfo.TypeName));
end;
except
on e: Exception do
AddTestError(e.Message);
flag := (AWatch <> nil) and (Data.TpNm <> '');
if flag then flag := TestTrue(Name + ' has typeinfo', AWatch.TypeInfo <> nil);
if flag then flag := TestEquals(Name + ' kind', KindName[Data.Kind], KindName[AWatch.TypeInfo.Kind]);
if flag then begin
if fTpMtch in Data.Flgs
then begin
FreeAndNil(rx);
s := AWatch.TypeInfo.TypeName;
rx := TRegExpr.Create;
rx.ModifierI := true;
rx.Expression := Data.TpNm;
TestTrue(Name + ' TypeName matches '+Data.TpNm+' but was '+AWatch.TypeInfo.TypeName, rx.Exec(s))
end
else TestEquals(Name + ' TypeName', LowerCase(Data.TpNm), LowerCase(AWatch.TypeInfo.TypeName));
end;
FreeAndNil(rx);
end;
@ -565,6 +606,8 @@ var
i: Integer;
WList: Array of TTestWatch;
begin
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestWatch')] then exit;
ClearTestErrors;
try
TestCompile(AppDir + 'WatchesPrg.pas', TestExeName);
@ -574,7 +617,7 @@ begin
try
FWatches := TBaseWatches.Create(TBaseWatch);
dbg := TGDBMIDebugger.Create(DebuggerInfo.ExeName);
dbg := StartGDB(AppDir, TestExeName);
dbg.OnDbgOutput := @DoDbgOutput;
if (RUN_TEST_ONLY >= 0) or (RUN_GDB_TEST_ONLY >= 0) then begin
@ -618,13 +661,9 @@ begin
(* Start debugging *)
dbg.Init;
if dbg.State = dsError then
Fail(' Failed Init');
dbg.WorkingDir := AppDir;
dbg.FileName := TestExeName;
dbg.Arguments := '';
dbg.ShowConsole := True;
dbg.Run;