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

DBG: "inspect" dialog, now shows entire class

Browse Source 
git-svn-id: trunk@29056 -
This commit is contained in:
martin 2011-01-16 19:11:23 +00:00
parent b15353401b
commit 5b6cc6df96
7 changed files with 456 additions and 100 deletions

55
debugger/debugger.pp
View File

@ -131,6 +131,12 @@ type
TValidState = (vsUnknown, vsValid, vsInvalid);
TDBGEvaluateFlag =
(defNoTypeInfo, // No Typeinfo object will be returned
defSimpleTypeInfo, // Returns: Kind (skSimple, skClass, ..); TypeName (but does make no attempt to avoid an alias)
defFullTypeInfo // Get all typeinfo, resolve all anchestors
);
TDBGEvaluateFlags = set of TDBGEvaluateFlag;
const
// dcRunCommands = [dcRun,dcStepInto,dcStepOver,dcRunTo];
@ -486,18 +492,26 @@ type
TDBGField = class(TObject)
private
FRefCount: Integer;
protected
FName: String;
FFlags: TDBGFieldFlags;
FLocation: TDBGFieldLocation;
FDBGType: TDBGType;
FClassName: String;
procedure IncRefCount;
procedure DecRefCount;
property RefCount: Integer read FRefCount;
public
constructor Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags = []);
constructor Create(const AName: String; ADBGType: TDBGType;
ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags = [];
AClassName: String = '');
destructor Destroy; override;
property Name: String read FName;
property DBGType: TDBGType read FDBGType;
property Location: TDBGFieldLocation read FLocation;
property Flags: TDBGFieldFlags read FFlags;
property ClassName: String read FClassName; // the class in which the field was declared
end;
{ TDBGFields }
@ -542,7 +556,9 @@ type
FKind: TDBGSymbolKind;
FMembers: TStrings;
FTypeName: String;
FTypeDeclaration: String;
FDBGValue: TDBGValue;
procedure Init; virtual;
public
Value: TDBGValue;
constructor Create(AKind: TDBGSymbolKind; const ATypeName: String);
@ -553,7 +569,8 @@ type
property Fields: TDBGFields read FFields;
property Kind: TDBGSymbolKind read FKind;
property Attributes: TDBGSymbolAttributes read FAttributes;
property TypeName: String read FTypeName;
property TypeName: String read FTypeName; // Name/Alias as in type section. One pascal token, or empty
property TypeDeclaration: String read FTypeDeclaration; // Declaration (for array, set, enum, ..)
property Members: TStrings read FMembers;
property Result: TDBGType read FResult;
end;
@ -1583,7 +1600,8 @@ type
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;
var ATypeInfo: TDBGType): Boolean; // Evaluates the given expression, returns true if valid
var ATypeInfo: TDBGType;
EvalFlags: TDBGEvaluateFlags = []): 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, AFile: String; out ALine: Integer): Boolean; deprecated;
@ -2059,10 +2077,10 @@ begin
end;
function TDebugger.Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean;
var ATypeInfo: TDBGType; EvalFlags: TDBGEvaluateFlags = []): Boolean;
begin
FreeAndNIL(ATypeInfo);
Result := ReqCmd(dcEvaluate, [AExpression, @AResult, @ATypeInfo]);
Result := ReqCmd(dcEvaluate, [AExpression, @AResult, @ATypeInfo, Integer(EvalFlags)]);
end;
class function TDebugger.ExePaths: String;
@ -3281,13 +3299,28 @@ end;
{ TDBGField }
constructor TDBGField.Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags);
procedure TDBGField.IncRefCount;
begin
inc(FRefCount);
end;
procedure TDBGField.DecRefCount;
begin
dec(FRefCount);
if FRefCount <= 0
then Self.Free;
end;
constructor TDBGField.Create(const AName: String; ADBGType: TDBGType;
ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags; AClassName: String = '');
begin
inherited Create;
FName := AName;
FLocation := ALocation;
FDBGType := ADBGType;
FFlags := AFlags;
FRefCount := 0;
FClassName := AClassName;
end;
destructor TDBGField.Destroy;
@ -3309,7 +3342,7 @@ var
n: Integer;
begin
for n := 0 to Count - 1 do
Items[n].Free;
Items[n].DecRefCount;
FreeAndNil(FList);
inherited;
@ -3317,6 +3350,7 @@ end;
procedure TDBGFields.Add(const AField: TDBGField);
begin
AField.IncRefCount;
FList.Add(AField);
end;
@ -3332,10 +3366,16 @@ end;
{ TDBGPType }
procedure TDBGType.Init;
begin
//
end;
constructor TDBGType.Create(AKind: TDBGSymbolKind; const ATypeName: String);
begin
FKind := AKind;
FTypeName := ATypeName;
Init;
inherited Create;
end;
@ -3344,6 +3384,7 @@ begin
FKind := AKind;
FArguments := AArguments;
FResult := AResult;
Init;
inherited Create;
end;

