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

Patch by JoshyFun (modified)

Browse Source 
* Moved TGDBtype to TDBGtype, so it can be used in general to return expression typeinfo
* Changed inspect dialog to use this typeinfo
* display evaluation result on multiple lines

git-svn-id: trunk@22348 -
This commit is contained in:
marc 2009-10-30 00:02:38 +00:00
parent f9301bebcb
commit f90aca978c
13 changed files with 1315 additions and 378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

238
debugger/debugger.pp
View File

@ -441,6 +441,111 @@ type
end;
(******************************************************************************)
(******************************************************************************)
(** **)
(** D E B U G I N F O R M A T I O N **)
(** **)
(******************************************************************************)
(******************************************************************************)
type
TDBGSymbolKind = (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer);
TDBGFieldLocation = (flPrivate, flProtected, flPublic, flPublished);
TDBGFieldFlag = (ffVirtual,ffConstructor,ffDestructor);
TDBGFieldFlags = set of TDBGFieldFlag;
TDBGType = class;
TDBGValue = record
AsString: ansistring;
case integer of
0: (As8Bits: BYTE);
1: (As16Bits: WORD);
2: (As32Bits: DWORD);
3: (As64Bits: QWORD);
4: (AsSingle: Single);
5: (AsDouble: Double);
6: (AsPointer: Pointer);
end;
{ TDBGField }
TDBGField = class(TObject)
private
protected
FName: String;
FFlags: TDBGFieldFlags;
FLocation: TDBGFieldLocation;
FDBGType: TDBGType;
public
constructor Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags = []);
destructor Destroy; override;
property Name: String read FName;
property DBGType: TDBGType read FDBGType;
property Location: TDBGFieldLocation read FLocation;
property Flags: TDBGFieldFlags read FFlags;
end;
{ TDBGFields }
TDBGFields = class(TObject)
private
FList: TList;
function GetField(const AIndex: Integer): TDBGField;
function GetCount: Integer;
protected
public
constructor Create;
destructor Destroy; override;
property Count: Integer read GetCount;
property Items[const AIndex: Integer]: TDBGField read GetField; default;
procedure Add(const AField: TDBGField);
end;
TDBGTypes = class(TObject)
private
function GetType(const AIndex: Integer): TDBGType;
function GetCount: Integer;
protected
FList: TList;
public
constructor Create;
destructor Destroy; override;
property Count: Integer read GetCount;
property Items[const AIndex: Integer]: TDBGType read GetType; default;
end;
{ TDBGType }
TDBGType = class(TObject)
private
protected
FAncestor: String;
FResult: TDBGType;
FResultString: String;
FArguments: TDBGTypes;
FFields: TDBGFields;
FKind: TDBGSymbolKind;
FMembers: TStrings;
FTypeName: String;
FDBGValue: TDBGValue;
public
Value: TDBGValue;
constructor Create(AKind: TDBGSymbolKind; const ATypeName: String);
constructor Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType = nil);
destructor Destroy; override;
property Ancestor: String read FAncestor;
property Arguments: TDBGTypes read FArguments;
property Fields: TDBGFields read FFields;
property Kind: TDBGSymbolKind read FKind;
property TypeName: String read FTypeName;
property Members: TStrings read FMembers;
property Result: TDBGType read FResult;
end;
(******************************************************************************)
(******************************************************************************)
(** **)
@ -468,6 +573,7 @@ type
function GetExpression: String; virtual;
function GetValid: TValidState; virtual;
function GetValue: String; virtual;
function GetTypeInfo: TDBGType; virtual;
procedure SetEnabled(const AValue: Boolean); virtual;
procedure SetExpression(const AValue: String); virtual;
@ -478,6 +584,7 @@ type
property Expression: String read GetExpression write SetExpression;
property Valid: TValidState read GetValid;
property Value: String read GetValue;
property TypeInfo: TDBGType read GetTypeInfo;
end;
TBaseWatchClass = class of TBaseWatch;
@ -1102,7 +1209,6 @@ type
write SetItem; default;
end;
(******************************************************************************)
(******************************************************************************)
(** **)
@ -1214,8 +1320,8 @@ type
procedure StepInto;
procedure RunTo(const ASource: String; const ALine: Integer); // Executes til a certain point
procedure JumpTo(const ASource: String; const ALine: Integer); // No execute, only set exec point
function Evaluate(const AExpression: String; var AResult: String): Boolean; // Evaluates the given expression, returns true if valid
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean; // Evaluates the given expression, returns true if valid
function Modify(const AExpression, AValue: String): Boolean; // Modifies the given expression, returns true if valid
function Disassemble(AAddr: TDbgPtr; ABackward: Boolean;
out ANextAddr: TDbgPtr; out ADump, AStatement: String): Boolean;
@ -1597,9 +1703,11 @@ begin
FCurEnvironment.Assign(FEnvironment);
end;
function TDebugger.Evaluate(const AExpression: String; var AResult: String): Boolean;
function TDebugger.Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean;
begin
Result := ReqCmd(dcEvaluate, [AExpression, @AResult]);
FreeAndNIL(ATypeInfo);
Result := ReqCmd(dcEvaluate, [AExpression, @AResult, @ATypeInfo]);
end;
class function TDebugger.ExePaths: String;
@ -2779,6 +2887,121 @@ begin
inherited SetItem(AnIndex, AValue);
end;
(******************************************************************************)
(******************************************************************************)
(** **)
(** D E B U G I N F O R M A T I O N **)
(** **)
(******************************************************************************)
(******************************************************************************)
{ TDBGField }
constructor TDBGField.Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags);
begin
inherited Create;
FName := AName;
FLocation := ALocation;
FDBGType := ADBGType;
FFlags := AFlags;
end;
destructor TDBGField.Destroy;
begin
FreeAndNil(FDBGType);
inherited Destroy;
end;
{ TDBGFields }
constructor TDBGFields.Create;
begin
FList := TList.Create;
inherited;
end;
destructor TDBGFields.Destroy;
var
n: Integer;
begin
for n := 0 to Count - 1 do
Items[n].Free;
FreeAndNil(FList);
inherited;
end;
procedure TDBGFields.Add(const AField: TDBGField);
begin
FList.Add(AField);
end;
function TDBGFields.GetCount: Integer;
begin
Result := FList.Count;
end;
function TDBGFields.GetField(const AIndex: Integer): TDBGField;
begin
Result := TDBGField(FList[AIndex]);
end;
{ TDBGPType }
constructor TDBGType.Create(AKind: TDBGSymbolKind; const ATypeName: String);
begin
FKind := AKind;
FTypeName := ATypeName;
inherited Create;
end;
constructor TDBGType.Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType);
begin
FKind := AKind;
FArguments := AArguments;
FResult := AResult;
inherited Create;
end;
destructor TDBGType.Destroy;
begin
FreeAndNil(FResult);
FreeAndNil(FArguments);
FreeAndNil(FFields);
FreeAndNil(FMembers);
inherited;
end;
{ TDBGPTypes }
constructor TDBGTypes.Create;
begin
FList := TList.Create;
inherited;
end;
destructor TDBGTypes.Destroy;
var
n: Integer;
begin
for n := 0 to Count - 1 do
Items[n].Free;
FreeAndNil(FList);
inherited;
end;
function TDBGTypes.GetCount: Integer;
begin
Result := Flist.Count;
end;
function TDBGTypes.GetType(const AIndex: Integer): TDBGType;
begin
Result := TDBGType(FList[AIndex]);
end;
(******************************************************************************)
(******************************************************************************)
(** **)
@ -2848,6 +3071,11 @@ begin
end;
end;
function TBaseWatch.GetTypeInfo: TDBGType;
begin
Result:=nil;
end;
procedure TBaseWatch.SetEnabled(const AValue: Boolean);
begin
if FEnabled <> AValue

7
debugger/evaluatedlg.pp
View File

@ -38,7 +38,7 @@ interface
uses
Classes, SysUtils, LResources, LCLType, Forms, Controls, Graphics, Dialogs,
ComCtrls, StdCtrls, DebuggerDlg, BaseDebugManager, IDEWindowIntf, InputHistory;
ComCtrls, StdCtrls, DebuggerDlg, BaseDebugManager, IDEWindowIntf, InputHistory,debugger;
type
@ -161,15 +161,18 @@ end;
procedure TEvaluateDlg.tbEvaluateClick(Sender: TObject);
var
S, R: String;
DBGType: TDBGType;
begin
S := cmbExpression.Text;
InputHistories.HistoryLists.Add(ClassName, S);
if DebugBoss.Evaluate(S, R)
DBGType:=nil;
if DebugBoss.Evaluate(S, R, DBGType)
then begin
if cmbExpression.Items.IndexOf(S) = -1
then cmbExpression.Items.Insert(0, S);
// tbModify.Enabled := True;
end;
FreeAndNil(DBGType);
txtResult.Lines.Text := R;
end;

654
debugger/gdbmidebugger.pp
View File

@ -136,7 +136,7 @@ type
// Implementation of external functions
function GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
function GDBEvaluate(const AExpression: String; var AResult: String): Boolean;
function GDBEvaluate(const AExpression: String; var AResult: String; out ATypeInfo: TGDBType): Boolean;
function GDBRun: Boolean;
function GDBPause(const AInternal: Boolean): Boolean;
function GDBStop: Boolean;
@ -355,16 +355,20 @@ type
private
FEvaluated: Boolean;
FValue: String;
FTypeInfo: TGDBType;
procedure EvaluationNeeded;
procedure ClearOwned;
protected
procedure DoEnableChange; override;
procedure DoExpressionChange; override;
procedure DoChange; override;
procedure DoStateChange(const AOldState: TDBGState); override;
function GetValue: String; override;
function GetTypeInfo: TDBGType; override;
function GetValid: TValidState; override;
public
constructor Create(ACollection: TCollection); override;
destructor Destroy; override;
procedure Invalidate;
end;
@ -511,7 +515,6 @@ type
destructor Destroy; override;
function DumpExpression: String;
function Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String; out AResultInfo: TGDBType): Boolean;
function Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String): Boolean;
end;
{ TGDBMIType }
@ -523,6 +526,18 @@ type
constructor CreateFromResult(const AResult: TGDBMIExecResult);
end;
{ TGDBStringIterator }
TGDBStringIterator=class
private
protected
FDataSize: Integer;
FReadPointer: Integer;
FParsableData: String;
public
constructor Create(const AParsableData: String);
function ParseNext(out ADecomposable: Boolean; out APayload: String; out ACharStopper: Char): Boolean;
end;
PGDBMICmdInfo = ^TGDBMICmdInfo;
TGDBMICmdInfo = record
@ -1619,8 +1634,7 @@ begin
end;
end;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String;
var AResult: String): Boolean;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String; out ATypeInfo: TGDBType): Boolean;
function MakePrintable(const AString: String): String;
var
@ -1654,6 +1668,314 @@ function TGDBMIDebugger.GDBEvaluate(const AExpression: String;
then Result := Result + '''';
end;
function FormatResult(const AInput: String): String;
const
INDENTSTRING = ' ';
var
Indent: String;
i: Integer;
InStr: Boolean;
InBrackets: Boolean;
Limit: Integer;
Skip: Integer;
begin
Indent := '';
Skip := 0;
InStr := False;
InBrackets := False;
Limit := Length(AInput);
Result := '';
for i := 1 to Limit do
begin
if Skip>0
then begin
Dec(SKip);
Continue;
end;
if AInput[i] in [#10, #13]
then begin
//Removes unneeded LineEnding.
Continue;
end;
Result := Result + AInput[i];
if InStr
then begin
InStr := AInput[i] <> '''';
Continue;
end;
if InBrackets
then begin
InBrackets := AInput[i] <> ']';
Continue;
end;
case AInput[i] of
'[': begin
InBrackets:=true;
end;
'''': begin
InStr:=true;
end;
'{': begin
if (i < Limit) and (AInput[i+1] <> '}')
then begin
Indent := Indent + INDENTSTRING;
Result := Result + LineEnding + Indent;
end;
end;
'}': begin
if (i > 0) and (AInput[i-1] <> '{')
then Delete(Indent, 1, Length(INDENTSTRING));
end;
' ': begin
if (i > 0) and (AInput[i-1] = ',')
then Result := Result + LineEnding + Indent;
end;
'0': begin
if (i > 4) and (i < Limit - 2)
then begin
//Pascalize pointers "Var = 0x12345 => Var = $12345"
if (AInput[i-3] = ' ')
and (AInput[i-2] = '=')
and (AInput[i-1] = ' ')
and (AInput[i+1] = 'x')
then begin
Skip := 1;
Result[Length(Result)] := '$';
end;
end;
end;
end;
end;
end;
function WhichIsFirst(const ASource: String; const ASearchable: array of Char): Integer;
var
j, k: Integer;
InString: Boolean;
begin
InString := False;
for j := 1 to Length(ASource) do
begin
if ASource[j] = '''' then InString := not InString;
if InString then Continue;
for k := Low(ASearchable) to High(ASearchable) do
begin
if ASource[j] = ASearchable[k] then Exit(j);
end;
end;
Result := -1;
end;
function SkipPairs(var ASource: String; const ABeginChar: Char; const AEndChar: Char): String;
var
Deep,j: SizeInt;
InString: Boolean;
begin
DebugLn('->->', ASource);
Deep := 0;
InString := False;
for j := 1 to Length(ASource) do
begin
if ASource[j]='''' then InString := not InString;
if InString then Continue;
if ASource[j] = ABeginChar
then begin
Inc(Deep)
end
else begin
if ASource[j] = AEndChar
then Dec(Deep);
end;
if Deep=0
then begin
Result := Copy(ASource, 1, j);
ASource := Copy(ASource, j + 1, Length(ASource) - j);
Exit;
end;
end;
end;
function IsHexC(const ASource: String): Boolean;
begin
if Length(ASource) <= 2 then Exit(False);
if ASource[1] <> '0' then Exit(False);
Result := ASource[2] = 'x';
end;
function HexCToHexPascal(const ASource: String): String;
begin
if IsHexC(Asource)
then begin
Result := Copy(ASource, 2, Length(ASource) - 1);
Result[1] := '$';
end
else Result := ASource;
end;
procedure PutValuesInTypeRecord(const AType: TDBGType; const ATextInfo: String);
var
GDBParser: TGDBStringIterator;
Payload: String;
Composite: Boolean;
StopChar: Char;
j: Integer;
begin
GDBParser := TGDBStringIterator.Create(ATextInfo);
GDBParser.ParseNext(Composite, Payload, StopChar);
GDBParser.Free;
if not Composite
then begin
//It is not a record
debugln('Expected record, but found: "', ATextInfo, '"');
exit;
end;
//Parse information between brackets...
GDBParser := TGDBStringIterator.Create(Payload);
for j := 0 to AType.Fields.Count-1 do
begin
if not GDBParser.ParseNext(Composite, Payload, StopChar)
then begin
debugln('Premature end of parsing');
Break;
end;
if Payload <> AType.Fields[j].Name
then begin
debugln('Field name does not match, expected "', AType.Fields[j].Name, '" but found "', Payload,'"');
Break;
end;
if StopChar <> '='
then begin
debugln('Expected assignement, but other found.');
Break;
end;
//Field name verified...
if not GDBParser.ParseNext(Composite, Payload, StopChar)
then begin
debugln('Premature end of parsing');
Break;
end;
if Composite
then TGDBMIType(AType.Fields[j].DBGType).FKind := skRecord;
AType.Fields[j].DBGType.Value.AsString := HexCToHexPascal(Payload);
end;
GDBParser.Free;
end;
procedure PutValuesInClass(const AType: TGDBType; ATextInfo: String);
var
GDBParser: TGDBStringIterator;
Payload: String;
Composite: Boolean;
StopChar: Char;
j: Integer;
begin
GDBParser := TGDBStringIterator.Create(ATextInfo);
GDBParser.ParseNext(Composite, Payload, StopChar);
GDBParser.Free;
if not Composite
then begin
//It is not a record
debugln('Expected class, but found: "', ATextInfo, '"');
exit;
end;
//Parse information between brackets...
GDBParser := TGDBStringIterator.Create(Payload);
try
if not GDBParser.ParseNext(Composite, Payload, StopChar)
then begin
debugln('Premature end of parsing.');
exit;
end;
//APayload holds the ancestor name
if '<' + AType.Ancestor + '>' <> Payload
then begin
debugln('Ancestor does not match, expected ', AType.Ancestor,' but found ', Payload);
exit;
end;
//Special hidden field, skip as a decomposable, parse and forget...
if not GDBParser.ParseNext(Composite, Payload, StopChar)
then begin
debugln('Premature end of parsing.');
exit;
end;
while GDBParser.ParseNext(Composite, Payload, StopChar) do
begin
if StopChar <> '='
then begin
debugln('Expected assignement, but other found.');
exit;
end;
for j := 0 to AType.Fields.Count-1 do
begin
if Payload <> AType.Fields[j].Name then Continue;
//Field name verified...
if not GDBParser.ParseNext(Composite, Payload, StopChar)
then begin
debugln('Premature end of parsing.');
exit;
end;
if Composite
then TGDBMIType(AType.Fields[j].DBGType).FKind := skRecord;
AType.Fields[j].DBGType.Value.AsString := HexCToHexPascal(Payload);
Break;
end;
end;
finally
GDBParser.Free;
end;
end;
procedure PutValuesInTree();
var
ValData: string;
begin
if not Assigned(ATypeInfo) then exit;
ValData := AResult;
case ATypeInfo.Kind of
skClass: begin
GetPart('','{',ValData);
PutValuesInClass(ATypeInfo,ValData);
end;
skRecord: begin
GetPart('','{',ValData);
PutValuesInTypeRecord(ATypeInfo,ValData);
end;
// skEnum: ;
// skSet: ;
skSimple: begin
ATypeInfo.Value.AsString:=ValData;
end;
// skPointer: ;
end;
end;
function SelectParentFrame(var aFrame: Integer): Boolean;
var
R: TGDBMIExecResult;
@ -1686,6 +2008,25 @@ function TGDBMIDebugger.GDBEvaluate(const AExpression: String;
List.Free;
end;
function PascalizePointer(AString: String): String;
begin
if IsHexC(AString)
then begin
if GetPart([], [' '], AString, False, False) = '0x0'
then begin
Result := AString;
Result[1] := 'n';
Result[2] := 'i';
Result[3] := 'l';
end
else begin
Result := Copy(AString, 2, Length(AString) - 1);
Result[1] := '$';
end;
end
else Result := AString;
end;
var
R, Rtmp: TGDBMIExecResult;
S: String;
@ -1695,7 +2036,10 @@ var
e: Integer;
Expr: TGDBMIExpression;
frame, frameidx: Integer;
PrintableString: String;
begin
AResult:='';
ATypeInfo:=nil;
S := AExpression;
if S = '' then Exit(false);
@ -1706,7 +2050,8 @@ begin
Expr := TGDBMIExpression.Create(S);
AResult := Expr.DumpExpression;
AResult := AResult + LineEnding;
Expr.Evaluate(Self, S);
Expr.Evaluate(Self, S, ATypeInfo);
FreeAndNil(ATypeInfo);
AResult := AResult + S;
Expr.Free;
Exit(True);
@ -1716,106 +2061,134 @@ begin
// original
frame := -1;
frameidx := -1;
repeat
Result := ExecuteCommand('-data-evaluate-expression %s', [S], [cfIgnoreError, cfExternal], R);
if (R.State <> dsError)
then Break;
// check if there is a parentfp and try to evaluate there
if frame = -1
then begin
// store current
ExecuteCommand('-stack-info-frame', [cfIgnoreError], Rtmp);
ResultList.Init(Rtmp.Values);
ResultList.SetPath('frame');
frame := StrToIntDef(ResultList.Values['level'], -1);
if frame = -1 then Break;
frameidx := frame;
end;
until not SelectParentFrame(frameidx);
if frameidx <> frame
then begin
// Restore current frame
ExecuteCommand('-stack-select-frame %u', [frame], [cfIgnoreError]);
end;
ResultList.Init(R.Values);
if R.State = dsError
then AResult := ResultList.Values['msg']
else AResult := ResultList.Values['value'];
AResult := DeleteEscapeChars(AResult);
ResultList.Free;
if R.State = dsError
then Exit;
// Check for strings
ResultInfo := GetGDBTypeInfo(S);
if (ResultInfo = nil) then Exit;
try
repeat
Result := ExecuteCommand('-data-evaluate-expression %s', [S], [cfIgnoreError, cfExternal], R);
case ResultInfo.Kind of
skPointer: begin
S := GetPart([], [' '], AResult, False, False);
Val(S, addr, e);
if e <> 0 then Exit;
if (R.State <> dsError)
then Break;
// check if there is a parentfp and try to evaluate there
if frame = -1
then begin
// store current
ExecuteCommand('-stack-info-frame', [cfIgnoreError], Rtmp);
ResultList.Init(Rtmp.Values);
ResultList.SetPath('frame');
frame := StrToIntDef(ResultList.Values['level'], -1);
if frame = -1 then Break;
frameidx := frame;
end;
until not SelectParentFrame(frameidx);
ResultList.Init(R.Values);
if R.State = dsError
then AResult := ResultList.Values['msg']
else AResult := ResultList.Values['value'];
AResult := DeleteEscapeChars(AResult);
ResultList.Free;
if R.State = dsError
then Exit;
// Check for strings
ResultInfo := GetGDBTypeInfo(S);
if (ResultInfo = nil) then Exit;
try
case ResultInfo.Kind of
skPointer: begin
Val(AResult, addr, e);
if e <> 0 then Exit;
S := Lowercase(ResultInfo.TypeName);
case StringCase(S, ['character', 'ansistring', '__vtbl_ptr_type', 'wchar']) of
0, 1: begin
if Addr = 0
then AResult := ''''''
else AResult := MakePrintable(GetText(Addr));
end;
2: begin
if Addr = 0
then AResult := 'nil'
else begin
S := GetClassName(Addr);
if S = '' then S := '???';
AResult := 'class of ' + S + ' ' + AResult;
end;
end;
3: begin
// widestring handling
if Addr = 0
then AResult := ''''''
else AResult := MakePrintable(GetWideText(Addr));
end;
else
S := Lowercase(ResultInfo.TypeName);
case StringCase(S, ['character', 'ansistring', '__vtbl_ptr_type', 'wchar']) of
0, 1: begin
if Addr = 0
then AResult := 'nil';
if S = 'pointer' then Exit;
if Length(S) = 0 then Exit;
then
AResult := ''''''
else
AResult := MakePrintable(GetText(Addr));
PrintableString := AResult;
end;
2: begin
if Addr = 0
then AResult := 'nil'
else begin
S := GetClassName(Addr);
if S = '' then S := '???';
AResult := 'class of ' + S + ' ' + AResult;
end;
end;
3: begin
// widestring handling
if Addr = 0
then AResult := ''''''
else AResult := MakePrintable(GetWideText(Addr));
PrintableString := AResult;
end;
else
if Addr = 0
then AResult := 'nil';
if (Length(S) > 0) and (S <> 'pointer')
then begin
if S[1] = 't'
then begin
S[1] := 'T';
if Length(S) > 1 then S[2] := UpperCase(S[2])[1];
end;
AResult := '^' + S + ' ' + AResult;
AResult := '^' + S + ' ' + PascalizePointer(AResult);
end;
end;
skClass: begin
Val(AResult, addr, e);
if e <> 0 then Exit;
ResultInfo.Value.AsPointer := Pointer(PtrUint(Addr));
S := Format('$%x', [Addr]);
if PrintableString <> ''
then S := S + ' ' + PrintableString;
ResultInfo.Value.AsString := S;
end;
skClass: begin
Val(AResult, addr, e); //Get the class mem address
if e = 0 then begin //No error ?
if Addr = 0
then AResult := 'nil'
else begin
S := GetInstanceClassName(Addr);
if S = '' then S := '???';
AResult := S + ' ' + AResult;
if S = '' then S := '???'; //No instanced class found
AResult := 'class ' + S + ' ' + AResult;
end;
end;
end;
finally
ResultInfo.Free;
skRecord: begin
AResult:= 'record ' + ResultInfo.TypeName + ' '+ AResult;
end;
skSimple: begin
AResult:=AResult;
end;
end;
finally
if frameidx <> frame
then begin
// Restore current frame
ExecuteCommand('-stack-select-frame %u', [frame], [cfIgnoreError]);
end;
end
end;
ATypeInfo := ResultInfo;
PutValuesInTree;
AResult := FormatResult(AResult);
end;
function TGDBMIDebugger.GDBJumpTo(const ASource: String;
const ALine: Integer): Boolean;
function TGDBMIDebugger.GDBJumpTo(const ASource: String; const ALine: Integer): Boolean;
begin
Result := False;
end;
@ -2917,7 +3290,7 @@ begin
dcStepInto: Result := GDBStepInto;
dcRunTo: Result := GDBRunTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
dcJumpto: Result := GDBJumpTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
dcEvaluate: Result := GDBEvaluate(String(AParams[0].VAnsiString), String(AParams[1].VPointer^));
dcEvaluate: Result := GDBEvaluate(String(AParams[0].VAnsiString), String(AParams[1].VPointer^),TGDBType(AParams[2].VPointer^));
dcEnvironment: Result := GDBEnvironment(String(AParams[0].VAnsiString), AParams[1].VBoolean);
dcDisassemble: Result := GDBDisassemble(AParams[0].VQWord^, AParams[1].VBoolean, TDbgPtr(AParams[2].VPointer^),
String(AParams[3].VPointer^), String(AParams[4].VPointer^));
@ -3161,6 +3534,10 @@ begin
// so the possible arguments of a previous run are cleared
ExecuteCommand('-exec-arguments %s', [Arguments], [cfIgnoreError]);
// set the output width to a great value to avoid unexpected
// new lines like in large functions or procedures
ExecuteCommand('set width 50000', [], [cfIgnoreError]);
if tfHasSymbols in FTargetFlags
then begin
// Make sure we are talking pascal
@ -3716,6 +4093,12 @@ begin
inherited;
end;
destructor TGDBMIWatch.Destroy;
begin
FreeAndNil(FTypeInfo);
inherited;
end;
procedure TGDBMIWatch.DoEnableChange;
begin
inherited;
@ -3737,12 +4120,16 @@ begin
if Debugger = nil then Exit;
if Debugger.State in [dsPause, dsStop]
then FEvaluated := False;
then begin
ClearOwned;
FEvaluated := False;
end;
if Debugger.State = dsPause then Changed;
end;
procedure TGDBMIWatch.Invalidate;
begin
ClearOwned;
FEvaluated := False;
end;
@ -3756,7 +4143,8 @@ begin
if (Debugger.State in [dsPause, dsStop])
and Enabled
then begin
ExprIsValid:=TGDBMIDebugger(Debugger).GDBEvaluate(Expression, FValue);
ClearOwned;
ExprIsValid:=TGDBMIDebugger(Debugger).GDBEvaluate(Expression, FValue, FTypeInfo);
if ExprIsValid then
SetValid(vsValid)
else
@ -3768,6 +4156,12 @@ begin
FEvaluated := True;
end;
procedure TGDBMIWatch.ClearOwned;
begin
FreeAndNil(FTypeInfo);
FValue:='';
end;
function TGDBMIWatch.GetValue: String;
begin
if (Debugger <> nil)
@ -3780,6 +4174,18 @@ begin
else Result := inherited GetValue;
end;
function TGDBMIWatch.GetTypeInfo: TDBGType;
begin
if (Debugger <> nil)
and (Debugger.State in [dsStop, dsPause])
and Enabled
then begin
EvaluationNeeded;
Result := FTypeInfo;
end
else Result := inherited GetTypeInfo;
end;
function TGDBMIWatch.GetValid: TValidState;
begin
EvaluationNeeded;
@ -4378,14 +4784,6 @@ begin
end;
end;
function TGDBMIExpression.Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String): Boolean;
var
GDBType: TGDBType;
begin
Result := Evaluate(ADebugger, AResult, GDBType);
if Result then GDBType.Free;
end;
function TGDBMIExpression.Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String; out AResultInfo: TGDBType): Boolean;
const
@ -4789,6 +5187,82 @@ begin
CreateFromValues(AResult.Values);
end;
{ TGDBStringIterator }
constructor TGDBStringIterator.Create(const AParsableData: String);
begin
inherited Create;
FParsableData := AParsableData;
FReadPointer := 1;
FDataSize := Length(AParsableData);
DebugLn(AParsableData);
end;
function TGDBStringIterator.ParseNext(out ADecomposable: Boolean; out
APayload: String; out ACharStopper: Char): Boolean;
var
InStr: Boolean;
InBrackets1, InBrackets2: Integer;
c: Char;
BeginString: Integer;
EndString: Integer;
begin
ADecomposable := False;
InStr := False;
InBrackets1 := 0;
InBrackets2 := 0;
BeginString := FReadPointer;
EndString := FDataSize;
ACharStopper := #0; //none
while FReadPointer <= FDataSize do
begin
c := FParsableData[FReadPointer];
if c = '''' then InStr := not InStr;
if not InStr
then begin
case c of
'{': Inc(InBrackets1);
'}': Dec(InBrackets1);
'[': Inc(InBrackets2);
']': Dec(InBrackets2);
end;
if (InBrackets1 = 0) and (InBrackets2 = 0) and (c in [',', '='])
then begin
EndString := FReadPointer - 1;
Inc(FReadPointer); //Skip this char
ACharStopper := c;
Break;
end;
end;
Inc(FReadPointer);
end;
//Remove boundary spaces.
while BeginString<EndString do
begin
if FParsableData[BeginString] <> ' ' then break;
Inc(BeginString);
end;
while EndString > BeginString do
begin
if FParsableData[EndString] <> ' ' then break;
Dec(EndString);
end;
if (EndString - BeginString > 0)
and (FParsableData[BeginString] = '{')
then begin
inc(BeginString);
dec(EndString);
ADecomposable := True;
end;
APayload := Copy(FParsableData, BeginString, EndString - BeginString + 1);
Result := Length(APayload) > 0;
end;
initialization
RegisterDebugger(TGDBMIDebugger);

281
debugger/gdbtypeinfo.pp
View File

@ -34,7 +34,7 @@ unit GDBTypeInfo;
interface
uses
Classes, SysUtils;
Classes, SysUtils, Debugger, LclProc;
(*
ptype = {
@ -51,78 +51,18 @@ uses
[ type = "..." ]
*)
type
TGDBSymbolKind = (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer);
TGDBFieldLocation = (flPrivate, flProtected, flPublic, flPublished);
TGDBFieldFlag = (ffVirtual);
TGDBFieldFlags = set of TGDBFieldFlag;
{ TGDBTypes }
TGDBType = class;
TGDBField = class(TObject)
private
FName: String;
FFlags: TGDBFieldFlags;
FLocation: TGDBFieldLocation;
FGDBType: TGDBType;
protected
TGDBTypes = class(TDBGTypes)
public
constructor Create;
destructor Destroy; override;
property Name: String read FName;
property GDBType: TGDBType read FGDBType;
property Location: TGDBFieldLocation read FLocation;
property Flags: TGDBFieldFlags read FFlags;
end;
TGDBFields = class(TObject)
private
FList: TList;
function GetField(const AIndex: Integer): TGDBField;
function GetCount: Integer;
protected
public
constructor Create;
destructor Destroy; override;
property Count: Integer read GetCount;
property Items[const AIndex: Integer]: TGDBField read GetField; default;
end;
TGDBTypes = class(TObject)
private
FList: TList;
function GetType(const AIndex: Integer): TGDBType;
function GetCount: Integer;
protected
public
constructor Create;
constructor CreateFromCSV(AValues: String);
destructor Destroy; override;
property Count: Integer read GetCount;
property Items[const AIndex: Integer]: TGDBType read GetType; default;
end;
{ TGDBType }
TGDBType = class(TObject)
private
FAncestor: String;
FResult: TGDBType;
FArguments: TGDBTypes;
FFields: TGDBFields;
FKind: TGDBSymbolKind;
FMembers: TStrings;
FTypeName: String;
protected
TGDBType = class(TDBGType)
public
constructor Create;
constructor CreateFromValues(const AValues: String);
destructor Destroy; override;
property Ancestor: String read FAncestor;
property Arguments: TGDBTypes read FArguments;
property Fields: TGDBFields read FFields;
property Kind: TGDBSymbolKind read FKind;
property TypeName: String read FTypeName;
property Members: TStrings read FMembers;
property Result: TGDBType read FResult;
end;
@ -130,6 +70,7 @@ function CreatePTypeValueList(AResultValues: String): TStringList;
implementation
(*
function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String): String;
var
n, i, idx, SkipLen: Integer;
@ -179,6 +120,7 @@ begin
Delete(ASource, 1, idx - 1);
end;
end;
*)
function CreatePTypeValueList(AResultValues: String): TStringList;
var
@ -306,62 +248,8 @@ begin
end;
end;
{ TGDBField }
constructor TGDBField.Create;
begin
FFlags := [];
FGDBType := nil;
FLocation := flPublic;
end;
destructor TGDBField.Destroy;
begin
if FGDBType<>nil then FreeAndNil(FGDBType);
inherited Destroy;
end;
{ TGDBFields }
constructor TGDBFields.Create;
begin
FList := TList.Create;
inherited;
end;
destructor TGDBFields.Destroy;
var
n: Integer;
begin
for n := 0 to Count - 1 do
Items[n].Free;
FreeAndNil(FList);
inherited;
end;
function TGDBFields.GetCount: Integer;
begin
Result := FList.Count;
end;
function TGDBFields.GetField(const AIndex: Integer): TGDBField;
begin
Result := TGDBField(FList[AIndex]);
end;
{ TGDBPType }
constructor TGDBType.Create;
begin
FResult := nil;
FArguments := nil;
FFields := nil;
FMembers := nil;
inherited Create;
end;
constructor TGDBType.CreateFromValues(const AValues: String);
var
S, Line: String;
@ -371,10 +259,10 @@ var
var
n: Integer;
S: String;
Field: TGDBField;
Field: TDBGField;
begin
FKind := skRecord;
FFields := TGDBFields.Create;
FFields := TDBGFields.Create;
//concatenate all lines and skip last end
S := '';
@ -383,13 +271,12 @@ var
while S <> '' do
begin
Field := TGDBField.Create;
Field.FName := GetPart([' '], [' '], S);
Field.FLocation := flPublic;
Field.FGDBType := TGDBType.Create;
Field.FGDBType.FKind := skSimple; // for now
Field.FGDBType.FTypeName := GetPart([' : '], [';'], S);
FFields.FList.Add(Field);
Field := TDBGField.Create(
GetPart([' '], [' '], S),
TGDBType.Create(skSimple, GetPart([' : '], [';'], S)),
flPublic
);
FFields.Add(Field);
Delete(S, 1, 1);
end;
end;
@ -460,21 +347,22 @@ var
S := S + Lines[n];
FArguments := TGDBTypes.CreateFromCSV(GetPart([], [')'], S));
FResult := TGDBType.Create;
FResult.FKind := skSimple; // for now
FResult.FTypeName := GetPart([' : '], [], S);
FResult := TGDBType.Create(skSimple, GetPart([' : '], [], S));
end;
procedure DoClass;
var
n: Integer;
Field: TGDBField;
S: String;
Location: TGDBFieldLocation;
Name: String;
DBGType: TDBGType;
Location: TDBGFieldLocation;
Flags: TDBGFieldFlags;
begin
FKind := skClass;
FAncestor := GetPart([': public '], [' '], Line);
FFields := TGDBFields.Create;
FFields := TDBGFields.Create;
Location := flPublished;
for n := 0 to Lines.Count - 2 do
@ -486,43 +374,65 @@ var
else if S = ' public' then Location := flPublic
else if S = ' published' then Location := flPublished
else begin
Field := TGDBField.Create;
Field.FLocation := Location;
Field.FGDBType := TGDBType.Create;
FFields.FList.Add(Field);
Flags := [];
if Pos(' procedure ', S) > 0
then begin
Field.FName := GetPart(['procedure '], [' ', ';'], S);
Field.FGDBType.FKind := skProcedure;
Field.FGDBType.FArguments := TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S));
Name := GetPart(['procedure '], [' ', ';'], S);
DBGType := TGDBType.Create(
skProcedure,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Field.FFlags := [ffVirtual];
then Flags := [ffVirtual];
end
else if Pos(' destructor ~', S) > 0
then begin
Name := GetPart(['destructor ~'], [' ', ';'], S);
DBGType := TGDBType.Create(
skProcedure,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
Include(Flags, ffDestructor);
end
else if Pos(' constructor ', S) > 0
then begin
Name := GetPart(['constructor '], [' ', ';'], S);
DBGType := TGDBType.Create(
skFunction,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S)),
TGDBType.Create(skSimple, GetPart([' : '], [';'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
Include(Flags, ffConstructor);
end
else if Pos(' function ', S) > 0
then begin
Field.FName := GetPart(['function '], [' ', ';'], S);
Field.FGDBType.FKind := skFunction;
Field.FGDBType.FArguments := TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S));
Field.FGDBType.FResult := TGDBType.Create;
Field.FGDBType.FResult.FKind := skSimple; // for now
Field.FGDBType.FResult.FTypeName := GetPart([' : '], [';'], S);
Name := GetPart(['function '], [' ', ';'], S);
DBGType := TGDBType.Create(
skFunction,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S)),
TGDBType.Create(skSimple, GetPart([' : '], [';'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Field.FFlags := [ffVirtual];
then Flags := [ffVirtual];
end
else begin
Field.FName := GetPart([' '], [' '], S);
Field.FGDBType.FKind := skSimple; // for now
Field.FGDBType.FTypeName := GetPart([' : '], [';'], S);
Name := GetPart([' '], [' '], S);
DBGType := TGDBType.Create(skSimple, GetPart([' : '], [';'], S));
end;
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags));
end;
end;
end;
var
HasClass: Boolean;
begin
Create;
Create(skSimple, '');
if AValues = '' then Exit;
@ -540,8 +450,14 @@ begin
if HasClass
and (S[2] <> '^') // pointer to class is handled next
then begin
FTypeName := GetPart(['^'], [' '], S);
DoClass;
FKind:=skClass;
if S[1] = '^' then begin
FKind:=skPointer;
FTypeName := GetPart(['^'], [' '], S);
end else begin
FTypeName := GetPart([], ['{'], S);
DoClass;
end;
end
else if S[1] = '^'
then begin
@ -549,6 +465,8 @@ begin
if HasClass
then FTypeName := GetPart(['^^'], [' ='], S)
else FTypeName := GetPart(['^'], [' ='], S);
// strip brackets
FTypeName := GetPart(['(', ''], [')'], FTypeName);
end
else if S = 'set'
then DoSet
@ -559,7 +477,15 @@ begin
else if Pos(' = (', Line) > 0
then DoEnum
else if Pos(' = record', Line) > 0
then DoRecord
then begin
FTypeName := S;
DoRecord
end
else if S = 'record'
then begin
// unnamed record (classtype ??)
DoRecord;
end
else begin
FKind := skSimple;
FTypeName := S;
@ -570,24 +496,8 @@ begin
end;
end;
destructor TGDBType.Destroy;
begin
if FResult<>nil then FreeAndNil(FResult);
if FArguments<>nil then FreeAndNil(FArguments);
if FFields<>nil then FreeAndNil(FFields);
if FMembers<>nil then FreeAndNil(FMembers);
inherited;
end;
{ TGDBPTypes }
constructor TGDBTypes.Create;
begin
FList := TList.Create;
inherited;
end;
constructor TGDBTypes.CreateFromCSV(AValues: String);
var
GDBType: TGDBType;
@ -595,33 +505,10 @@ begin
Create;
while AValues <> '' do
begin
GDBType := TGDBType.Create;
GDBType.FKind := skSimple;
GDBType.FTypeName := GetPart([], [', '], AValues);
GDBType := TGDBType.Create(skSimple, GetPart([], [', '], AValues));
FList.Add(GDBType);
{if Length(AValues) >= 2 then} Delete(AValues, 1, 2);
end;
end;
destructor TGDBTypes.Destroy;
var
n: Integer;
begin
for n := 0 to Count - 1 do
Items[n].Free;
FreeAndNil(FList);
inherited;
end;
function TGDBTypes.GetCount: Integer;
begin
Result := Flist.Count;
end;
function TGDBTypes.GetType(const AIndex: Integer): TGDBType;
begin
Result := TGDBType(FList[AIndex]);
end;
end.

33
debugger/inspectdlg.lfm
View File

@ -1,27 +1,27 @@
inherited IDEInspectDlg: TIDEInspectDlg
Left = 368
Height = 400
Top = 198
Width = 260
Left = 366
Height = 407
Top = 185
Width = 295
BorderStyle = bsSizeToolWin
Caption = 'IDEInspectDlg'
ClientHeight = 400
ClientWidth = 260
ClientHeight = 407
ClientWidth = 295
Constraints.MinHeight = 200
Constraints.MinWidth = 200
OnClose = FormClose
object StatusBar1: TStatusBar[0]
Left = 0
Height = 23
Top = 377
Width = 260
Top = 384
Width = 295
Panels = <>
end
object PageControl: TPageControl[1]
Left = 0
Height = 377
Top = 0
Width = 260
Height = 363
Top = 21
Width = 295
ActivePage = DataPage
Align = alClient
TabIndex = 0
@ -36,4 +36,15 @@ inherited IDEInspectDlg: TIDEInspectDlg
Caption = 'MethodsPage'
end
end
object EditInspected: TEdit[2]
Left = 0
Height = 21
Top = 0
Width = 295
Align = alTop
Enabled = False
ReadOnly = True
TabOrder = 2
Text = '(...)'
end
end

27
debugger/inspectdlg.lrs
View File

@ -1,13 +1,18 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TIDEInspectDlg','FORMDATA',[
'TPF0'#241#14'TIDEInspectDlg'#13'IDEInspectDlg'#4'Left'#3'p'#1#6'Height'#3#144
+#1#3'Top'#3#198#0#5'Width'#3#4#1#11'BorderStyle'#7#13'bsSizeToolWin'#7'Capti'
+'on'#6#13'IDEInspectDlg'#12'ClientHeight'#3#144#1#11'ClientWidth'#3#4#1#21'C'
+'onstraints.MinHeight'#3#200#0#20'Constraints.MinWidth'#3#200#0#7'OnClose'#7
+#9'FormClose'#0#242#2#0#10'TStatusBar'#10'StatusBar1'#4'Left'#2#0#6'Height'#2
+#23#3'Top'#3'y'#1#5'Width'#3#4#1#6'Panels'#14#0#0#0#242#2#1#12'TPageControl'
+#11'PageControl'#4'Left'#2#0#6'Height'#3'y'#1#3'Top'#2#0#5'Width'#3#4#1#10'A'
+'ctivePage'#7#8'DataPage'#5'Align'#7#8'alClient'#8'TabIndex'#2#0#8'TabOrder'
+#2#1#0#9'TTabSheet'#8'DataPage'#7'Caption'#6#8'DataPage'#0#0#9'TTabSheet'#14
+'PropertiesPage'#7'Caption'#6#14'PropertiesPage'#0#0#9'TTabSheet'#11'Methods'
+'Page'#7'Caption'#6#11'MethodsPage'#0#0#0#0
'TPF0'#241#14'TIDEInspectDlg'#13'IDEInspectDlg'#4'Left'#3'n'#1#6'Height'#3#151
+#1#3'Top'#3#185#0#5'Width'#3''''#1#11'BorderStyle'#7#13'bsSizeToolWin'#7'Cap'
+'tion'#6#13'IDEInspectDlg'#12'ClientHeight'#3#151#1#11'ClientWidth'#3''''#1
+#21'Constraints.MinHeight'#3#200#0#20'Constraints.MinWidth'#3#200#0#7'OnClos'
+'e'#7#9'FormClose'#0#242#2#0#10'TStatusBar'#10'StatusBar1'#4'Left'#2#0#6'Hei'
+'ght'#2#23#3'Top'#3#128#1#5'Width'#3''''#1#6'Panels'#14#0#0#0#242#2#1#12'TPa'
+'geControl'#11'PageControl'#4'Left'#2#0#6'Height'#3'k'#1#3'Top'#2#21#5'Width'
+#3''''#1#10'ActivePage'#7#8'DataPage'#5'Align'#7#8'alClient'#8'TabIndex'#2#0
+#8'TabOrder'#2#1#0#9'TTabSheet'#8'DataPage'#7'Caption'#6#8'DataPage'#0#0#9'T'
+'TabSheet'#14'PropertiesPage'#7'Caption'#6#14'PropertiesPage'#0#0#9'TTabShee'
+'t'#11'MethodsPage'#7'Caption'#6#11'MethodsPage'#0#0#0#242#2#2#5'TEdit'#13'E'
+'ditInspected'#4'Left'#2#0#6'Height'#2#21#3'Top'#2#0#5'Width'#3''''#1#5'Alig'
+'n'#7#5'alTop'#7'Enabled'#8#8'ReadOnly'#9#8'TabOrder'#2#2#4'Text'#6#5'(...)'
+#0#0#0
]);