197
debugger/gdbmidebugger.pp
View File

@ -224,7 +224,7 @@ 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): TGDBType;
function GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False): 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;
@ -294,7 +294,8 @@ type
// Implementation of external functions
function GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
function GDBEvaluate(const AExpression: String; var AResult: String; out ATypeInfo: TGDBType): Boolean;
function GDBEvaluate(const AExpression: String; var AResult: String;
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
function GDBModify(const AExpression, ANewValue: String): Boolean;
function GDBRun: Boolean;
function GDBPause(const AInternal: Boolean): Boolean;
@ -828,6 +829,7 @@ type
TGDBMIDebuggerCommandEvaluate = class(TGDBMIDebuggerCommand)
private
FEvalFlags: TDBGEvaluateFlags;
FExpression: String;
FDisplayFormat: TWatchDisplayFormat;
FTextValue: String;
@ -839,6 +841,7 @@ type
const ADisplayFormat: TWatchDisplayFormat);
function DebugText: String; override;
property Expression: String read FExpression;
property EvalFlags: TDBGEvaluateFlags read FEvalFlags write FEvalFlags;
property DisplayFormat: TWatchDisplayFormat read FDisplayFormat;
property TextValue: String read FTextValue;
property TypeInfo: TGDBType read FTypeInfo;
@ -5068,17 +5071,21 @@ begin
end;
end;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String; out ATypeInfo: TGDBType): Boolean;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String;
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
var
CommandObj: TGDBMIDebuggerCommandEvaluate;
begin
CommandObj := TGDBMIDebuggerCommandEvaluate.Create(Self, AExpression, wdfDefault);
CommandObj.EvalFlags := EvalFlags;
CommandObj.KeepFinished := True;
CommandObj.Priority := GDCMD_PRIOR_IMMEDIATE; // try run imediately
QueueCommand(CommandObj);
Result := CommandObj.State in [dcsExecuting, dcsFinished];
AResult := CommandObj.TextValue;
ATypeInfo := CommandObj.TypeInfo;
if EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
then FreeAndNil(ATypeInfo);
CommandObj.KeepFinished := False;
end;
@ -5582,6 +5589,8 @@ begin
end;
function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
var
EvalFlags: TDBGEvaluateFlags;
begin
LockRelease;
try
@ -5594,7 +5603,14 @@ begin
dcStepOut: Result := GDBStepOut;
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^),TGDBType(AParams[2].VPointer^));
dcEvaluate: begin
EvalFlags := [];
if high(AParams) >= 3 then
EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);
Result := GDBEvaluate(String(AParams[0].VAnsiString),
String(AParams[1].VPointer^), TGDBType(AParams[2].VPointer^),
EvalFlags);
end;
dcModify: Result := GDBModify(String(AParams[0].VAnsiString), String(AParams[1].VAnsiString));
dcEnvironment: Result := GDBEnvironment(String(AParams[0].VAnsiString), AParams[1].VBoolean);
dcDisassemble: Result := GDBDisassemble(AParams[0].VQWord^, AParams[1].VBoolean, TDbgPtr(AParams[2].VPointer^),
@ -8466,10 +8482,11 @@ begin
Result := UTF8Encode(WStr);
end;
function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String): TGDBType;
function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False): TGDBType;
var
R: TGDBMIExecResult;
f: Boolean;
flags: TGDBTypeCreationFlags;
AReq: PGDBPTypeRequest;
begin
(* Analyze what type is in AExpression
@ -8534,7 +8551,12 @@ begin
*)
Result := TGdbType.CreateForExpression(AExpression, tfClassIsPointer in TargetInfo^.TargetFlags);
flags := [];
if tfClassIsPointer in TargetInfo^.TargetFlags
then flags := [gtcfClassIsPointer];
if FullTypeInfo
then flags := [gtcfFullTypeInfo];
Result := TGdbType.CreateForExpression(AExpression, flags);
while not Result.ProcessExpression do begin
if Result.EvalError
then break;
@ -9099,12 +9121,149 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
procedure PutValuesInClass(const AType: TGDBType; ATextInfo: String);
var
GDBParser: TGDBStringIterator;
Payload: String;
Composite: Boolean;
StopChar: Char;
j: Integer;
//GDBParser: TGDBStringIterator;
//Payload: String;
//Composite: Boolean;
//StopChar: Char;
//j: Integer;
AWarnText: string;
StartPtr, EndPtr: PChar;
Procedure SkipSpaces;
begin
while (StartPtr <= EndPtr) and (StartPtr^ = ' ') do inc(StartPtr);
end;
Procedure SkipToEndOfField(EndAtComma: Boolean = False);
var
i: Integer;
begin
// skip forward, past the next ",", but do NOT skip the closing "}"
i := 1;
while (StartPtr <= EndPtr) and (i > 0) do begin
case StartPtr^ of
'{': inc(i);
'}': if i = 1
then break // do not skip }
else dec(i);
'''': begin
inc(StartPtr);
while (StartPtr <= EndPtr) and (StartPtr^ <> '''') do inc(StartPtr);
end;
',': if (i = 1) then begin
if EndAtComma then break;
i := 0;
end;
end;
inc(StartPtr);
end;
SkipSpaces;
end;
procedure ProcessAncestor(ATypeName: String);
var
HelpPtr, HelpPtr2: PChar;
NewName, NewVal: String;
i: Integer;
begin
inc(StartPtr); // skip '{'
SkipSpaces;
if StartPtr^ = '<' Then begin
inc(StartPtr);
HelpPtr := StartPtr;
while (HelpPtr <= EndPtr) and (HelpPtr^ <> '>') do inc(HelpPtr);
NewName := copy(StartPtr, 1, HelpPtr - StartPtr);
StartPtr := HelpPtr + 1;
SkipSpaces;
if StartPtr^ <> '=' then begin
debugln('WARNING: PutValuesInClass: Expected "=" for ancestor "' + NewName + '" in: ' + AWarnText);
AWarnText := '';
SkipToEndOfField;
// continue fields, or end
end
else begin
inc(StartPtr);
SkipSpaces;
if StartPtr^ <> '{'
then begin
//It is not a class
debugln('WARNING: PutValuesInClass: Expected "{" for ancestor "' + NewName + '" in: ' + AWarnText);
AWarnText := '';
SkipToEndOfField;
end
else
ProcessAncestor(NewName);
if StartPtr^ = ',' then inc(StartPtr);
SkipSpaces;
end;
end;
// process fields in this ancestor
while (StartPtr <= EndPtr) and (StartPtr^ <> '}') do begin
HelpPtr := StartPtr;
while (HelpPtr < EndPtr) and not (HelpPtr^ in [' ', '=', ',']) do inc(HelpPtr);
NewName := uppercase(copy(StartPtr, 1, HelpPtr - StartPtr)); // name of field
StartPtr := HelpPtr;
SkipSpaces;
if StartPtr^ <> '=' then begin
debugln('WARNING: PutValuesInClass: Expected "=" for field"' + NewName + '" in: ' + AWarnText);
AWarnText := '';
SkipToEndOfField;
continue;
end;
inc(StartPtr);
SkipSpaces;
HelpPtr := StartPtr;
SkipToEndOfField(True);
HelpPtr2 := StartPtr; // "," or "}"
dec(HelpPtr2);
while HelpPtr2^ = ' ' do dec(HelpPtr2);
NewVal := copy(HelpPtr, 1, HelpPtr2 + 1 - HelpPtr); // name of field
i := AType.Fields.Count - 1;
while (i >= 0)
and ( (uppercase(AType.Fields[i].Name) <> NewName)
or (uppercase(AType.Fields[i].ClassName) <> ATypeName) )
do dec(i);
if i < 0 then begin
if (uppercase(ATypeName) <> 'TOBJECT') or (pos('vptr', NewName) < 1)
then debugln('WARNING: PutValuesInClass: No field for "' + ATypeName + '"."' + NewName + '"');
end
else
AType.Fields[i].DBGType.Value.AsString := HexCToHexPascal(NewVal);
if (StartPtr^ <> '}') then inc(StartPtr);
SkipSpaces;
end;
inc(StartPtr); // skip the }
end;
begin
if ATextInfo = '' then exit;
AWarnText := ATextInfo;
StartPtr := @ATextInfo[1];
EndPtr := @ATextInfo[length(ATextInfo)];
while EndPtr^ = ' ' do dec(EndPtr);
SkipSpaces;
if StartPtr^ <> '{'
then begin
//It is not a class
debugln('ERROR: PutValuesInClass: Expected class, but found: "', ATextInfo, '"');
exit;
end;
ProcessAncestor(AType.TypeName);
////
(*
GDBParser := TGDBStringIterator.Create(ATextInfo);
GDBParser.ParseNext(Composite, Payload, StopChar);
GDBParser.Free;
@ -9167,6 +9326,7 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
finally
GDBParser.Free;
end;
*)
end;
procedure PutValuesInTree();
@ -9188,8 +9348,12 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
skVariant: begin
FTypeInfo.Value.AsString:=ValData;
end;
// skEnum: ;
// skSet: ;
skEnum: begin
FTypeInfo.Value.AsString:=ValData;
end;
skSet: begin
FTypeInfo.Value.AsString:=ValData;
end;
skSimple: begin
FTypeInfo.Value.AsString:=ValData;
end;
@ -9465,7 +9629,7 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
begin
// Check for strings
if ResultInfo = nil then
ResultInfo := GetGDBTypeInfo(AnExpression);
ResultInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags);
if (ResultInfo = nil) then Exit;
FTypeInfo := ResultInfo;
@ -9629,7 +9793,7 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
function PrepareExpr(var expr: string; NoAddressOp: Boolean = False): boolean;
begin
FTypeInfo := GetGDBTypeInfo(expr);
FTypeInfo := GetGDBTypeInfo(expr, defFullTypeInfo in FEvalFlags);
Result := FTypeInfo <> nil;
if (not Result) and StoreError
then FTextValue := '<error>';
@ -9762,7 +9926,7 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
else // wdfDefault
begin
Result := False;
FTypeInfo := GetGDBTypeInfo(AnExpression);
FTypeInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags);
if FTypeInfo = nil
then begin
ResultList := TGDBMINameValueList.Create(LastExecResult.Values);
@ -9871,6 +10035,7 @@ begin
FDisplayFormat := ADisplayFormat;
FTextValue := '';
FTypeInfo:=nil;
FEvalFlags := [];
end;
function TGDBMIDebuggerCommandEvaluate.DebugText: String;