288
debugger/inspectdlg.pas
View File

@ -30,13 +30,23 @@ interface
uses
Classes, SysUtils, TypInfo, FileUtil, LResources, Forms, Controls, Graphics,
Dialogs, ComCtrls, ObjectInspector, PropEdits, Debugger, DebuggerDlg,
LazarusIDEStrConsts, IDEWindowIntf;
LazarusIDEStrConsts, IDEWindowIntf,LCLProc,Grids, StdCtrls;
type
{ TOIDBGGrid }
TOIDBGGrid=class(TOIPropertyGrid)
private
protected
procedure BuildPropertyList(OnlyIfNeeded: boolean=false);
public
end;
{ TIDEInspectDlg }
TIDEInspectDlg = class(TDebuggerDlg)
EditInspected: TEdit;
PageControl: TPageControl;
StatusBar1: TStatusBar;
DataPage: TTabSheet;
@ -49,14 +59,28 @@ type
FMethodsGridHook: TPropertyEditorHook;
FDataGrid,
FPropertiesGrid,
FMethodsGrid: TOIPropertyGrid;
FMethodsGrid: TOIDBGGrid;
FDebugger: TDebugger;
FExpression: ansistring;
FHumanReadable: ansistring;
FDBGInfo: TDBGType;
FGridData: TStringGrid;
FGridMethods: TStringGrid;
procedure Localize;
procedure InspectClass;
procedure InspectRecord;
procedure InspectSimple;
procedure InspectPointer;
procedure GridDataSetup;
procedure GridMethodsSetup;
procedure ShowDataFields;
procedure ShowMethodsFields;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Execute(ADebugger: TDebugger; AData, AProperties, AMethods: TStrings);
end;
procedure Execute(const ADebugger: TDebugger; const AExpression: ansistring);
end;
implementation
@ -75,11 +99,220 @@ begin
MethodsPage.Caption := lisInspectMethods;
end;
procedure TIDEInspectDlg.InspectClass;
begin
DataPage.Visible:=true;
PropertiesPage.Visible:=false;
MethodsPage.Visible:=true;
if not Assigned(FDBGInfo) then exit;
if not Assigned(FDBGInfo.Fields) then exit;
EditInspected.Text:=FExpression+' : Class '+FDBGInfo.TypeName+' inherits from '+FDBGInfo.Ancestor;
GridDataSetup;
ShowDataFields;
FGridData.AutoSizeColumn(1);
FGridData.AutoSizeColumn(2);
GridMethodsSetup;
ShowMethodsFields;
FGridMethods.AutoSizeColumn(1);
FGridMethods.AutoSizeColumn(3);
end;
procedure TIDEInspectDlg.InspectRecord;
begin
DataPage.Visible:=true;
PropertiesPage.Visible:=false;
MethodsPage.Visible:=false;
if not Assigned(FDBGInfo) then exit;
if not Assigned(FDBGInfo.Fields) then exit;
EditInspected.Text:=FExpression+' : '+FDBGInfo.TypeName;
GridDataSetup;
ShowDataFields;
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.InspectSimple;
begin
if not Assigned(FDBGInfo) then exit;
EditInspected.Text:=FExpression+' : '+FDBGInfo.TypeName + ' = ' + FDBGInfo.Value.AsString;
GridDataSetup;
FGridData.Cells[0,1]:=FExpression;
FGridData.Cells[1,1]:=FDBGInfo.TypeName;
FGridData.Cells[2,1]:=FDBGInfo.Value.AsString;
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.InspectPointer;
begin
if not Assigned(FDBGInfo) then exit;
EditInspected.Text:=FExpression+' : ^'+FDBGInfo.TypeName + ' = ' + FDBGInfo.Value.AsString;
GridDataSetup;
FGridData.Cells[0,1]:=FExpression;
FGridData.Cells[1,1]:='Pointer to '+FDBGInfo.TypeName;
FGridData.Cells[2,1]:=format('$%x',[PtrUInt(FDBGInfo.Value.AsPointer)]);
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.GridDataSetup;
begin
with FGridData do begin
Clear;
BorderStyle:=bsNone;
BorderWidth:=0;
DefaultColWidth:=100;
Options:=[goColSizing,goDblClickAutoSize,goDrawFocusSelected,
goVertLine,goHorzLine,goFixedHorzLine,goSmoothScroll,
goTabs,goScrollKeepVisible,goRowSelect];
Align:=alClient;
TitleFont.Style:=[fsBold];
ExtendedSelect:=false;
RowCount:=2;
FixedRows:=1;
FixedCols:=0;
ColCount:=3;
Cols[0].Text:='Name';
Cols[1].Text:='Type';
Cols[2].Text:='Value';
Color:=clBtnFace;
end;
end;
procedure TIDEInspectDlg.GridMethodsSetup;
begin
with FGridMethods do begin
Clear;
BorderStyle:=bsNone;
BorderWidth:=0;
DefaultColWidth:=100;
Options:=[goColSizing,goDblClickAutoSize,goDrawFocusSelected,
goVertLine,goHorzLine,goFixedHorzLine,goSmoothScroll,
goTabs,goScrollKeepVisible,goRowSelect];
Align:=alClient;
TitleFont.Style:=[fsBold];
ExtendedSelect:=false;
RowCount:=2;
FixedRows:=1;
FixedCols:=0;
ColCount:=4;
Cols[0].Text:='Name';
Cols[1].Text:='Type';
Cols[2].Text:='Returns';
Cols[3].Text:='Address';
Color:=clBtnFace;
end;
end;
procedure TIDEInspectDlg.ShowDataFields;
var
j,k: SizeInt;
begin
k:=0;
for j := 0 to FDBGInfo.Fields.Count-1 do begin
case FDBGInfo.Fields[j].DBGType.Kind of
skSimple,skRecord,skPointer: inc(k);
end;
end;
k:=k+1;
if k<2 Then k:=2;
FGridData.RowCount:=k;
k:=0;
for j := 0 to FDBGInfo.Fields.Count-1 do begin
case FDBGInfo.Fields[j].DBGType.Kind of
skSimple:
begin
inc(k);
FGridData.Cells[0,k]:=FDBGInfo.Fields[j].Name;
FGridData.Cells[1,k]:=FDBGInfo.Fields[j].DBGType.TypeName;
if FDBGInfo.Fields[j].DBGType.Value.AsString='$0' then begin
if FDBGInfo.Fields[j].DBGType.TypeName='ANSISTRING' then begin
FGridData.Cells[2,k]:='''''';
end else begin
FGridData.Cells[2,k]:='nil';
end;
end else begin
FGridData.Cells[2,k]:=FDBGInfo.Fields[j].DBGType.Value.AsString;
end;
end;
skRecord:
begin
inc(k);
FGridData.Cells[0,k]:=FDBGInfo.Fields[j].Name;
FGridData.Cells[1,k]:='Record '+FDBGInfo.Fields[j].DBGType.TypeName;
FGridData.Cells[2,k]:=FDBGInfo.Fields[j].DBGType.Value.AsString;
end;
skProcedure:
begin
end;
skFunction:
begin
end;
skPointer:
begin
inc(k);
FGridData.Cells[0,k]:=FDBGInfo.Fields[j].Name;
FGridData.Cells[1,k]:='Pointer '+FDBGInfo.Fields[j].DBGType.TypeName;
FGridData.Cells[2,k]:=FDBGInfo.Fields[j].DBGType.Value.AsString;
end;
else
raise Exception.Create('Inspect: Unknown type in record ->'+inttostr(ord(FDBGInfo.Fields[j].DBGType.Kind)));
end;
end;
end;
procedure TIDEInspectDlg.ShowMethodsFields;
var
j,k: SizeInt;
begin
k:=0;
for j := 0 to FDBGInfo.Fields.Count-1 do begin
case FDBGInfo.Fields[j].DBGType.Kind of
skProcedure,skFunction: inc(k);
end;
end;
k:=k+1;
if k<2 Then k:=2;
FGridMethods.RowCount:=k;
k:=0;
for j := 0 to FDBGInfo.Fields.Count-1 do begin
case FDBGInfo.Fields[j].DBGType.Kind of
skProcedure:
begin
inc(k);
FGridMethods.Cells[0,k]:=FDBGInfo.Fields[j].Name;
if ffDestructor in FDBGInfo.Fields[j].Flags then begin
FGridMethods.Cells[1,k]:='Destructor';
end else begin
FGridMethods.Cells[1,k]:='Procedure';
end;
FGridMethods.Cells[2,k]:='';
FGridMethods.Cells[3,k]:='???';
end;
skFunction:
begin
inc(k);
FGridMethods.Cells[0,k]:=FDBGInfo.Fields[j].Name;
if ffConstructor in FDBGInfo.Fields[j].Flags then begin
FGridMethods.Cells[1,k]:='Constructor';
end else begin
FGridMethods.Cells[1,k]:='Function';
end;
if Assigned(FDBGInfo.Fields[j].DBGType.Result) then begin
FGridMethods.Cells[2,k]:=FDBGInfo.Fields[j].DBGType.Result.TypeName;
end else begin
FGridMethods.Cells[2,k]:='';
end;
FGridMethods.Cells[3,k]:='???';
end;
end;
end;
end;
constructor TIDEInspectDlg.Create(AOwner: TComponent);
function NewGrid(AName: String; AParent: TWinControl; AHook: TPropertyEditorHook): TOIPropertyGrid;
function NewGrid(AName: String; AParent: TWinControl; AHook: TPropertyEditorHook): TOIDBGGrid;
begin
Result := TOIPropertyGrid.Create(Self);
Result := TOIDBGGrid.Create(Self);
with Result do
begin
Name := AName;
@ -102,19 +335,56 @@ begin
Localize;
IDEDialogLayoutList.ApplyLayout(Self, 260, 400);
FGridData:=TStringGrid.Create(DataPage);
DataPage.InsertControl(FGridData);
GridDataSetup;
FGridMethods:=TStringGrid.Create(MethodsPage);
MethodsPage.InsertControl(FGridMethods);
GridMethodsSetup;
end;
destructor TIDEInspectDlg.Destroy;
begin
FreeAndNil(FDBGInfo);
FreeAndNil(FDataGridHook);
FreeAndNil(FPropertiesGridHook);
FreeAndNil(FMethodsGridHook);
inherited Destroy;
end;
procedure TIDEInspectDlg.Execute(ADebugger: TDebugger; AData, AProperties, AMethods: TStrings);
procedure TIDEInspectDlg.Execute(const ADebugger: TDebugger;
const AExpression: ansistring);
begin
FDataGrid.BuildPropertyList;
FExpression:='';
FreeAndNil(FDBGInfo);
FDebugger:=ADebugger;
if not FDebugger.Evaluate(AExpression,FHumanReadable,FDBGInfo) then begin
FreeAndNil(FDBGInfo);
Exit;
end;
if not assigned(FDBGInfo) then begin
exit;
end;
FExpression:=AExpression;
case FDBGInfo.Kind of
skClass: InspectClass();
skRecord: InspectRecord();
// skEnum: ;
// skSet: ;
// skProcedure: ;
// skFunction: ;
skSimple: InspectSimple();
skPointer: InspectPointer();
// skDecomposable: ;
end;
end;
{ TOIDBGGrid }
procedure TOIDBGGrid.BuildPropertyList(OnlyIfNeeded: boolean);
begin
end;
initialization

8
debugger/watchesdlg.lfm
View File

@ -7,12 +7,16 @@ inherited WatchesDlg: TWatchesDlg
VertScrollBar.Page = 199
ActiveControl = lvWatches
Caption = 'Watch list'
ClientHeight = 200
ClientWidth = 500
OnClose = FormClose
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
OnDestroy = FormDestroy
object lvWatches: TListView
object lvWatches: TListView[0]
Left = 0
Height = 200
Top = 0
Width = 500
Align = alClient
Columns = <
@ -33,7 +37,7 @@ inherited WatchesDlg: TWatchesDlg
OnKeyDown = lvWatchesKeyDown
OnSelectItem = lvWatchesSelectItem
end
object mnuPopup: TPopupMenu
object mnuPopup: TPopupMenu[1]
left = 100
top = 96
object popAdd: TMenuItem

37
debugger/watchesdlg.lrs
View File

@ -4,22 +4,23 @@ LazarusResources.Add('TWatchesDlg','FORMDATA',[
'TPF0'#241#11'TWatchesDlg'#10'WatchesDlg'#4'Left'#3'A'#1#6'Height'#3#200#0#3
+'Top'#3#181#1#5'Width'#3#244#1#18'HorzScrollBar.Page'#3#243#1#18'VertScrollB'
+'ar.Page'#3#199#0#13'ActiveControl'#7#9'lvWatches'#7'Caption'#6#10'Watch lis'
+'t'#7'OnClose'#7#9'FormClose'#12'OnCloseQuery'#7#14'FormCloseQuery'#8'OnCrea'
+'te'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#0#9'TListView'#9'lvWatc'
+'hes'#6'Height'#3#200#0#5'Width'#3#244#1#5'Align'#7#8'alClient'#7'Columns'#14
+#1#7'Caption'#6#10'Expression'#5'Width'#2#10#0#1#7'Caption'#6#5'Value'#5'Wid'
+'th'#2#10#0#0#11'MultiSelect'#9#9'PopupMenu'#7#8'mnuPopup'#9'RowSelect'#9#8
+'TabOrder'#2#0#9'ViewStyle'#7#8'vsReport'#10'OnDblClick'#7#17'lvWatchesDblCl'
+'ick'#9'OnKeyDown'#7#16'lvWatchesKeyDown'#12'OnSelectItem'#7#19'lvWatchesSel'
+'ectItem'#0#0#10'TPopupMenu'#8'mnuPopup'#4'left'#2'd'#3'top'#2'`'#0#9'TMenuI'
+'tem'#6'popAdd'#7'Caption'#6#4'&Add'#7'OnClick'#7#11'popAddClick'#0#0#9'TMen'
+'uItem'#2'N1'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#13'popProperties'#7'Caption'
+#6#11'&Properties'#7'OnClick'#7#18'popPropertiesClick'#0#0#9'TMenuItem'#10'p'
+'opEnabled'#7'Caption'#6#8'&Enabled'#7'OnClick'#7#15'popEnabledClick'#0#0#9
+'TMenuItem'#9'popDelete'#7'Caption'#6#7'&Delete'#7'OnClick'#7#14'popDeleteCl'
+'ick'#0#0#9'TMenuItem'#2'N2'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#13'popDisabl'
+'eAll'#7'Caption'#6#12'D&isable All'#7'OnClick'#7#18'popDisableAllClick'#0#0
+#9'TMenuItem'#12'popEnableAll'#7'Caption'#6#11'E&nable All'#7'OnClick'#7#17
+'popEnableAllClick'#0#0#9'TMenuItem'#12'popDeleteAll'#7'Caption'#6#11'De&let'
+'e All'#7'OnClick'#7#17'popDeleteAllClick'#0#0#0#0
+'t'#12'ClientHeight'#3#200#0#11'ClientWidth'#3#244#1#7'OnClose'#7#9'FormClos'
+'e'#12'OnCloseQuery'#7#14'FormCloseQuery'#8'OnCreate'#7#10'FormCreate'#9'OnD'
+'estroy'#7#11'FormDestroy'#0#242#2#0#9'TListView'#9'lvWatches'#4'Left'#2#0#6
+'Height'#3#200#0#3'Top'#2#0#5'Width'#3#244#1#5'Align'#7#8'alClient'#7'Column'
+'s'#14#1#7'Caption'#6#10'Expression'#5'Width'#2#10#0#1#7'Caption'#6#5'Value'
+#5'Width'#2#10#0#0#11'MultiSelect'#9#9'PopupMenu'#7#8'mnuPopup'#9'RowSelect'
+#9#8'TabOrder'#2#0#9'ViewStyle'#7#8'vsReport'#10'OnDblClick'#7#17'lvWatchesD'
+'blClick'#9'OnKeyDown'#7#16'lvWatchesKeyDown'#12'OnSelectItem'#7#19'lvWatche'
+'sSelectItem'#0#0#242#2#1#10'TPopupMenu'#8'mnuPopup'#4'left'#2'd'#3'top'#2'`'
+#0#9'TMenuItem'#6'popAdd'#7'Caption'#6#4'&Add'#7'OnClick'#7#11'popAddClick'#0
+#0#9'TMenuItem'#2'N1'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#13'popProperties'#7
+'Caption'#6#11'&Properties'#7'OnClick'#7#18'popPropertiesClick'#0#0#9'TMenuI'
+'tem'#10'popEnabled'#7'Caption'#6#8'&Enabled'#7'OnClick'#7#15'popEnabledClic'
+'k'#0#0#9'TMenuItem'#9'popDelete'#7'Caption'#6#7'&Delete'#7'OnClick'#7#14'po'
+'pDeleteClick'#0#0#9'TMenuItem'#2'N2'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#13
+'popDisableAll'#7'Caption'#6#12'D&isable All'#7'OnClick'#7#18'popDisableAllC'
+'lick'#0#0#9'TMenuItem'#12'popEnableAll'#7'Caption'#6#11'E&nable All'#7'OnCl'
+'ick'#7#17'popEnableAllClick'#0#0#9'TMenuItem'#12'popDeleteAll'#7'Caption'#6
+#11'De&lete All'#7'OnClick'#7#17'popDeleteAllClick'#0#0#0#0
]);