211
debugger/gdbtypeinfo.pp
View File

@ -168,10 +168,14 @@ type
{ TGDBType }
TGDBTypeCreationFlag = (gtcfClassIsPointer, gtcfFullTypeInfo, gtcfExprIsType);
TGDBTypeCreationFlags = set of TGDBTypeCreationFlag;
TGDBTypeProcessState =
(gtpsInitial,
gtpsSimplePointer,
gtpsClass, gtpsClassPointer
gtpsClass, gtpsClassPointer, gtpsClassAncestor,
gtpsFinished
);
TGDBTypeProcessRequest =
(gptrPTypeExpr, gptrWhatisExpr, gptrPTypeOfWhatis,
@ -186,7 +190,8 @@ type
FEvalError: boolean;
FEvalRequest: PGDBPTypeRequest;
FExpression: string;
FClassIsPointer: Boolean;
FCreationFlags: TGDBTypeCreationFlags;
FTypeInfoAncestor: TGDBType;
FProcessState: TGDBTypeProcessState;
FProccesReuestsMade: TGDBTypeProcessRequests;
@ -195,9 +200,12 @@ type
procedure AddTypeReq(var AReq :TGDBPTypeRequest; const ACmd: string = '');
function RequireRequests(ARequired: TGDBTypeProcessRequests): Boolean;
function IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
protected
procedure Init; override;
public
constructor CreateForExpression(const AnExpression: string;
const AClassIsPointer: Boolean = False);
const AFlags: TGDBTypeCreationFlags);
destructor Destroy; override;
function ProcessExpression: Boolean;
property EvalRequest: PGDBPTypeRequest read FEvalRequest;
property EvalError: boolean read FEvalError;
@ -726,22 +734,35 @@ end;
function TGDBType.IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
begin
Result := (FReqResults[AReqType].Error <> '')
Result := (not (AReqType in FProccesReuestsMade))
or (FReqResults[AReqType].Error <> '')
or (CheckResKind and (FReqResults[AReqType].Result.Kind = ptprkError));
end;
procedure TGDBType.Init;
begin
inherited Init;
FProcessState := gtpsFinished;
end;
constructor TGDBType.CreateForExpression(const AnExpression: string;
const AClassIsPointer: Boolean);
const AFlags: TGDBTypeCreationFlags);
begin
Create(skSimple, ''); // initialize
FInternalTypeName := '';
FEvalError := False;
FExpression := AnExpression;
FClassIsPointer := AClassIsPointer;
FCreationFlags := AFlags;
FEvalRequest := nil;
FProcessState := gtpsInitial;
end;
destructor TGDBType.Destroy;
begin
inherited Destroy;
FreeAndNil(FTypeInfoAncestor);
end;
function TGDBType.ProcessExpression: Boolean;
var
Lines: TStringList;
@ -754,6 +775,21 @@ var
if i > 0 then delete(Result, i, 1);
end;
procedure SetTypNameFromReq(AReqType: TGDBTypeProcessRequest;
AnUseBaseName: Boolean = False; ADefaultName: String = '');
begin
if IsReqError(AReqType) or (FReqResults[AReqType].Result.BaseName.Len = 0)
then AReqType := gptrPTypeExpr;
if AnUseBaseName
then FTypeName := PCLenToString(FReqResults[AReqType].Result.BaseName)
else FTypeName := ClearAmpersand(PCLenToString(FReqResults[AReqType].Result.Name));
if FTypeName = ''
then FTypeName := ADefaultName;
FInternalTypeName := FTypeName;
end;
Procedure InitLinesFrom(AReq: TGDBPTypeRequest);
begin
FreeAndNil(Lines);
@ -861,8 +897,8 @@ var
{%region * Class * }
procedure DoClass;
var
n: Integer;
S: String;
n, i: Integer;
S, S2: String;
Name: String;
DBGType: TDBGType;
@ -878,17 +914,20 @@ var
FAncestor := GetPart([': public '], [' '], s);
Location := flPublished;
for n := 1 to Lines.Count - 2 do
n := 0;
while n < Lines.Count - 2 do
begin
inc(n);
S := Lines[n];
if S = '' then Continue;
if S = 'end' then break;
if S = ' private' then Location := flPrivate
else if S = ' protected' then Location := flProtected
else if S = ' public' then Location := flPublic
else if S = ' published' then Location := flPublished
else begin
Flags := [];
if Pos(' procedure ', S) > 0
if Pos(' procedure ', S) > 0
then begin
Name := GetPart(['procedure '], [' ', ';'], S);
DBGType := TGDBType.Create(
@ -898,7 +937,7 @@ var
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
end
else if Pos(' destructor ~', S) > 0
else if Pos(' destructor ~', S) > 0
then begin
Name := GetPart(['destructor ~'], [' ', ';'], S);
DBGType := TGDBType.Create(
@ -909,7 +948,7 @@ var
then Flags := [ffVirtual];
Include(Flags, ffDestructor);
end
else if Pos(' constructor ', S) > 0
else if Pos(' constructor ', S) > 0
then begin
Name := GetPart(['constructor '], [' ', ';'], S);
DBGType := TGDBType.Create(
@ -921,7 +960,7 @@ var
then Flags := [ffVirtual];
Include(Flags, ffConstructor);
end
else if Pos(' function ', S) > 0
else if Pos(' function ', S) > 0
then begin
Name := GetPart(['function '], [' ', ';'], S);
DBGType := TGDBType.Create(
@ -934,10 +973,22 @@ var
end
else begin
Name := GetPart([' '], [' '], S);
DBGType := TGDBType.Create(skSimple, GetPart([' : '], [';'], S));
S2 := GetPart([' : '], [';'], S);
if (lowercase(copy(S2, 1, 7)) = 'record ') then begin
i := 1;
while (n < Lines.Count - 2) and (i > 0) do
begin
inc(n);
S := Lines[n];
if S = '' then Continue;
if pos(': record ', S) > 0 then inc(i);
if pos(' end;', S) > 0 then dec(i);
S2 := S2 + ' ' + Trim(S);
end;
end;
DBGType := TGDBType.Create(skSimple, S2);
end;
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags));
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags, FTypeName));
end;
end;
end;
@ -949,18 +1000,60 @@ var
exit;
FKind := skPointer;
FTypeName := ClearAmpersand(PCLenToString(FReqResults[gptrWhatisExpr].Result.Name));
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr);
Result := True;
// ====> DONE
end;
procedure ProcessClassAncestor;
var
r: PGDBPTypeRequest;
i: Integer;
begin
FProcessState := gtpsClassAncestor;
If FTypeInfoAncestor = nil then begin
FTypeInfoAncestor := TGDBType.CreateForExpression(FAncestor, FCreationFlags + [gtcfExprIsType]);
end;
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;
end;
procedure ProcessClass;
var
t: TGDBTypeProcessRequest;
begin
FProcessState := gtpsClass;
if (gtcfExprIsType in FCreationFlags) then begin
SetTypNameFromReq(gptrPTypeExpr, True);
DoClass;
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
then ProcessClassAncestor
else Result := True; // ====> DONE
exit;
end;
if saRefParam in FAttributes
then t := gptrPTypeExprDeDeRef // &Class (var param; dwarf)
else t := gptrPTypeExprDeRef; // Class
@ -979,11 +1072,11 @@ var
else begin
// Handle Error in ptype^ as normal class
// May need a whatis, if aliased names are needed "type TFooAlias = type TFoo"
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr, True);
DoClass;
Result := True;
// ====> DONE
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
then ProcessClassAncestor
else Result := True; // ====> DONE
end;
end;
{%endregion * Class * }
@ -1002,19 +1095,20 @@ var
// Whatis result is ok
if (ptprfParamByRef in FReqResults[gptrWhatisExpr].Result.Flags) then
include(FAttributes, saRefParam);
FTypeName := ClearAmpersand(PCLenToString(FReqResults[gptrWhatisExpr].Result.Name));
SetTypNameFromReq(gptrWhatisExpr);
end
else begin
// Whatis result failed
FTypeName := ClearAmpersand((PCLenToString(FReqResults[gptrPTypeExpr].Result.Name)));
SetTypNameFromReq(gptrPTypeExpr);
end;
FInternalTypeName := FTypeName;
Result := True;
// ====> DONE
end;
{%endregion * Simple * }
procedure ProcessInitial;
var
i: Integer;
begin
if FReqResults[gptrPTypeExpr].Error <> '' then begin
FEvalError := True;
@ -1043,8 +1137,8 @@ var
if (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
and ( (FReqResults[gptrPTypeExpr].Result.Kind in
[ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
or (FClassIsPointer and (FReqResults[gptrPTypeExpr].Result.Kind in
[ptprkProcedure, ptprkFunction]) )
or ( (gtcfClassIsPointer in FCreationFlags)
and (FReqResults[gptrPTypeExpr].Result.Kind in [ptprkProcedure, ptprkFunction]) )
)
then begin
ProcessSimplePointer;
@ -1067,8 +1161,7 @@ var
and (ptprfPointer in FReqResults[gptrPTypeOfWhatis].Result.Flags) then begin
// pointer
FKind := skPointer;
FTypeName := ClearAmpersand(PCLenToString(FReqResults[gptrWhatisExpr].Result.Name));
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr);
Result := True;
// ====> DONE
exit;
@ -1086,25 +1179,20 @@ var
if not RequireRequests([gptrWhatisExpr])
then exit;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0) then
FTypeName := PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName)
else
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName; // There may be an alias?
SetTypNameFromReq(gptrWhatisExpr, True);
FKind := skSimple;
Result := True;
// ====> DONE
end;
ptprkRecord: begin
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName; // There may be an alias?
SetTypNameFromReq(gptrWhatisExpr, True);
DoRecord;
Result := True;
// ====> DONE
end;
ptprkEnum: begin
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName; //s There may be an alias?
SetTypNameFromReq(gptrWhatisExpr, True);
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
DoEnum;
Result := True;
// ====> DONE
@ -1113,11 +1201,11 @@ var
if not RequireRequests([gptrWhatisExpr])
then exit;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0) then
FTypeName := PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName)
else
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr, True);
// TODO: resolve enum-name (set of SomeEnum) if mode-full ?
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
i := pos('set of = ', FTypeDeclaration);
if i > 0 then delete(FTypeDeclaration, i+7, 3);
DoSet;
Result := True;
// ====> DONE
@ -1127,17 +1215,14 @@ var
then exit;
FKind := skSimple;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0) then
FTypeName := PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName)
else
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr, True);
FTypeDeclaration := ClearAmpersand(PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration));
Result := True;
// ====> DONE
end;
ptprkProcedure: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if FClassIsPointer // Dwarf
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
then begin
ProcessSimplePointer;
@ -1147,19 +1232,14 @@ var
if not RequireRequests([gptrWhatisExpr])
then exit;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0) then
FTypeName := PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName)
else
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
if FTypeName = '' then FTypeName := 'procedure';
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr, True, 'procedure');
DoProcedure;
Result := True;
// ====> DONE
end;
ptprkFunction: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if FClassIsPointer // Dwarf
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in FReqResults[gptrPTypeExpr].Result.Flags)
then begin
ProcessSimplePointer;
@ -1169,12 +1249,7 @@ var
if not RequireRequests([gptrWhatisExpr])
then exit;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0) then
FTypeName := PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName)
else
FTypeName := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
if FTypeName = '' then FTypeName := 'function';
FInternalTypeName := FTypeName;
SetTypNameFromReq(gptrWhatisExpr, True, 'function');
DoFunction;
Result := True;
// ====> DONE
@ -1185,6 +1260,7 @@ var
var
OldProcessState: TGDBTypeProcessState;
OldReqMade: TGDBTypeProcessRequests;
wi: TGDBTypeProcessRequests;
begin
Result := False;
FEvalRequest := nil;
@ -1192,7 +1268,12 @@ begin
OldProcessState := FProcessState;
OldReqMade := FProccesReuestsMade;
if not RequireRequests([gptrPTypeExpr])
if (gtcfFullTypeInfo in FCreationFlags)
and not (gtcfExprIsType in FCreationFlags)
then wi := [gptrWhatisExpr]
else wi := [];
if not RequireRequests([gptrPTypeExpr]+wi)
then exit;
case FProcessState of
@ -1200,9 +1281,13 @@ begin
gtpsSimplePointer: ProcessSimplePointer;
gtpsClass: ProcessClass;
gtpsClassPointer: ProcessClassPointer;
gtpsClassAncestor: ProcessClassAncestor;
end;
FreeAndNil(Lines);
if Result
then FProcessState := gtpsFinished;
if (FProcessState = OldProcessState) and (FProccesReuestsMade = OldReqMade)
and (not Result) and (FEvalRequest = nil)
then begin

6
debugger/inspectdlg.lfm
View File

@ -21,8 +21,8 @@ inherited IDEInspectDlg: TIDEInspectDlg
end
object PageControl: TPageControl[1]
Left = 0
Height = 363
Top = 21
Height = 361
Top = 23
Width = 295
ActivePage = DataPage
Align = alClient
@ -40,7 +40,7 @@ inherited IDEInspectDlg: TIDEInspectDlg
end
object EditInspected: TEdit[2]
Left = 0
Height = 21
Height = 23
Top = 0
Width = 295
Align = alTop

72
debugger/inspectdlg.pas
View File

@ -71,16 +71,20 @@ type
procedure InspectRecord;
procedure InspectVariant;
procedure InspectSimple;
procedure InspectEnum;
procedure InspectSet;
procedure InspectPointer;
procedure GridDataSetup;
procedure GridMethodsSetup;
procedure ShowDataFields;
procedure ShowMethodsFields;
procedure Clear;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Execute(const AExpression: ansistring);
procedure UpdateData;
end;
implementation
@ -170,6 +174,40 @@ begin
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.InspectEnum;
begin
DataPage.TabVisible:=true;
PropertiesPage.TabVisible:=false;
MethodsPage.TabVisible:=false;
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;
if (FDBGInfo.TypeName <> '') and (FDBGInfo.TypeDeclaration <> '')
then FGridData.Cells[1,1] := FGridData.Cells[1,1] + ' = ';
FGridData.Cells[1,1] := FGridData.Cells[1,1] + FDBGInfo.TypeDeclaration;
FGridData.Cells[2,1]:=FDBGInfo.Value.AsString;
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.InspectSet;
begin
DataPage.TabVisible:=true;
PropertiesPage.TabVisible:=false;
MethodsPage.TabVisible:=false;
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;
if (FDBGInfo.TypeName <> '') and (FDBGInfo.TypeDeclaration <> '')
then FGridData.Cells[1,1] := FGridData.Cells[1,1] + ' = ';
FGridData.Cells[1,1] := FGridData.Cells[1,1] + FDBGInfo.TypeDeclaration;
FGridData.Cells[2,1]:=FDBGInfo.Value.AsString;
FGridData.AutoSizeColumn(2);
end;
procedure TIDEInspectDlg.InspectPointer;
begin
DataPage.TabVisible:=true;
@ -347,6 +385,16 @@ begin
end;
end;
procedure TIDEInspectDlg.Clear;
begin
DataPage.TabVisible:=false;
PropertiesPage.TabVisible:=false;
MethodsPage.TabVisible:=false;
FGridData.Clear;
FreeAndNil(FDBGInfo);
EditInspected.Text:='';
end;
constructor TIDEInspectDlg.Create(AOwner: TComponent);
function NewGrid(AName: String; AParent: TWinControl; AHook: TPropertyEditorHook): TOIDBGGrid;
@ -393,22 +441,32 @@ end;
procedure TIDEInspectDlg.Execute(const AExpression: ansistring);
begin
FExpression:='';
FExpression:=AExpression;
UpdateData;
end;
procedure TIDEInspectDlg.UpdateData;
begin
FreeAndNil(FDBGInfo);
if not DebugBoss.Evaluate(AExpression,FHumanReadable,FDBGInfo) or not assigned(FDBGInfo) then
if FExpression = ''
then exit;
if not DebugBoss.Evaluate(FExpression, FHumanReadable, FDBGInfo, [defFullTypeInfo])
or not assigned(FDBGInfo) then
begin
FreeAndNil(FDBGInfo);
Clear;
EditInspected.Text:=FExpression + ' : unavailable';
Exit;
end;
FExpression:=AExpression;
case FDBGInfo.Kind of
skClass: InspectClass();
skRecord: InspectRecord();
skVariant: InspectVariant();
// skEnum: ;
// skSet: ;
// skProcedure: ;
// skFunction: ;
skEnum: InspectEnum;
skSet: InspectSet;
skProcedure: InspectSimple;
skFunction: InspectSimple;
skSimple: InspectSimple();
skPointer: InspectPointer();
// skDecomposable: ;