32
debugger/watchesdlg.pp
View File

@ -289,11 +289,41 @@ begin
end;
procedure TWatchesDlg.UpdateItem(const AItem: TListItem; const AWatch: TIDEWatch);
function ClearMultiline(const AValue: ansistring): ansistring;
var
j: SizeInt;
ow: SizeInt;
NewLine: Boolean;
begin
ow:=0;
SetLength(Result,Length(AValue));
NewLine:=true;
for j := 1 to Length(AValue) do begin
if (AValue[j]=#13) or (AValue[j]=#10) then begin
NewLine:=true;
end else if Avalue[j]=#32 then begin
if not NewLine then begin
inc(ow);
Result[ow]:=#32;
end;
end else begin
inc(ow);
Result[ow]:=AValue[j];
NewLine:=false;
end;
end;
If ow>255 then begin
//Limit watch to 255 chars in length
Result:=Copy(Result,1,252)+'...';
end else begin
SetLength(Result,ow);
end;
end;
begin
// Expression
// Result
AItem.Caption := AWatch.Expression;
AItem.SubItems[0] := AWatch.Value;
AItem.SubItems[0] := ClearMultiline(AWatch.Value);
end;
procedure TWatchesDlg.WatchAdd(const ASender: TIDEWatches; const AWatch: TIDEWatch);

6
ide/basedebugmanager.pas
View File

@ -108,8 +108,10 @@ type
function RunDebugger: TModalResult; virtual; abstract;
procedure EndDebugging; virtual; abstract;
function Evaluate(const AExpression: String; var AResult: String
): Boolean; virtual; abstract; // Evaluates the given expression, returns true if valid
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean; virtual; abstract; // Evaluates the given expression, returns true if valid
function GetFullFilename(var Filename: string; AskUserIfNotFound: Boolean): Boolean; virtual; abstract;
procedure Inspect(const AExpression: String); virtual; abstract;

64
ide/debugmanager.pas
View File

@ -166,8 +166,9 @@ type
function RunDebugger: TModalResult; override;
procedure EndDebugging; override;
function Evaluate(const AExpression: String;
var AResult: String): Boolean; override;
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean; override;
procedure Inspect(const AExpression: String); override;
function GetFullFilename(var Filename: string; AskUserIfNotFound: Boolean): Boolean; override;
@ -244,6 +245,8 @@ type
property Master: TDBGBreakPoints read FMaster write SetMaster;
end;
{ TManagedWatch }
TManagedWatch = class(TIDEWatch)
private
FMaster: TDBGWatch;
@ -252,6 +255,7 @@ type
procedure DoChanged; override;
function GetValid: TValidState; override;
function GetValue: String; override;
function GetTypeInfo: TDBGType; override;
procedure SetEnabled(const AValue: Boolean); override;
procedure SetExpression(const AValue: String); override;
public
@ -692,6 +696,13 @@ begin
else Result := FMaster.Value;
end;
function TManagedWatch.GetTypeInfo: TDBGType;
begin
if FMaster = nil
then Result := inherited GetTypeInfo
else Result := FMaster.TypeInfo;
end;
procedure TManagedWatch.SetEnabled(const AValue: Boolean);
begin
if Enabled = AValue then Exit;
@ -1553,8 +1564,7 @@ begin
if SrcLine < 1
then begin
ViewDebugDialog(ddtAssembler);
(*
if FDialogs[ddtAssembler] = nil
then begin
// TODO: change into assemblerview failure
@ -1563,22 +1573,24 @@ begin
HexStr(ALocation.Address, FDebugger.TargetWidth div 4), #13,
ALocation.FuncName, #13, ALocation.SrcFile, #13#13#13, #13]),
mtInformation, [mbOK],0);
// jump to the deepest stack frame with debugging info
i:=0;
while (i < FDebugger.CallStack.Count) do
begin
StackEntry := FDebugger.CallStack.Entries[i];
if StackEntry.Line > 0
then begin
SrcLine := StackEntry.Line;
SrcFile := StackEntry.Source;
StackEntry.Current := True;
Break;
end;
Inc(i);
end; *)
// jump to the deepest stack frame with debugging info
i:=0;
while (i < FDebugger.CallStack.Count) do
begin
StackEntry := FDebugger.CallStack.Entries[i];
if StackEntry.Line > 0
then begin
SrcLine := StackEntry.Line;
SrcFile := StackEntry.Source;
StackEntry.Current := True;
Break;
end;
if SrcLine < 1 then Exit;
Inc(i);
end;
if SrcLine < 1 then begin
ViewDebugDialog(ddtAssembler);
Exit;
end;
end;
@ -1760,11 +1772,10 @@ begin
end;
procedure TDebugManager.InitInspectDlg;
var
TheDialog: TIDEInspectDlg;
//var
// TheDialog: TIDEInspectDlg;
begin
TheDialog := TIDEInspectDlg(FDialogs[ddtInspect]);
TheDialog.Execute(FDebugger, nil, nil, nil);
// TheDialog := TIDEInspectDlg(FDialogs[ddtInspect]);
end;
procedure TDebugManager.InitCallStackDlg;
@ -2353,13 +2364,13 @@ begin
end;
function TDebugManager.Evaluate(const AExpression: String;
var AResult: String): Boolean;
var AResult: String; var ATypeInfo: TDBGType): Boolean;
begin
Result := (not Destroying)
and (MainIDE.ToolStatus = itDebugger)
and (FDebugger <> nil)
and (dcEvaluate in FDebugger.Commands)
and FDebugger.Evaluate(AExpression, AResult)
and FDebugger.Evaluate(AExpression, AResult, ATypeInfo)
end;
procedure TDebugManager.Inspect(const AExpression: String);
@ -2368,8 +2379,7 @@ begin
ViewDebugDialog(ddtInspect);
if FDialogs[ddtInspect] <> nil then
begin
// todo: fill data, properties, methods
TIDEInspectDlg(FDialogs[ddtInspect]).Execute(FDebugger, nil, nil, nil);
TIDEInspectDlg(FDialogs[ddtInspect]).Execute(FDebugger, AExpression);
end;
end;