3
ide/basedebugmanager.pas
View File

@ -138,7 +138,8 @@ type
procedure EndDebugging; virtual; abstract;
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean; virtual; abstract; // Evaluates the given expression, returns true if valid
var ATypeInfo: TDBGType;
EvalFlags: TDBGEvaluateFlags = []): Boolean; virtual; abstract; // Evaluates the given expression, returns true if valid
function Modify(const AExpression: String; const ANewValue: String): Boolean; virtual; abstract; // Modify the given expression, returns true if valid
function GetFullFilename(var Filename: string; AskUserIfNotFound: Boolean): Boolean; virtual; abstract;

12
ide/debugmanager.pas
View File

@ -183,7 +183,8 @@ type
function RunDebugger: TModalResult; override; // waits till program ends
procedure EndDebugging; override;
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType): Boolean; override;
var ATypeInfo: TDBGType;
EvalFlags: TDBGEvaluateFlags = []): Boolean; override;
function Modify(const AExpression, ANewValue: String): Boolean; override;
procedure Inspect(const AExpression: String); override;
@ -1726,6 +1727,11 @@ begin
FBreakPoints[i].SetLocation(FBreakPoints[i].Source, FBreakPoints[i].Line);
end;
// update inspect
if (FDebugger.State in [dsPause]) and (OldState = dsRun)
and (FDialogs[ddtInspect] <> nil)
then TIDEInspectDlg(FDialogs[ddtInspect]).UpdateData;
case FDebugger.State of
dsError: begin
{$ifdef VerboseDebugger}
@ -2889,13 +2895,13 @@ begin
end;
function TDebugManager.Evaluate(const AExpression: String;
var AResult: String; var ATypeInfo: TDBGType): Boolean;
var AResult: String; var ATypeInfo: TDBGType;EvalFlags: TDBGEvaluateFlags = []): Boolean;
begin
Result := (not Destroying)
and (MainIDE.ToolStatus = itDebugger)
and (FDebugger <> nil)
and (dcEvaluate in FDebugger.Commands)
and FDebugger.Evaluate(AExpression, AResult, ATypeInfo)
and FDebugger.Evaluate(AExpression, AResult, ATypeInfo, EvalFlags)
end;
function TDebugManager.Modify(const AExpression, ANewValue: String): Boolean;