18
ide/main.pp
View File

@ -92,7 +92,7 @@ uses
// LRT stuff
Translations,
// debugger
RunParamsOpts, BaseDebugManager, DebugManager,
RunParamsOpts, BaseDebugManager, DebugManager, debugger,
// packager
PackageSystem, PkgManager, BasePkgManager,
// source editing
@ -13828,7 +13828,8 @@ procedure TMainIDE.OnSrcNotebookShowHintForSource(SrcEdit: TSourceEditor;
var
ActiveSrcEdit: TSourceEditor;
ActiveUnitInfo: TUnitInfo;
BaseURL, SmartHintStr, Expression, DebugEval: String;
BaseURL, SmartHintStr, Expression, DebugEval, DebugEvalDerefer: String;
DBGType,DBGTypeDerefer: TDBGType;
begin
//DebugLn(['TMainIDE.OnSrcNotebookShowHintForSource START']);
if (SrcEdit=nil) then exit;
@ -13855,9 +13856,20 @@ begin
Expression := SrcEdit.GetText(True)
else
Expression := SrcEdit.GetOperandFromCaret(CaretPos);
if Expression='' then exit;
//DebugLn(['TMainIDE.OnSrcNotebookShowHintForSource Expression="',Expression,'"']);
if not DebugBoss.Evaluate(Expression, DebugEval) or (DebugEval = '') then
DBGType:=nil;
DBGTypeDerefer:=nil;
if not DebugBoss.Evaluate(Expression, DebugEval, DBGType) or (DebugEval = '') then
DebugEval := '???';
if Assigned(DBGType) and ((DBGType.Kind=skPointer) or (DBGType.Kind=skClass)) then begin
if DBGType.Value.AsPointer<>nil then begin
if DebugBoss.Evaluate(Expression+'^', DebugEvalDerefer, DBGTypeDerefer) then
DebugEval:=DebugEval+' = '+DebugEvalDerefer;
end;
end;
FreeAndNil(DBGType);
FreeAndNil(DBGTypeDerefer);
SmartHintStr := Expression + ' = ' + DebugEval;
end;
else