paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-26 22:23:49 +02:00
Code Issues Packages Projects Releases Wiki Activity
de7f2b3c91
lazarus/debugger/gdbmidebugger.pp
paul 55f665674a debugger: format output of generic pointer 
git-svn-id: trunk@23059 -
2009-12-10 08:07:17 +00:00

5767 lines
156 KiB
ObjectPascal
Raw Blame History

{ $Id$ }
{ ----------------------------------------------
GDBDebugger.pp - Debugger class forGDB
----------------------------------------------
@created(Wed Feb 23rd WET 2002)
@lastmod($Date$)
@author(Marc Weustink <marc@@lazarus.dommelstein.net>)
This unit contains debugger class for the GDB/MI debugger.
***************************************************************************
* *
* 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 GDBMIDebugger;
{$mode objfpc}
{$H+}
interface
uses
Classes, SysUtils, Variants, LCLProc, Dialogs, LazConf, DebugUtils, Debugger,
FileUtil, CmdLineDebugger, GDBTypeInfo, Maps,
{$IFdef MSWindows}
Windows,
{$ENDIF}
{$IFDEF UNIX}
Unix,BaseUnix,
{$ENDIF}
BaseDebugManager;
type
TGDBMIProgramInfo = record
State: TDBGState;
BreakPoint: Integer; // ID of Breakpoint hit
Signal: Integer; // Signal no if we hit one
SignalText: String; // Signal text if we hit one
end;
TGDBMICmdFlags = set of (
cfNoMiCommand, // the command is not a MI command
cfIgnoreState, // ignore the result state of the command
cfIgnoreError, // ignore errors
cfExternal // the command is a result from a user action
);
TGDBMIResultFlags = set of (
rfNoMI // flag is set if the output is not MI fomatted
// 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);
TGDBMITargetFlags = set of (
tfHasSymbols, // Debug symbols are present
tfRTLUsesRegCall, // the RTL is compiled with RegCall calling convention
tfClassIsPointer // with dwarf class names are pointer. with stabs they are not
);
TGDBMIDebuggerFlags = set of (
dfImplicidTypes // Debugger supports implicit types (^Type)
);
TGDBMIRTLCallingConvention = (ccDefault, ccRegCall, ccStdCall);
{ TGDBMIDebuggerProperties }
TGDBMIDebuggerProperties = class(TDebuggerProperties)
private
FGDBOptions: String;
FOverrideRTLCallingConvention: TGDBMIRTLCallingConvention;
public
constructor Create;
published
property OverrideRTLCallingConvention: TGDBMIRTLCallingConvention read FOverrideRTLCallingConvention write FOverrideRTLCallingConvention;
property Debugger_Startup_Options: String read FGDBOptions write FGDBOptions;
end;
{ TGDBMIDebugger }
TGDBMIDebugger = class(TCmdLineDebugger)
private
FCommandQueue: TStringList;
FMainAddr: TDbgPtr;
FBreakAtMain: TDBGBreakPoint;
FBreakErrorBreakID: Integer;
FRunErrorBreakID: Integer;
FExceptionBreakID: Integer;
FPauseWaitState: TGDBMIPauseWaitState;
FInExecuteCount: Integer;
FDebuggerFlags: TGDBMIDebuggerFlags;
FCurrentStackFrame: Integer;
FAsmCache: TTypedMap;
FAsmCacheIter: TTypedMapIterator;
FSourceNames: TStringList; // Objects[] -> TMap[Integer|Integer] -> TDbgPtr
// GDB info (move to ?)
FGDBVersion: String;
FGDBCPU: String;
FGDBOS: String;
// Target info (move to record ?)
FTargetPID: Integer;
FTargetFlags: TGDBMITargetFlags;
FTargetCPU: String;
FTargetOS: String;
FTargetRegisters: array[0..2] of String;
FTargetPtrSize: Byte; // size in bytes
FTargetIsBE: Boolean;
// 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 GDBRun: Boolean;
function GDBPause(const AInternal: Boolean): Boolean;
function GDBStop: Boolean;
function GDBStepOver: Boolean;
function GDBStepInto: Boolean;
function GDBRunTo(const ASource: String; const ALine: Integer): Boolean;
function GDBJumpTo(const ASource: String; const ALine: Integer): Boolean;
function GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr;
out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
function GDBSourceAdress(const ASource: String; ALine, AColumn: Integer; out AAddr: TDbgPtr): Boolean;
procedure CallStackSetCurrent(AIndex: Integer);
// ---
procedure ClearSourceInfo;
procedure GDBStopCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
function FindBreakpoint(const ABreakpoint: Integer): TDBGBreakPoint;
function GetClassName(const AClass: TDBGPtr): String; overload;
function GetClassName(const AExpression: String; const AValues: array of const): String; overload;
function GetFrame(const AIndex: Integer): String;
function GetInstanceClassName(const AInstance: TDBGPtr): String; overload;
function GetInstanceClassName(const AExpression: String; const AValues: array of const): String; overload;
function GetText(const ALocation: TDBGPtr): String; overload;
function GetText(const AExpression: String; const AValues: array of const): String; overload;
function GetWideText(const ALocation: TDBGPtr): String;
function GetData(const ALocation: TDbgPtr): TDbgPtr; overload;
function GetData(const AExpression: String; const AValues: array of const): TDbgPtr; overload;
function GetStrValue(const AExpression: String; const AValues: array of const): String;
function GetIntValue(const AExpression: String; const AValues: array of const): Integer;
function GetPtrValue(const AExpression: String; const AValues: array of const): TDbgPtr;
function GetGDBTypeInfo(const AExpression: String): TGDBType;
function ProcessResult(var AResult: TGDBMIExecResult): Boolean;
function ProcessRunning(var AStoppedParams: String): Boolean;
function ProcessStopped(const AParams: String; const AIgnoreSigIntState: Boolean): Boolean;
procedure ProcessFrame(const AFrame: String = '');
procedure SelectStackFrame(AIndex: Integer);
// All ExecuteCommand functions are wrappers for the real (full) implementation
// ExecuteCommandFull is never called directly
function ExecuteCommand(const ACommand: String; const AFlags: TGDBMICmdFlags): Boolean; overload;
function ExecuteCommand(const ACommand: String; const AFlags: TGDBMICmdFlags; const ACallback: TGDBMICallback; const ATag: PtrInt): Boolean; overload;
function ExecuteCommand(const ACommand: String; const AFlags: TGDBMICmdFlags; var AResult: TGDBMIExecResult): Boolean; overload;
function ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICmdFlags): Boolean; overload;
function ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICmdFlags; const ACallback: TGDBMICallback; const ATag: PtrInt): Boolean; overload;
function ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICmdFlags; var AResult: TGDBMIExecResult): Boolean; overload;
function ExecuteCommandFull(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICmdFlags; const ACallback: TGDBMICallback; const ATag: PtrInt; var AResult: TGDBMIExecResult): Boolean; overload;
function StartDebugging(const AContinueCommand: String): Boolean;
protected
function ChangeFileName: Boolean; override;
function CreateBreakPoints: TDBGBreakPoints; override;
function CreateLocals: TDBGLocals; override;
function CreateLineInfo: TDBGLineInfo; override;
function CreateRegisters: TDBGRegisters; override;
function CreateCallStack: TDBGCallStack; override;
function CreateWatches: TDBGWatches; override;
function GetSupportedCommands: TDBGCommands; override;
function GetTargetWidth: Byte; override;
procedure InterruptTarget; virtual;
{$IFdef MSWindows}
procedure InterruptTargetCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt); virtual;
{$ENDIF}
function ParseInitialization: Boolean; virtual;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
procedure ClearCommandQueue;
procedure DoState(const OldState: TDBGState); override;
property TargetPID: Integer read FTargetPID;
public
class function CreateProperties: TDebuggerProperties; override; // Creates debuggerproperties
class function Caption: String; override;
class function ExePaths: String; override;
constructor Create(const AExternalDebugger: String); override;
destructor Destroy; override;
procedure Init; override; // Initializes external debugger
procedure Done; override; // Kills external debugger
// internal testing
procedure TestCmd(const ACommand: String); override;
end;
implementation
type
TGDBMIAsmLine = record
Dump: String;
Statement: String;
FileName: String;
Line: Integer;
FuncName: String;
Offset: Integer;
Next: TDbgPtr;
end;
PGDBMIDisasm = ^TGDBMIDisasm;
TGDBMIDisasm = record
FileName: String;
Line: Integer;
Address: TDbgPtr;
Statement: String;
FuncName: String;
Offset: Integer;
end;
PGDBMINameValue = ^TGDBMINameValue;
TGDBMINameValue = record
NamePtr: PChar;
NameLen: Integer;
ValuePtr: PChar;
ValueLen: Integer;
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;
public
constructor Create(const AResultValues: String);
constructor Create(AResult: TGDBMIExecResult);
constructor Create(const AResultValues: String; const APath: array of String);
constructor Create(AResult: TGDBMIExecResult; const APath: array of String);
procedure Delete(AIndex: Integer);
procedure Init(const AResultValues: String);
procedure Init(AResultValues: PChar; ALength: Integer);
procedure SetPath(const APath: String); overload;
procedure SetPath(const APath: array of String); overload;
property Count: Integer read FCount;
property Items[const AIndex: Integer]: PGDBMINameValue read GetItem;
property Values[const AName: string]: string read GetValue;
property UseTrim: Boolean read FUseTrim write FUseTrim;
end;
TGDBMIBreakPoint = class(TDBGBreakPoint)
private
FBreakID: Integer;
procedure SetBreakPointCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
procedure SetBreakPoint;
procedure ReleaseBreakPoint;
procedure UpdateEnable;
procedure UpdateExpression;
protected
procedure DoEnableChange; override;
procedure DoExpressionChange; override;
procedure DoStateChange(const AOldState: TDBGState); override;
public
constructor Create(ACollection: TCollection); override;
destructor Destroy; override;
procedure SetLocation(const ASource: String; const ALine: Integer); override;
end;
{ TGDBMILocals }
TGDBMILocals = class(TDBGLocals)
private
FLocals: TStringList;
FLocalsValid: Boolean;
procedure LocalsNeeded;
procedure AddLocals(const AParams:String);
protected
procedure DoStateChange(const AOldState: TDBGState); override;
procedure Invalidate;
function GetCount: Integer; override;
function GetName(const AnIndex: Integer): String; override;
function GetValue(const AnIndex: Integer): String; override;
public
procedure Changed; override;
constructor Create(const ADebugger: TDebugger);
destructor Destroy; override;
end;
{ TGDBMILineInfo }
TGDBMIAddressReqInfo = record
Source: String;
Trial: Byte;
end;
PGDBMIAddressReqInfo = ^TGDBMIAddressReqInfo;
TGDBMILineInfo = class(TDBGLineInfo)
private
FSourceIndex: TStringList;
FSourceMaps: array of record
Source: String;
Map: TMap;
end;
procedure ClearSources;
procedure SymbolListCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
procedure AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
protected
function GetSource(const AIndex: integer): String; override;
procedure DoStateChange(const AOldState: TDBGState); override;
public
constructor Create(const ADebugger: TDebugger);
destructor Destroy; override;
function Count: Integer; override;
function GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr; override;
function GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean; override;
function IndexOf(const ASource: String): integer; override;
procedure Request(const ASource: String); override;
end;
{ TGDBMIRegisters }
TGDBMIRegisters = class(TDBGRegisters)
private
FRegisters: array of record
Name: String;
Value: String;
Modified: Boolean;
end;
FRegistersValid: Boolean;
FValuesValid: Boolean;
procedure RegistersNeeded;
procedure ValuesNeeded;
protected
procedure DoStateChange(const AOldState: TDBGState); override;
procedure Invalidate;
function GetCount: Integer; override;
function GetModified(const AnIndex: Integer): Boolean; override;
function GetName(const AnIndex: Integer): String; override;
function GetValue(const AnIndex: Integer): String; override;
public
procedure Changed; override;
end;
{ TGDBMIWatch }
TGDBMIWatch = class(TDBGWatch)
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;
{ TGDBMIWatches }
TGDBMIWatches = class(TDBGWatches)
private
protected
procedure Changed;
public
end;
{ TGDBMICallStack }
TGDBMICallStack = class(TDBGCallStack)
private
function InternalCreateEntry(AIndex: Integer; AArgInfo, AFrameInfo: TGDBMINameValueList): TCallStackEntry;
protected
function CheckCount: Boolean; override;
function CreateStackEntry(AIndex: Integer): TCallStackEntry; override;
procedure PrepareEntries(AIndex, ACount: Integer); override;
function GetCurrent: TCallStackEntry; override;
procedure SetCurrent(AValue: TCallStackEntry); override;
public
end;
{ TGDBMIExpression }
// TGDBMIExpression was an attempt to make expression evaluation on Objects possible for GDB <= 5.2
// It is not completed and buggy. Since 5.3 expression evaluation is OK, so maybe in future the
// TGDBMIExpression will be completed to support older gdb versions
TDBGExpressionOperator = (
eoNone,
eoNegate,
eoPlus,
eoSubstract,
eoAdd,
eoMultiply,
eoPower,
eoDivide,
eoDereference,
eoAddress,
eoEqual,
eoLess,
eoLessOrEqual,
eoGreater,
eoGreaterOrEqual,
eoNotEqual,
eoIn,
eoIs,
eoAs,
eoDot,
eoComma,
eoBracket,
eoIndex,
eoClose,
eoAnd,
eoOr,
eoMod,
eoNot,
eoDiv,
eoXor,
eoShl,
eoShr
);
const
OPER_LEVEL: array[TDBGExpressionOperator] of Byte = (
{eoNone } 0,
{eoNegate } 5,
{eoPlus } 5,
{eoSubstract } 7,
{eoAdd } 7,
{eoMultiply } 6,
{eoPower } 4,
{eoDivide } 6,
{eoDereference } 2,
{eoAddress } 4,
{eoEqual } 8,
{eoLess } 8,
{eoLessOrEqual } 8,
{eoGreater } 8,
{eoGreaterOrEqual } 8,
{eoNotEqual } 8,
{eoIn } 8,
{eoIs } 8,
{eoAs } 6,
{eoDot } 2,
{eoComma } 9,
{eoBracket } 1,
{eoIndex } 3,
{eoClose } 9,
{eoAnd } 6,
{eoOr } 7,
{eoMod } 6,
{eoNot } 5,
{eoDiv } 6,
{eoXor } 7,
{eoShl } 6,
{eoShr } 6
);
type
PGDBMISubExpression = ^TGDBMISubExpression;
TGDBMISubExpression = record
Opertor: TDBGExpressionOperator;
Operand: String;
Next, Prev: PGDBMISubExpression;
end;
PGDBMIExpressionResult = ^TGDBMIExpressionResult;
TGDBMIExpressionResult = record
Opertor: TDBGExpressionOperator;
// Operand: String;
Value: String;
Info: TGDBType;
Next, Prev: PGDBMIExpressionResult;
end;
TGDBMIExpression = class(TObject)
private
FList: PGDBMISubExpression;
FStack: PGDBMIExpressionResult;
FStackPtr: PGDBMIExpressionResult;
procedure Push(var AResult: PGDBMIExpressionResult);
procedure Pop(var AResult: PGDBMIExpressionResult);
procedure DisposeList(AList: PGDBMIExpressionResult);
function Solve(const ADebugger: TGDBMIDebugger; ALimit: Byte; const ARight: String; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveAddress(const ADebugger: TGDBMIDebugger; ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveMath(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveIn(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveIs(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveAs(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveDeref(const ADebugger: TGDBMIDebugger; ALeft: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
function SolveDot(const ADebugger: TGDBMIDebugger; ALeft: PGDBMIExpressionResult; const ARight: String; out AVAlue: String; out AInfo: TGDBType): Boolean;
protected
function Evaluate(const ADebugger: TGDBMIDebugger; const AText: String; out AResult: String; out AResultInfo: TGDBType): Boolean;
public
constructor Create(const AExpression: String);
destructor Destroy; override;
function DumpExpression: String;
function Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String; out AResultInfo: TGDBType): Boolean;
end;
{ TGDBMIType }
TGDBMIType = class(TGDBType)
private
protected
public
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
Flags: TGDBMICmdFlags;
CallBack: TGDBMICallback;
Tag: PtrInt;
end;
TGDBMIExceptionInfo = record
ObjAddr: String;
Name: String;
end;
{ TGDBMILineInfo }
procedure TGDBMILineInfo.ClearSources;
var
n: Integer;
begin
for n := Low(FSourceMaps) to High(FSourceMaps) do
FSourceMaps[n].Map.Free;
Setlength(FSourceMaps, 0);
for n := 0 to FSourceIndex.Count - 1 do
DoChange(FSourceIndex[n]);
FSourceIndex.Clear;
end;
procedure TGDBMILineInfo.SymbolListCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
var
Info: PGDBMIAddressReqInfo absolute ATag;
Source: String;
begin
if AResult.State <> dsError
then begin
AddInfo(Info^.Source, AResult);
Dispose(Info);
Exit;
end;
if Info^.Trial > 1
then begin
Dispose(Info);
Exit;
end;
Source := ExtractFileName(Info^.Source);
if Source = Info^.Source
then begin
Dispose(Info);
Exit;
end;
// the second trial: gdb can return info to file w/o path
if Debugger.State = dsRun
then TGDBMIDebugger(Debugger).GDBPause(True);
Inc(Info^.Trial);
TGDBMIDebugger(Debugger).ExecuteCommand('-symbol-list-lines %s', [Source], [cfIgnoreError], @SymbolListCallback, ATag);
end;
procedure TGDBMILineInfo.AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
var
ID: packed record
Line, Column: Integer;
end;
Map: TMap;
n, idx: Integer;
LinesList, LineList: TGDBMINameValueList;
Item: PGDBMINameValue;
Addr: TDbgPtr;
begin
n := FSourceIndex.IndexOf(ASource);
if n = -1
then begin
idx := Length(FSourceMaps);
SetLength(FSourceMaps, idx+1);
FSourceMaps[idx].Map := nil;
FSourceMaps[idx].Source := ASource;
n := FSourceIndex.AddObject(ASource, TObject(PtrInt(idx)));
end
else idx := PtrInt(FSourceIndex.Objects[n]);
LinesList := TGDBMINameValueList.Create(AResult, ['lines']);
if LinesList = nil then Exit;
Map := FSourceMaps[idx].Map;
if Map = nil
then begin
// no map present
Map := TMap.Create(its8, SizeOf(TDBGPtr));
FSourceMaps[idx].Map := Map;
end;
ID.Column := 0;
LineList := TGDBMINameValueList.Create('');
for n := 0 to LinesList.Count - 1 do
begin
Item := LinesList.Items[n];
LineList.Init(Item^.NamePtr, Item^.NameLen);
if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
// one line can have more than one address
if Map.HasId(ID) then Continue;
Map.Add(ID, Addr);
end;
LineList.Free;
LinesList.Free;
DoChange(ASource);
end;
function TGDBMILineInfo.Count: Integer;
begin
Result := FSourceIndex.Count;
end;
function TGDBMILineInfo.GetSource(const AIndex: integer): String;
begin
if AIndex < Low(FSourceMaps) then Exit('');
if AIndex > High(FSourceMaps) then Exit('');
Result := FSourceMaps[AIndex].Source;
end;
function TGDBMILineInfo.GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr;
var
ID: packed record
Line, Column: Integer;
end;
Map: TMap;
begin
if AIndex < Low(FSourceMaps) then Exit(0);
if AIndex > High(FSourceMaps) then Exit(0);
Map := FSourceMaps[AIndex].Map;
if Map = nil then Exit(0);
ID.Line := ALine;
// since we dont have column info we map all on column 0
// ID.Column := AColumn;
ID.Column := 0;
if (Map = nil) then Exit(0);
if not Map.GetData(ID, Result) then
Result := 0;
end;
function TGDBMILineInfo.GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean;
begin
Result := False;
end;
procedure TGDBMILineInfo.DoStateChange(const AOldState: TDBGState);
begin
if not (Debugger.State in [dsPause, dsRun]) then
ClearSources;
end;
function TGDBMILineInfo.IndexOf(const ASource: String): integer;
begin
Result := FSourceIndex.IndexOf(ASource);
if Result <> -1
then Result := PtrInt(FSourceIndex.Objects[Result]);
end;
constructor TGDBMILineInfo.Create(const ADebugger: TDebugger);
begin
FSourceIndex := TStringList.Create;
FSourceIndex.Sorted := True;
FSourceIndex.Duplicates := dupError;
FSourceIndex.CaseSensitive := False;
inherited;
end;
destructor TGDBMILineInfo.Destroy;
begin
ClearSources;
FreeAndNil(FSourceIndex);
inherited Destroy;
end;
procedure TGDBMILineInfo.Request(const ASource: String);
var
Info: PGDBMIAddressReqInfo;
idx: Integer;
begin
if ASource = '' then Exit; // we cannot request when source file name is empty
if Debugger = nil then Exit;
idx := IndexOf(ASource);
if (idx <> -1) and (FSourceMaps[idx].Map <> nil) then Exit; // already present
if Debugger.State = dsRun
then TGDBMIDebugger(Debugger).GDBPause(True);
New(Info);
Info^.Source := ASource;
Info^.Trial := 1;
TGDBMIDebugger(Debugger).ExecuteCommand('-symbol-list-lines %s', [ASource], [cfIgnoreError], @SymbolListCallback, PtrInt(Info));
end;
{ TGDBMINameValueList }
constructor TGDBMINameValueList.Create(const AResultValues: String);
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, len: Integer;
begin
if FCount = 0 then Exit(nil);
len := Length(AName);
Result := @FIndex[0];
for n := 0 to FCount - 1 do
begin
if (Result^.NameLen = len)
and (strlcomp(Result^.NamePtr, PChar(AName), len) = 0)
then Exit;
Inc(Result);
end;
Result := nil;
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^.NameLen;
if Item^.ValuePtr <> nil then begin
if (Item^.ValuePtr-1) = '"' then inc(len, 2);
len := len + 1 + Item^.ValueLen;
end;
SetLength(Result, len);
Move(Item^.NamePtr^, 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^.ValueLen);
Move(Item^.ValuePtr^, Result[1], Item^.ValueLen);
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^.NamePtr := AStartPtr;
Item^.NameLen := PtrUInt(AEndPtr) - PtrUInt(AStartPtr) + 1;
Item^.ValuePtr := nil;
Item^.ValueLen := 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^.NamePtr := AStartPtr;
Item^.NameLen := PtrUInt(AEquPtr) - PtrUInt(AStartPtr);
// trim name spaces
if UseTrim then
while (Item^.NameLen > 0) and (Item^.NamePtr[Item^.NameLen - 1] = #32) do
dec(Item^.NameLen);
if (AEquPtr < AEndPtr - 1) and (AEquPtr[1] = '"') and (AEndPtr^ = '"')
then begin
// strip surrounding "
Item^.ValuePtr := AEquPtr + 2;
Item^.ValueLen := PtrUInt(AEndPtr) - PtrUInt(AEquPtr) - 2;
end
else begin
Item^.ValuePtr := AEquPtr + 1;
Item^.ValueLen := PtrUInt(AEndPtr) - PtrUInt(AEquPtr)
end;
// trim value spaces
if UseTrim then
while (Item^.ValueLen > 0) and (Item^.ValuePtr[0] = #32) do
begin
inc(Item^.ValuePtr);
dec(Item^.ValueLen);
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: 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^.ValuePtr, Item^.ValueLen);
end;
end;
{ =========================================================================== }
{ Some win32 stuff }
{ =========================================================================== }
{$IFdef MSWindows}
var
DebugBreakAddr: Pointer = nil;
// use our own version. Win9x doesn't support this, so it is a nice check
_CreateRemoteThread: function(hProcess: THandle; lpThreadAttributes: Pointer; dwStackSize: DWORD; lpStartAddress: TFNThreadStartRoutine; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall = nil;
procedure InitWin32;
var
hMod: THandle;
begin
// Check if we already are initialized
if DebugBreakAddr <> nil then Exit;
// normally you would load a lib, but since kernel32 is
// always loaded we can use this (and we don't have to free it
hMod := GetModuleHandle(kernel32);
if hMod = 0 then Exit; //????
DebugBreakAddr := GetProcAddress(hMod, 'DebugBreak');
Pointer(_CreateRemoteThread) := GetProcAddress(hMod, 'CreateRemoteThread');
end;
{$ENDIF}
{ =========================================================================== }
{ Helpers }
{ =========================================================================== }
function ConvertToGDBPath(APath: string): string;
// GDB wants forward slashes in its filenames, even on win32.
begin
Result := APath;
// no need to process empty filename
if Result='' then exit;
{$WARNINGS off}
if DirectorySeparator <> '/' then
Result := StringReplace(Result, DirectorySeparator, '/', [rfReplaceAll]);
{$WARNINGS on}
Result := '"' + Result + '"';
end;
{ =========================================================================== }
{ TGDBMIDebuggerProperties }
{ =========================================================================== }
constructor TGDBMIDebuggerProperties.Create;
begin
FOverrideRTLCallingConvention := ccDefault;
inherited;
end;
{ =========================================================================== }
{ TGDBMIDebugger }
{ =========================================================================== }
procedure TGDBMIDebugger.CallStackSetCurrent(AIndex: Integer);
begin
if FCurrentStackFrame = AIndex then Exit;
FCurrentStackFrame := AIndex;
SelectStackFrame(FCurrentStackFrame);
TGDBMICallstack(CallStack).CurrentChanged;
TGDBMILocals(Locals).Changed;
TGDBMIWatches(Watches).Changed;
end;
class function TGDBMIDebugger.Caption: String;
begin
Result := 'GNU debugger (gdb)';
end;
function TGDBMIDebugger.ChangeFileName: Boolean;
procedure ClearBreakpoint(var ABreakID: Integer);
begin
if ABreakID = -1 then Exit;
ExecuteCommand('-break-delete %d', [ABreakID], [cfIgnoreError]);
ABreakID := -1;
end;
var
S: String;
R: TGDBMIExecResult;
List: TGDBMINameValueList;
begin
Result := False;
//Cleanup our own breakpoints
ClearBreakpoint(FExceptionBreakID);
ClearBreakpoint(FBreakErrorBreakID);
ClearBreakpoint(FRunErrorBreakID);
S := ConvertToGDBPath(UTF8ToSys(FileName));
if not ExecuteCommand('-file-exec-and-symbols %s', [S], [cfIgnoreError], R) then Exit;
if (R.State = dsError)
and (FileName <> '')
then begin
List := TGDBMINameValueList.Create(R);
MessageDlg('Debugger', Format('Failed to load file: %s', [DeleteEscapeChars((List.Values['msg']))]), mtError, [mbOK], 0);
List.Free;
SetState(dsStop);
Exit;
end;
if not (inherited ChangeFileName) then Exit;
if State = dsError then Exit;
if FileName = ''
then begin
Result := True;
Exit;
end;
if tfHasSymbols in FTargetFlags
then begin
// Force setting language
// Setting extensions dumps GDB (bug #508)
if not ExecuteCommand('-gdb-set language pascal', []) then exit;
if State=dsError then exit;
(*
ExecuteCommand('-gdb-set extension-language .lpr pascal', False);
if not FHasSymbols then Exit; // file-exec-and-symbols not allways result in no symbols
ExecuteCommand('-gdb-set extension-language .lrs pascal', False);
ExecuteCommand('-gdb-set extension-language .dpr pascal', False);
ExecuteCommand('-gdb-set extension-language .pas pascal', False);
ExecuteCommand('-gdb-set extension-language .pp pascal', False);
ExecuteCommand('-gdb-set extension-language .inc pascal', False);
*)
end;
Result:=true;
end;
constructor TGDBMIDebugger.Create(const AExternalDebugger: String);
begin
FBreakErrorBreakID := -1;
FRunErrorBreakID := -1;
FExceptionBreakID := -1;
FCommandQueue := TStringList.Create;
FTargetPID := 0;
FTargetFlags := [];
FDebuggerFlags := [];
FAsmCache := TTypedMap.Create(itu8, TypeInfo(TGDBMIAsmLine));
FAsmCacheIter := TTypedMapIterator.Create(FAsmCache);
FSourceNames := TStringList.Create;
FSourceNames.Sorted := True;
FSourceNames.Duplicates := dupError;
FSourceNames.CaseSensitive := False;
{$IFdef MSWindows}
InitWin32;
{$ENDIF}
inherited;
end;
function TGDBMIDebugger.CreateBreakPoints: TDBGBreakPoints;
begin
Result := TDBGBreakPoints.Create(Self, TGDBMIBreakPoint);
end;
function TGDBMIDebugger.CreateCallStack: TDBGCallStack;
begin
Result := TGDBMICallStack.Create(Self);
end;
function TGDBMIDebugger.CreateLocals: TDBGLocals;
begin
Result := TGDBMILocals.Create(Self);
end;
function TGDBMIDebugger.CreateLineInfo: TDBGLineInfo;
begin
Result := TGDBMILineInfo.Create(Self);
end;
class function TGDBMIDebugger.CreateProperties: TDebuggerProperties;
begin
Result := TGDBMIDebuggerProperties.Create;
end;
function TGDBMIDebugger.CreateRegisters: TDBGRegisters;
begin
Result := TGDBMIRegisters.Create(Self);
end;
function TGDBMIDebugger.CreateWatches: TDBGWatches;
begin
Result := TGDBMIWatches.Create(Self, TGDBMIWatch);
end;
destructor TGDBMIDebugger.Destroy;
begin
inherited;
ClearCommandQueue;
FreeAndNil(FCommandQueue);
FreeAndNil(FAsmCacheIter);
FreeAndNil(FAsmCache);
ClearSourceInfo;
FreeAndNil(FSourceNames);
end;
procedure TGDBMIDebugger.Done;
begin
if State = dsRun then GDBPause(True);
ExecuteCommand('-gdb-exit', []);
inherited Done;
end;
procedure TGDBMIDebugger.DoState(const OldState: TDBGState);
begin
if State in [dsStop, dsError]
then begin
FAsmCache.Clear;
ClearSourceInfo;
FPauseWaitState := pwsNone;
end;
inherited DoState(OldState);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
const AFlags: TGDBMICmdFlags): Boolean;
var
R: TGDBMIExecResult;
begin
Result := ExecuteCommandFull(ACommand, [], AFlags, nil, 0, R);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
const AFlags: TGDBMICmdFlags; const ACallback: TGDBMICallback; const ATag: PtrInt): Boolean;
var
R: TGDBMIExecResult;
begin
Result := ExecuteCommandFull(ACommand, [], AFlags, ACallback, ATag, R);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String; const AFlags: TGDBMICmdFlags;
var AResult: TGDBMIExecResult): Boolean;
begin
Result := ExecuteCommandFull(ACommand, [], AFlags, nil, 0, AResult);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
const AValues: array of const; const AFlags: TGDBMICmdFlags): Boolean;
var
R: TGDBMIExecResult;
begin
Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, R);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
const AValues: array of const; const AFlags: TGDBMICmdFlags;
const ACallback: TGDBMICallback; const ATag: PtrInt): Boolean;
var
R: TGDBMIExecResult;
begin
Result := ExecuteCommandFull(ACommand, AValues, AFlags, ACallback, ATag, R);
end;
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
const AValues: array of const; const AFlags: TGDBMICmdFlags;
var AResult: TGDBMIExecResult): Boolean;
begin
Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, AResult);
end;
function TGDBMIDebugger.ExecuteCommandFull(const ACommand: String;
const AValues: array of const; const AFlags: TGDBMICmdFlags;
const ACallback: TGDBMICallback; const ATag: PtrInt;
var AResult: TGDBMIExecResult): Boolean;
var
Cmd: String;
CmdInfo: PGDBMICmdInfo;
R, FirstCmd: Boolean;
StoppedParams: String;
ExecResult: TGDBMIExecResult;
begin
Result := False; // Assume queued
AResult.Values := '';
AResult.State := dsNone;
AResult.Flags := [];
New(CmdInfo);
CmdInfo^.Flags := AFlags;
CmdInfo^.Callback := ACallBack;
CmdInfo^.Tag := ATag;
FCommandQueue.AddObject(Format(ACommand, AValues), TObject(CmdInfo));
if FCommandQueue.Count > 1
then begin
if cfExternal in AFlags
then DebugLn('[WARNING] Debugger: Execution of external command "', ACommand, '" while queue exists');
Exit;
end;
// If we are here we can process the command directly
Result := True;
FirstCmd := True;
repeat
Inc(FInExecuteCount);
try
ExecResult.Values := '';
ExecResult.State := dsNone;
ExecResult.Flags := [];
Cmd := FCommandQueue[0];
CmdInfo := PGDBMICmdInfo(FCommandQueue.Objects[0]);
SendCmdLn(Cmd);
R := ProcessResult(ExecResult);
if not R
then begin
DebugLn('[WARNING] TGDBMIDebugger: ExecuteCommand "',Cmd,'" failed.');
SetState(dsError);
Break;
end;
if (ExecResult.State <> dsNone)
and not (cfIgnoreState in CmdInfo^.Flags)
and ((ExecResult.State <> dsError) or not (cfIgnoreError in CmdInfo^.Flags))
then SetState(ExecResult.State);
StoppedParams := '';
if ExecResult.State = dsRun
then R := ProcessRunning(StoppedParams);
// Delete command first to allow GDB access while processing stopped
FCommandQueue.Delete(0);
try
if StoppedParams <> ''
then ProcessStopped(StoppedParams, FPauseWaitState = pwsInternal);
if Assigned(CmdInfo^.Callback)
then CmdInfo^.Callback(ExecResult, CmdInfo^.Tag);
finally
Dispose(CmdInfo);
end;
if FirstCmd
then begin
FirstCmd := False;
AResult := ExecResult;
end;
finally
Dec(FInExecuteCount);
end;
if FCommandQueue.Count = 0
then begin
if (FInExecuteCount = 0)
and (FPauseWaitState = pwsInternal)
and (State = dsRun)
then begin
// reset state
FPauseWaitState := pwsNone;
// insert continue command
New(CmdInfo);
CmdInfo^.Flags := [];
CmdInfo^.Callback := nil;
FCommandQueue.AddObject('-exec-continue', TObject(CmdInfo));
end
else Break;
end;
until not R;
end;
class function TGDBMIDebugger.ExePaths: String;
begin
Result := '/usr/bin/gdb;/usr/local/bin/gdb;/opt/fpc/gdb';
end;
function TGDBMIDebugger.FindBreakpoint(
const ABreakpoint: Integer): TDBGBreakPoint;
var
n: Integer;
begin
if ABreakpoint > 0
then
for n := 0 to Breakpoints.Count - 1 do
begin
Result := Breakpoints[n];
if TGDBMIBreakPoint(Result).FBreakID = ABreakpoint
then Exit;
end;
Result := nil;
end;
function TGDBMIDebugger.GetClassName(const AClass: TDBGPtr): String;
var
S: String;
begin
// format has a problem with %u, so use Str for it
Str(AClass, S);
Result := GetClassName(S, []);
end;
function TGDBMIDebugger.GetClassName(const AExpression: String; const AValues: array of const): String;
var
OK: Boolean;
S: String;
R: TGDBMIExecResult;
ResultList: TGDBMINameValueList;
begin
Result := '';
if dfImplicidTypes in FDebuggerFlags
then begin
S := Format(AExpression, AValues);
OK := ExecuteCommand(
'-data-evaluate-expression ^^shortstring(%s+%d)^^',
[S, FTargetPtrSize * 3], [cfIgnoreError], R);
end
else begin
Str(TDbgPtr(GetData(AExpression + '+12', AValues)), S);
OK := ExecuteCommand('-data-evaluate-expression pshortstring(%s)^',
[S], [cfIgnoreError], R);
end;
if OK
then begin
ResultList := TGDBMINameValueList.Create(R);
S := DeleteEscapeChars(ResultList.Values['value']);
Result := GetPart('''', '''', S);
ResultList.Free;
end;
end;
function TGDBMIDebugger.GetInstanceClassName(const AInstance: TDBGPtr): String;
var
S: String;
begin
Str(AInstance, S);
Result := GetInstanceClassName(S, []);
end;
function TGDBMIDebugger.GetInstanceClassName(const AExpression: String; const AValues: array of const): String;
begin
if dfImplicidTypes in FDebuggerFlags
then begin
Result := GetClassName('^pointer(' + AExpression + ')^', AValues);
end
else begin
Result := GetClassName(GetData(AExpression, AValues));
end;
end;
function PosSetEx(const ASubStrSet, AString: string;
const Offset: integer): integer;
begin
for Result := Offset to Length(AString) do
if Pos(AString[Result], ASubStrSet) > 0 then
exit;
Result := 0;
end;
function EscapeGDBCommand(const AInput: string): string;
var
lPiece: string;
I, lPos, len: integer;
begin
lPos := 1;
Result := '';
repeat
I := PosSetEx(#9#10#13, AInput, lPos);
{ copy unmatched characters }
if I > 0 then
len := I-lPos
else
len := Length(AInput)+1-lPos;
Result := Result + Copy(AInput, lPos, len);
{ replace a matched character or be done }
if I > 0 then
begin
case AInput[I] of
#9: lPiece := '\t';
#10: lPiece := '\n';
#13: lPiece := '\r';
else
lPiece := '';
end;
Result := Result + lPiece;
lPos := I+1;
end else
exit;
until false;
end;
function DisasmSortCompare(AItem1, AItem2: Pointer): Integer;
begin
Result := PGDBMIDisasm(AItem1)^.Address - PGDBMIDisasm(AItem2)^.Address;
end;
function TGDBMIDebugger.GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
var
DumpList, InstList: TGDBMINameValueList;
procedure AddAsmLine(ACurAddr: TDbgPtr; var AAsmLine: TGDBMIAsmLine);
procedure GetAsmLineDump;
var
count: Cardinal;
R: TGDBMIExecResult;
S: String;
n: Integer;
Item: PGDBMINameValue;
begin
AAsmLine.Dump := '';
// check for cornercase when memory cycles
Count := AAsmLine.Next - ACurAddr;
if Count > 32 then Exit;
// retrieve instuction bytes
ExecuteCommand('-data-read-memory %u x 1 1 %u', [ACurAddr, Count], [cfIgnoreError, cfExternal], R);
if R.State = dsError then Exit;
DumpList.Init(R.Values);
DumpList.SetPath(['memory']);
if DumpList.Count = 0 then Exit;
S := '';
// get first (and only) memory part
Item := DumpList.Items[0];
DumpList.Init(Item^.NamePtr, Item^.NameLen);
// get data
DumpList.SetPath(['data']);
// now loop through elements
for n := 0 to DumpList.Count - 1 do
begin
S := S + Copy(DumpList.GetString(n), 4, 2);
end;
AAsmLine.Dump := S;
end;
procedure DoCacheAndResult;
begin
if FAsmCache.HasId(ACurAddr)
then FAsmCache.SetData(ACurAddr, AAsmLine)
else FAsmCache.Add(ACurAddr, AAsmLine);
if (ABackward and (AAsmLine.Next = AAddr))
or (not ABackward and (ACurAddr = AAddr))
then begin
if ABackward
then ANextAddr := ACurAddr
else ANextAddr := AAsmLine.Next;
ADump := AAsmLine.Dump;
AStatement := AAsmLine.Statement;
AFile := AAsmLine.FileName;
ALine := AAsmLine.Line;
Result := True;
end;
end;
var
AddrStop: TDbgPtr;
begin
if (Length(AAsmLine.FuncName) > 9)
and (CompareChar(AAsmLine.FuncName[1], 'DEBUGEND_', 9) = 0)
then begin
// some piece of dead code bytes, add one by one
AAsmLine.FuncName := '';
AAsmLine.Statement := '';
AddrStop := AAsmLine.Next;
while ACurAddr < AddrStop do
begin
AAsmLine.Next := ACurAddr + 1;
GetAsmLineDump;
DoCacheAndResult;
Inc(ACurAddr);
end;
end
else begin
GetAsmLineDump;
DoCacheAndResult;
end;
end;
procedure AddDisasm(AAsmList: TGDBMINameValueList; Alist: TList; const AFileName: String; ALine: Integer);
var
n: Integer;
Item: PGDBMINameValue;
Disasm: PGDBMIDisasm;
FuncNameQ, FuncName, S: String;
begin
FuncNameQ := '';
for n := 0 to AAsmList.Count - 1 do
begin
Item := AAsmList.Items[n];
InstList.Init(Item^.NamePtr, Item^.NameLen);
New(Disasm);
Disasm^.FileName := AFileName;
Disasm^.Line := ALine;
Disasm^.Address := StrToIntDef(Unquote(InstList.Values['address']), 0);
S := InstList.Values['func-name'];
if S <> FuncNameQ
then begin
FuncNameQ := S;
FuncName := Unquote(FuncNameQ);
end;
Disasm^.FuncName := FuncName;
Disasm^.Offset := StrToIntDef(Unquote(InstList.Values['offset']), 0);
Disasm^.Statement := Unquote(InstList.Values['inst']);
AList.Add(Disasm);
end;
end;
procedure AddDisasmWithSrc(ASource: TGDBMINameValueList; Alist: TList);
var
AsmList: TGDBMINameValueList;
Item: PGDBMINameValue;
n, Line: Integer;
FileNameQ, FileName, S: String;
begin
FileNameQ := '';
AsmList := TGDBMINameValueList.Create('');
for n := 0 to ASource.Count -1 do
begin
Item := ASource.Items[n];
AsmList.Init(Item^.ValuePtr, Item^.ValueLen);
S := AsmList.Values['file'];
// keep existing filename, only increase reference
if FilenameQ <> S
then begin
FileNameQ := S;
FileName := Unquote(FileNameQ);
end;
Line := StrToIntDef(Unquote(AsmList.Values['line']), 0);
AsmList.SetPath(['line_asm_insn']);
AddDisasm(AsmList, AList, FileName, Line);
end;
AsmList.Free;
end;
var
offset, n, count: Integer;
R: TGDBMIExecResult;
HasSource: Boolean;
AddrStart, Addr, AddrStop, SrcAddrStart: TDbgPtr;
Item: PGDBMINameValue;
AsmLine: TGDBMIAsmLine;
AsmList, AsmSrcList: TGDBMINameValueList;
DisasmList: TList;
Disasm: PGDBMIDisasm;
begin
if FAsmCacheIter.Locate(AAddr)
then begin
repeat
FAsmCacheIter.GetData(AsmLine);
if not ABackward then Break;
if AsmLine.Next > AAddr
then FAsmCacheIter.Previous;
until FAsmCacheIter.BOM or (AsmLine.Next <= AAddr);
if not ABackward
then begin
ANextAddr := AsmLine.Next;
ADump := AsmLine.Dump;
AStatement := AsmLine.Statement;
AFile := AsmLine.FileName;
ALine := AsmLine.Line;
Exit(True);
end;
if AsmLine.Next = AAddr
then begin
FAsmCacheIter.GetID(ANextAddr);
ADump := AsmLine.Dump;
AStatement := AsmLine.Statement;
AFile := AsmLine.FileName;
ALine := AsmLine.Line;
Exit(True);
end;
end
else begin
// position before the first address requested
if ABackward and not FAsmCacheIter.BOM
then FAsmCacheIter.Previous;
end;
InstList := nil;
if ABackward
then begin
// we need to get the line before this one
// try if we have some statement nearby
if not FAsmCacheIter.BOM
then begin
FAsmCacheIter.GetId(AddrStart);
// limit amout of retrieved adreses to 128
if AddrStart < AAddr - 128
then AddrStart := 0;
end
else AddrStart := 0;
if AddrStart = 0
then begin
// no starting point, see if we have an offset into a function
ExecuteCommand('-data-disassemble -s %u -e %u -- 0', [AAddr-1, AAddr], [cfIgnoreError, cfExternal], R);
if R.State <> dsError
then begin
AsmList := TGDBMINameValueList.Create(R, ['asm_insns']);
if AsmList.Count > 0
then begin
Item := AsmList.Items[0];
InstList := TGDBMINameValueList.Create('');
InstList.Init(Item^.NamePtr, Item^.NameLen);
if TryStrToQWord(Unquote(InstList.Values['address']), Addr)
and TryStrToInt(Unquote(InstList.Values['offset']), offset)
then AddrStart := Addr - Offset;
end;
FreeAndNil(AsmList);
end;
end;
if AddrStart = 0
then begin
// no nice startingpoint found, just start to disassemble 64 bytes before it
// and hope that when we started in the middle of an instruction it get
// sorted out.
AddrStart := AAddr - 64;
end;
// always include existing addr since we need this one to calculate the "nextaddr"
// of the previos record (the record we requested)
AddrStop := AAddr;
end
else begin
// stupid, gdb doesn't support linecount when disassembling from memory
// So we guess 32 here, that should give at least 2 lines on a CISC arch.
// On RISC we can do with less (future)
AddrStart := AAddr;
AddrStop := AAddr + 31;
end;
ExecuteCommand('-data-disassemble -s %u -e %u -- 1', [AddrStart, AddrStop], [cfIgnoreError, cfExternal], R);
if R.State = dsError
then begin
InstList.Free;
Exit(False);
end;
if InstList = nil
then InstList := TGDBMINameValueList.Create('');
DisasmList := TList.Create;
AsmList := TGDBMINameValueList.Create('');
AsmSrcList := TGDBMINameValueList.Create(R, ['asm_insns']);
HasSource := AsmSrcList.Count > 0;
if HasSource
then begin
// line info present
Item := AsmSrcList.Items[0];
if Item^.ValueLen = 0
then begin
// we got output as when requested without source
HasSource := False;
AsmList.Init(R.Values);
AsmList.SetPath(['asm_insns']);
if AsmList.Count >= 2
then AddDisasm(AsmList, DisasmList, '', 0);
end
else begin
AddDisasmWithSrc(AsmSrcList, DisasmList);
DisasmList.Sort(@DisasmSortCompare);
end;
end;
if DisasmList.Count > 0
then begin
Disasm := DisasmList[0];
SrcAddrStart := Disasm^.Address;
end
else begin
SrcAddrStart := AddrStop;
end;
if SrcAddrStart > AddrStart
then begin
// Start address of asm & source is after the requested start,
// fill with assembler
ExecuteCommand('-data-disassemble -s %u -e %u -- 0', [AddrStart, SrcAddrStart], [cfIgnoreError, cfExternal], R);
if R.State <> dsError
then begin
AsmList.Init(R.Values);
AsmList.SetPath(['asm_insns']);
AddDisasm(AsmList, DisasmList, '', 0);
DisasmList.Sort(@DisasmSortCompare);
end;
end;
if DisasmList.Count = 0
then begin
FreeAndNil(InstList);
FreeAndNil(AsmList);
FreeAndNil(AsmSrcList);
FreeAndNil(DisasmList);
Exit(False);
end;
DumpList := TGDBMINameValueList.Create('');
Disasm := DisasmList[0];
n := 1;
count := DisasmList.Count;
repeat
AsmLine.FileName := Disasm^.FileName;
AsmLine.Line := Disasm^.Line;
AsmLine.FuncName := Disasm^.FuncName;
AsmLine.Offset := Disasm^.Offset;
AsmLine.Statement := Disasm^.Statement;
AsmLine.Dump := '';
Addr := Disasm^.Address;
if n >= count then Break;
Disasm := DisasmList[n];
AsmLine.Next := Disasm^.Address;
AddAsmLine(Addr, AsmLine);
Inc(n);
until False;
// since next isn't known, the last AsmLine is not added yet.
if ABackward and (Addr < AAddr)
then begin
// the last backward next is allways the addr we requested
AsmLine.Next := AAddr;
AddAsmLine(Addr, AsmLine);
end
else begin
if HasSource
then begin
// When source is present, gdb disassembles only per line, so in
// this case we need to store the last asmline too.
// When requesting to disassemble the last statement, the
// next line is returned. NOT the skipped last statement.
// try to retrieve next
// make sure we get 2 lines
ExecuteCommand('-data-disassemble -s %u -e %u -- 0', [Addr, Addr+31], [cfIgnoreError, cfExternal], R);
if R.State <> dsError
then begin
AsmList.Init(R.Values);
AsmList.SetPath(['asm_insns']);
if AsmList.Count >= 2
then begin
Item := AsmList.Items[1];
InstList.Init(Item^.NamePtr, Item^.NameLen);
AsmLine.Next := StrToIntDef(Unquote(InstList.Values['address']), 0);
AddAsmLine(Addr, AsmLine);
end;
end;
end;
end;
for n := 0 to DisasmList.Count - 1 do
begin
Disasm := DisasmList[n];
Dispose(Disasm);
end;
FreeAndNil(InstList);
FreeAndNil(AsmList);
FreeAndNil(AsmSrcList);
FreeAndNil(DumpList);
FreeAndNil(DisasmList);
end;
function TGDBMIDebugger.GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
var
S: String;
begin
Result := True;
if State = dsRun
then GDBPause(True);
if ASet then
begin
S := EscapeGDBCommand(AVariable);
ExecuteCommand('-gdb-set env %s', [S], [cfIgnoreState, cfExternal]);
end else begin
S := AVariable;
ExecuteCommand('unset env %s', [GetPart([], ['='], S, False, False)], [cfNoMiCommand, cfIgnoreState, cfExternal]);
end;
end;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String; out ATypeInfo: TGDBType): Boolean;
function MakePrintable(const AString: String): String;
var
n: Integer;
InString: Boolean;
begin
Result := '';
InString := False;
for n := 1 to Length(AString) do
begin
case AString[n] of
' '..#127, #128..#255: begin
if not InString
then begin
InString := True;
Result := Result + '''';
end;
Result := Result + AString[n];
//if AString[n] = '''' then Result := Result + '''';
end;
else
if InString
then begin
InString := False;
Result := Result + '''';
end;
Result := Result + Format('#%d', [Ord(AString[n])]);
end;
end;
if InString
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; MinChars: Byte = 0): String;
var
Zeros: String;
begin
if IsHexC(Asource)
then begin
Result := Copy(ASource, 3, Length(ASource) - 2);
if Length(Result) < MinChars then
begin
SetLength(Zeros, MinChars - Length(Result));
FillChar(Zeros[1], Length(Zeros), '0');
Result := Zeros + Result;
end;
Result := '$' + Result;
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;
skVariant: begin
ATypeInfo.Value.AsString:=ValData;
end;
// skEnum: ;
// skSet: ;
skSimple: begin
ATypeInfo.Value.AsString:=ValData;
end;
// skPointer: ;
end;
end;
function SelectParentFrame(var aFrame: Integer): Boolean;
var
R: TGDBMIExecResult;
List: TGDBMINameValueList;
ParentFp, Fp: String;
begin
if not ExecuteCommand('-data-evaluate-expression parentfp', [cfIgnoreError], R)
or (R.State = dsError)
then Exit(False);
List := TGDBMINameValueList.Create(R);
ParentFP := List.Values['value'];
repeat
if not ExecuteCommand('-stack-select-frame %u', [aFrame+1], [cfIgnoreError], R)
or (R.State = dsError)
then begin
List.Free;
Exit(False);
end;
Inc(AFrame);
if not ExecuteCommand('-data-evaluate-expression $fp', [cfIgnoreError], R)
or (R.State = dsError)
then begin
List.Free;
Exit(False);
end;
Fp := List.Values['value'];
until ParentFP = Fp;
List.Free;
end;
function PascalizePointer(AString: String; const TypeCast: 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
// 0xabc0 => $0000ABC0
Result := UpperCase(HexCToHexPascal(AString, TargetWidth div 4));
end;
end
else Result := AString;
if TypeCast <> '' then
Result := TypeCast + '(' + Result + ')';
end;
function FormatCurrency(const AString: String): String;
var
i, e: Integer;
c: Currency;
begin
Result := AString;
Val(Result, i, e);
// debugger outputs 12345 for 1,2345 values
if e=0 then
begin
c := i / 10000;
Result := CurrToStr(c);
end;
end;
function GetVariantValue(AString: String): String;
function FormatVarError(const AString: String): String; inline;
begin
Result := 'Error('+AString+')';
end;
var
VarList: TGDBMINameValueList;
VType: Integer;
Addr: TDbgPtr;
dt: TDateTime;
e: Integer;
begin
VarList := TGDBMINameValueList.Create('');
try
VarList.UseTrim := True;
VarList.Init(AString);
VType := StrToIntDef(VarList.Values['VTYPE'], -1);
if VType = -1 then // can never happen if no error since varType is word
Exit('variant: unknown type');
case VType and not varTypeMask of
0:
begin
case VType of
varEmpty: Result := 'UnAssigned';
varNull: Result := 'Null';
varsmallint: Result := VarList.Values['VSMALLINT'];
varinteger: Result := VarList.Values['VINTEGER'];
varsingle: Result := VarList.Values['VSINGLE'];
vardouble: Result := VarList.Values['VDOUBLE'];
vardate:
begin
// float number
Result := VarList.Values['VDATE'];
val(Result, dt, e);
if e = 0 then
Result := DateTimeToStr(dt);
end;
varcurrency: Result := FormatCurrency(VarList.Values['VCURRENCY']);
varolestr: Result := VarList.Values['VOLESTR'];
vardispatch: Result := PascalizePointer(VarList.Values['VDISPATCH'], 'IDispatch');
varerror: Result := FormatVarError(VarList.Values['VERROR']);
varboolean: Result := VarList.Values['VBOOLEAN'];
varunknown: Result := PascalizePointer(VarList.Values['VUNKNOWN'], 'IUnknown');
varshortint: Result := VarList.Values['VSHORTINT'];
varbyte: Result := VarList.Values['VBYTE'];
varword: Result := VarList.Values['VWORD'];
varlongword: Result := VarList.Values['VLONGWORD'];
varint64: Result := VarList.Values['VINT64'];
varqword: Result := VarList.Values['VQWORD'];
varstring:
begin
// address of string
Result := VarList.Values['VSTRING'];
Val(Result, Addr, e);
if e = 0 then
begin
if Addr = 0 then
Result := ''''''
else
Result := MakePrintable(GetText(Addr));
end;
end;
varany: Result := VarList.Values['VANY'];
else
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
end;
end;
varArray:
begin
Result := VarTypeAsText(VType);
// TODO: show variant array data?
// Result := VarList.Values['VARRAY'];
end;
varByRef:
begin
Result := VarList.Values['VPOINTER'];
Val(Result, Addr, e);
if e = 0 then
begin
if Addr = 0 then
Result := '???'
else
begin
// Result contains a valid address
case VType xor varByRef of
varEmpty: Result := 'UnAssigned';
varNull: Result := 'Null';
varsmallint: Result := GetStrValue('psmallint(%s)^', [Result]);
varinteger: Result := GetStrValue('pinteger(%s)^', [Result]);
varsingle: Result := GetStrValue('psingle(%s)^', [Result]);
vardouble: Result := GetStrValue('pdouble(%s)^', [Result]);
vardate:
begin
// float number
Result := GetStrValue('pdatetime(%s)^', [Result]);
val(Result, dt, e);
if e = 0 then
Result := DateTimeToStr(dt);
end;
varcurrency: Result := FormatCurrency(GetStrValue('pcurrency(%s)^', [Result]));
varolestr:
begin
Result := GetStrValue('^pointer(%s)^', [Result]);
val(Result, Addr, e);
if e = 0 then
Result := MakePrintable(GetWideText(Addr));
end;
vardispatch: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IDispatch');
varerror: Result := FormatVarError(GetStrValue('phresult(%s)^', [Result]));
varboolean: Result := GetStrValue('pwordbool(%s)^', [Result]);
varunknown: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IUnknown');
varshortint: Result := GetStrValue('pshortint(%s)^', [Result]);
varbyte: Result := GetStrValue('pbyte(%s)^', [Result]);
varword: Result := GetStrValue('pword(%s)^', [Result]);
varlongword: Result := GetStrValue('plongword(%s)^', [Result]);
varint64: Result := GetStrValue('pint64(%s)^', [Result]);
varqword: Result := GetStrValue('pqword(%s)^', [Result]);
varstring: Result := MakePrintable(GetText('pansistring(%s)^', [Result]));
else
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
end;
end;
end;
end;
else
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
end;
finally
VarList.Free;
end;
end;
var
R, Rtmp: TGDBMIExecResult;
S: String;
ResultList: TGDBMINameValueList;
ResultInfo: TGDBType;
addr: TDbgPtr;
e: Integer;
Expr: TGDBMIExpression;
frame, frameidx: Integer;
PrintableString: String;
begin
AResult:='';
ATypeInfo:=nil;
S := AExpression;
if S = '' then Exit(false);
if S[1] = '!'
then begin
//TESTING...
Delete(S, 1, 1);
Expr := TGDBMIExpression.Create(S);
AResult := Expr.DumpExpression;
AResult := AResult + LineEnding;
Expr.Evaluate(Self, S, ATypeInfo);
FreeAndNil(ATypeInfo);
AResult := AResult + S;
Expr.Free;
Exit(True);
end;
ResultList := TGDBMINameValueList.Create('');
// 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
case ResultInfo.Kind of
skPointer: begin
S := GetPart([], [' '], AResult, False, False);
Val(S, addr, e);
if e <> 0 then Exit;
S := Lowercase(ResultInfo.TypeName);
case StringCase(S, ['char', 'character', 'ansistring', '__vtbl_ptr_type', 'wchar']) of
0, 1, 2: begin
if Addr = 0
then
AResult := ''''''
else
AResult := MakePrintable(GetText(Addr));
PrintableString := AResult;
end;
3: begin
if Addr = 0
then AResult := 'nil'
else begin
S := GetClassName(Addr);
if S = '' then S := '???';
AResult := 'class of ' + S + ' ' + AResult;
end;
end;
4: 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)
then begin
if (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 := PascalizePointer(AResult, '^' + S);
end
else AResult := PascalizePointer(AResult);
end;
end;
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 := '???'; //No instanced class found
AResult := 'class ' + S + ' ' + AResult;
end;
end;
end;
skVariant: begin
AResult := GetVariantValue(AResult);
end;
skRecord: begin
AResult := 'record ' + ResultInfo.TypeName + ' '+ AResult;
end;
skSimple: begin
if ResultInfo.TypeName = 'CURRENCY' then
AResult := FormatCurrency(AResult)
else
if (ResultInfo.TypeName = '&ShortString') then
AResult := GetStrValue('ShortString(%s)', [S]) // we have an address here, so we need to typecast
else
AResult := AResult;
end;
end;
finally
if frameidx <> frame
then begin
// Restore current frame
ExecuteCommand('-stack-select-frame %u', [frame], [cfIgnoreError]);
end
end;
ATypeInfo := ResultInfo;
PutValuesInTree;
AResult := FormatResult(AResult);
end;
function TGDBMIDebugger.GDBJumpTo(const ASource: String; const ALine: Integer): Boolean;
begin
Result := False;
end;
function TGDBMIDebugger.GDBPause(const AInternal: Boolean): Boolean;
begin
// Check if we already issued a break
if FPauseWaitState = pwsNone
then InterruptTarget;
if AInternal
then begin
if FPauseWaitState = pwsNone
then FPauseWaitState := pwsInternal;
end
else FPauseWaitState := pwsExternal;
Result := True;
end;
function TGDBMIDebugger.GDBRun: Boolean;
begin
Result := False;
case State of
dsStop: begin
Result := StartDebugging('-exec-continue');
end;
dsPause: begin
Result := ExecuteCommand('-exec-continue', [cfExternal]);
end;
dsIdle: begin
DebugLn('[WARNING] Debugger: Unable to run in idle state');
end;
end;
end;
function TGDBMIDebugger.GDBRunTo(const ASource: String;
const ALine: Integer): Boolean;
begin
Result := False;
case State of
dsStop: begin
Result := StartDebugging(Format('-exec-until %s:%d', [ASource, ALine]));
end;
dsPause: begin
Result := ExecuteCommand('-exec-until %s:%d', [ASource, ALine], [cfExternal]);
end;
dsIdle: begin
DebugLn('[WARNING] Debugger: Unable to runto in idle state');
end;
end;
end;
function TGDBMIDebugger.GDBSourceAdress(const ASource: String; ALine, AColumn: Integer; out AAddr: TDbgPtr): Boolean;
var
ID: packed record
Line, Column: Integer;
end;
Map: TMap;
idx, n: Integer;
R: TGDBMIExecResult;
LinesList, LineList: TGDBMINameValueList;
Item: PGDBMINameValue;
Addr: TDbgPtr;
begin
Result := False;
AAddr := 0;
if ASource = ''
then Exit;
idx := FSourceNames.IndexOf(ASource);
if (idx <> -1)
then begin
Map := TMap(FSourceNames.Objects[idx]);
ID.Line := ALine;
// since we dont have column info we map all on column 0
// ID.Column := AColumn;
ID.Column := 0;
Result := (Map <> nil);
if Result
then Map.GetData(ID, AAddr);
Exit;
end;
Result := ExecuteCommand('-symbol-list-lines %s', [ASource], [cfIgnoreError, cfExternal], R)
and (R.State <> dsError);
// if we have an .inc file then search for filename only since there are some
// problems with locating file by full path in gdb in case only relative file
// name is stored
if not Result then
Result := ExecuteCommand('-symbol-list-lines %s', [ExtractFileName(ASource)], [cfIgnoreError, cfExternal], R)
and (R.State <> dsError);
if not Result then Exit;
Map := TMap.Create(its8, SizeOf(AAddr));
FSourceNames.AddObject(ASource, Map);
LinesList := TGDBMINameValueList.Create(R, ['lines']);
if LinesList = nil then Exit(False);
ID.Column := 0;
LineList := TGDBMINameValueList.Create('');
for n := 0 to LinesList.Count - 1 do
begin
Item := LinesList.Items[n];
LineList.Init(Item^.NamePtr, Item^.NameLen);
if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
// one line can have more than one address
if Map.HasId(ID) then Continue;
Map.Add(ID, Addr);
if ID.Line = ALine
then AAddr := Addr;
end;
LineList.Free;
LinesList.Free;
end;
function TGDBMIDebugger.GDBStepInto: Boolean;
begin
Result := False;
case State of
dsStop: begin
Result := StartDebugging('');
end;
dsPause: begin
Result := ExecuteCommand('-exec-step', [cfExternal]);
end;
dsIdle: begin
DebugLn('[WARNING] Debugger: Unable to step in idle state');
end;
end;
end;
function TGDBMIDebugger.GDBStepOver: Boolean;
begin
Result := False;
case State of
dsStop: begin
Result := StartDebugging('');
end;
dsPause: begin
Result := ExecuteCommand('-exec-next', [cfExternal]);
end;
dsIdle: begin
DebugLn('[WARNING] Debugger: Unable to step over in idle state');
end;
end;
end;
function TGDBMIDebugger.GDBStop: Boolean;
begin
if State = dsError
then begin
// We don't know the state of the debugger,
// force a reinit. Let's hope this works.
DebugProcess.Terminate(0);
Done;
Result := True;
Exit;
end;
if State = dsRun
then GDBPause(True);
// not supported yet
// ExecuteCommand('-exec-abort');
Result := ExecuteCommand('kill', [cfNoMiCommand], @GDBStopCallback, 0);
end;
procedure TGDBMIDebugger.GDBStopCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
var
R: TGDBMIExecResult;
begin
// verify stop
if not ExecuteCommand('info program', [], [cfNoMICommand], R) then Exit;
if Pos('not being run', R.Values) > 0
then SetState(dsStop);
end;
function TGDBMIDebugger.GetGDBTypeInfo(const AExpression: String): TGDBType;
var
R: TGDBMIExecResult;
begin
if not ExecuteCommand('ptype %s', [AExpression], [cfIgnoreError, cfNoMiCommand], R)
or (R.State = dsError)
then begin
Result := nil;
end
else begin
Result := TGdbMIType.CreateFromResult(R);
end;
end;
function TGDBMIDebugger.GetData(const ALocation: TDbgPtr): TDbgPtr;
var
S: String;
begin
Str(ALocation, S);
Result := GetData(S, []);
end;
function TGDBMIDebugger.GetData(const AExpression: String;
const AValues: array of const): TDbgPtr;
var
R: TGDBMIExecResult;
e: Integer;
begin
Result := 0;
if ExecuteCommand('x/d ' + AExpression, AValues, [cfNoMICommand], R)
then Val(StripLN(GetPart('\t', '', R.Values)), Result, e);
if e=0 then ;
end;
function TGDBMIDebugger.GetFrame(const AIndex: Integer): String;
var
R: TGDBMIExecResult;
List: TGDBMINameValueList;
begin
Result := '';
if ExecuteCommand('-stack-list-frames %d %d', [AIndex, AIndex], [cfIgnoreError], R)
then begin
List := TGDBMINameValueList.Create(R, ['stack']);
Result := List.Values['frame'];
List.Free;
end;
end;
function TGDBMIDebugger.GetIntValue(const AExpression: String; const AValues: array of const): Integer;
var
e: Integer;
begin
Result := 0;
Val(GetStrValue(AExpression, AValues), Result, e);
if e=0 then ;
end;
function TGDBMIDebugger.GetPtrValue(const AExpression: String; const AValues: array of const): TDbgPtr;
var
e: Integer;
begin
Result := 0;
Val(GetStrValue(AExpression, AValues), Result, e);
if e=0 then ;
end;
function TGDBMIDebugger.GetStrValue(const AExpression: String; const AValues: array of const): String;
var
R: TGDBMIExecResult;
ResultList: TGDBMINameValueList;
begin
if ExecuteCommand('-data-evaluate-expression %s', [Format(AExpression, AValues)], [cfIgnoreError], R)
then begin
ResultList := TGDBMINameValueList.Create(R);
Result := DeleteEscapeChars(ResultList.Values['value']);
ResultList.Free;
end
else Result := '';
end;
function TGDBMIDebugger.GetText(const ALocation: TDBGPtr): String;
var
S: String;
begin
Str(ALocation, S);
Result := GetText(S, []);
end;
function TGDBMIDebugger.GetText(const AExpression: String;
const AValues: array of const): String;
var
S, Trailor: String;
R: TGDBMIExecResult;
n, len, idx: Integer;
v: Integer;
begin
if not ExecuteCommand('x/s ' + AExpression, AValues, [cfNoMICommand, cfIgnoreError], R)
then begin
Result := '';
Exit;
end;
S := StripLN(R.Values);
// don't use ' as end terminator, there might be one as part of the text
// since ' will be the last char, simply strip it.
S := GetPart(['\t '], [], S);
// Scan the string
len := Length(S);
// Set the resultstring initially to the same size
SetLength(Result, len);
n := 0;
idx := 1;
Trailor:='';
while idx <= len do
begin
case S[idx] of
'''': begin
Inc(idx);
// scan till end
while idx <= len do
begin
case S[idx] of
'''' : begin
Inc(idx);
if idx > len then Break;
if S[idx] <> '''' then Break;
end;
'\' : begin
Inc(idx);
if idx > len then Break;
case S[idx] of
't': S[idx] := #9;
'n': S[idx] := #10;
'r': S[idx] := #13;
end;
end;
end;
Inc(n);
Result[n] := S[idx];
Inc(idx);
end;
end;
'#': begin
Inc(idx);
v := 0;
// scan till non number (correct input is assumed)
while (idx <= len) and (S[idx] >= '0') and (S[idx] <= '9') do
begin
v := v * 10 + Ord(S[idx]) - Ord('0');
Inc(idx)
end;
Inc(n);
Result[n] := Chr(v and $FF);
end;
',', ' ': begin
Inc(idx); //ignore them;
end;
'<': begin
// Debugger has returned something like <repeats 10 times>
v := StrToIntDef(GetPart(['<repeats '], [' times>'], S), 0);
// Since we deleted the first part of S, reset idx
idx := 8; // the char after ' times>'
len := Length(S);
if v <= 1 then Continue;
// limit the amount of repeats
if v > 1000
then begin
Trailor := Trailor + Format('###(repeat truncated: %u -> 1000)###', [v]);
v := 1000;
end;
// make sure result has some room
SetLength(Result, Length(Result) + v - 1);
while v > 1 do begin
Inc(n);
Result[n] := Result[n - 1];
Dec(v);
end;
end;
else
// Debugger has returned something we don't know of
// Append the remainder to our parsed result
Delete(S, 1, idx - 1);
Trailor := Trailor + '###(gdb unparsed remainder:' + S + ')###';
Break;
end;
end;
SetLength(Result, n);
Result := Result + Trailor;
end;
function TGDBMIDebugger.GetWideText(const ALocation: TDBGPtr): String;
function GetWideChar(const ALocation: TDBGPtr): WideChar;
var
Address, S: String;
R: TGDBMIExecResult;
begin
Str(ALocation, Address);
if not ExecuteCommand('x/uh' + Address, [], [cfNoMICommand, cfIgnoreError], R)
then begin
Result := #0;
Exit;
end;
S := StripLN(R.Values);
S := GetPart(['\t'], [], S);
Result := WideChar(StrToIntDef(S, 0) and $FFFF);
end;
var
OneChar: WideChar;
CurLocation: TDBGPtr;
WStr: WideString;
begin
WStr := '';
CurLocation := ALocation;
repeat
OneChar := GetWideChar(CurLocation);
if OneChar <> #0 then
begin
WStr := WStr + OneChar;
CurLocation := CurLocation + 2;
end;
until (OneChar = #0);
Result := UTF8Encode(WStr);
end;
function TGDBMIDebugger.GetSupportedCommands: TDBGCommands;
begin
Result := [dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcRunTo, dcJumpto,
dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment,
dcSetStackFrame, dcDisassemble];
end;
function TGDBMIDebugger.GetTargetWidth: Byte;
begin
Result := FTargetPtrSize*8;
end;
procedure TGDBMIDebugger.Init;
procedure ParseGDBVersion;
var
R: TGDBMIExecResult;
S: String;
begin
FGDBVersion := '';
FGDBOS := '';
FGDBCPU := '';
if not ExecuteCommand('-gdb-version', [], [cfNoMiCommand], R) // No MI since the output is no MI
then Exit;
S := GetPart(['configured as \"'], ['\"'], R.Values, False, False);
if Pos('--target=', S) <> 0 then
S := GetPart('--target=', '', S);
FGDBCPU := GetPart('', '-', S);
GetPart('-', '-', S); // strip vendor
FGDBOS := GetPart('-', '-', S);
FGDBVersion := GetPart(['('], [')'], R.Values, False, False);
if FGDBVersion <> '' then Exit;
FGDBVersion := GetPart(['gdb '], [#10, #13], R.Values, True, False);
if FGDBVersion <> '' then Exit;
end;
procedure CheckGDBVersion;
begin
if FGDBVersion < '5.3'
then begin
DebugLn('[WARNING] Debugger: Running an old (< 5.3) GDB version: ', FGDBVersion);
DebugLn(' Not all functionality will be supported.');
end
else begin
DebugLn('[Debugger] Running GDB version: ', FGDBVersion);
Include(FDebuggerFlags, dfImplicidTypes);
end;
end;
var
Options: String;
begin
FPauseWaitState := pwsNone;
FInExecuteCount := 0;
Options := '-silent -i mi -nx';
if Length(TGDBMIDebuggerProperties(GetProperties).Debugger_Startup_Options) > 0
then Options := Options + ' ' + TGDBMIDebuggerProperties(GetProperties).Debugger_Startup_Options;
if CreateDebugProcess(Options)
then begin
if not ParseInitialization
then begin
SetState(dsError);
Exit;
end;
ExecuteCommand('-gdb-set confirm off', []);
// for win32, turn off a new console otherwise breaking gdb will fail
// ignore the error on other platforms
ExecuteCommand('-gdb-set new-console off', [cfIgnoreError]);
ParseGDBVersion;
CheckGDBVersion;
inherited Init;
end
else begin
if DebugProcess = nil
then MessageDlg('Debugger', 'Failed to create debug process for unknown reason', mtError, [mbOK], 0)
else MessageDlg('Debugger', Format('Failed to create debug process: %s', [ReadLine]), mtError, [mbOK], 0);
SetState(dsError);
end;
end;
procedure TGDBMIDebugger.InterruptTarget;
{$IFdef MSWindows}
function TryNT: Boolean;
var
hProcess: THandle;
hThread: THandle;
ThreadID: Cardinal;
E: Integer;
Emsg: PChar;
begin
Result := False;
hProcess := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_WRITE or PROCESS_VM_READ, False, TargetPID);
if hProcess = 0 then Exit;
try
hThread := _CreateRemoteThread(hProcess, nil, 0, DebugBreakAddr, nil, 0, ThreadID);
if hThread = 0
then begin
E := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, E, 0, PChar(@Emsg), 0, nil);
DebugLN('Error creating remote thread: ' + String(EMsg));
// Yuck !
// mixing handles and pointers, but it is how MS documented it
LocalFree(HLOCAL(Emsg));
Exit;
end;
Result := True;
CloseHandle(hThread);
// queue an info to find out if we are stopped in our interrupt thread
ExecuteCommand('info program', [cfNoMICommand], @InterruptTargetCallback, ThreadID);
finally
CloseHandle(hProcess);
end;
end;
{$ENDIF}
begin
if TargetPID = 0 then Exit;
{$IFDEF UNIX}
FpKill(TargetPID, SIGINT);
{$ENDIF}
{$IFdef MSWindows}
// GenerateConsoleCtrlEvent is nice, but only works if both gdb and
// our target have a console. On win95 and family this is our only
// option, on NT4+ we have a choice. Since this is not likely that
// we have a console, we do it the hard way. On XP there exists
// DebugBreakProcess, but it does efectively the same.
if (DebugBreakAddr = nil)
or not Assigned(_CreateRemoteThread)
or not TryNT
then begin
// We have no other choice than trying this
GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, TargetPID);
Exit;
end;
{$ENDIF}
end;
{$IFdef MSWindows}
procedure TGDBMIDebugger.InterruptTargetCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
var
R: TGDBMIExecResult;
S: String;
List: TGDBMINameValueList;
n: Integer;
ID1, ID2: Integer;
begin
// check if we need to get out of the interrupt thread
S := AResult.Values;
S := GetPart(['.0x'], ['.'], S, True, False);
if StrToIntDef('$'+S, 0) <> ATag then Exit;
// we're stopped in our thread
if FPauseWaitState = pwsInternal then Exit; // internal, dont care
S := '';
if not ExecuteCommand('-thread-list-ids', [cfIgnoreError], R) then Exit;
List := TGDBMINameValueList.Create(R);
try
n := StrToIntDef(List.Values['number-of-threads'], 0);
if n < 2 then Exit; //nothing to switch
List.SetPath(['thread-ids']);
if List.Count < 2 then Exit; // ???
ID1 := StrToIntDef(List.Values['thread-id'], 0);
List.Delete(0);
ID2 := StrToIntDef(List.Values['thread-id'], 0);
if ID1 = ID2 then Exit;
finally
List.Free;
end;
if not ExecuteCommand('-thread-select %d', [ID2], [cfIgnoreError]) then Exit;
end;
{$ENDIF}
function TGDBMIDebugger.ParseInitialization: Boolean;
var
Line, S: String;
begin
Result := True;
// Get initial debugger lines
S := '';
Line := StripLN(ReadLine);
while DebugProcessRunning and (Line <> '(gdb) ') do
begin
S := S + Line + LineEnding;
Line := StripLN(ReadLine);
end;
if S <> ''
then MessageDlg('Debugger', 'Initialization output: ' + LineEnding + S,
mtInformation, [mbOK], 0);
end;
procedure TGDBMIDebugger.ProcessFrame(const AFrame: String);
var
S: String;
e: Integer;
Frame: TGDBMINameValueList;
Location: TDBGLocationRec;
begin
// Do we have a frame ?
if AFrame = ''
then S := GetFrame(0)
else S := AFrame;
Frame := TGDBMINameValueList.Create(S);
Location.Address := 0;
Val(Frame.Values['addr'], Location.Address, e);
if e=0 then ;
Location.FuncName := Frame.Values['func'];
Location.SrcFile := ConvertPathDelims(Frame.Values['file']);
Location.SrcFullName := ConvertPathDelims(Frame.Values['fullname']);
Location.SrcLine := StrToIntDef(Frame.Values['line'], -1);
Frame.Free;
DoCurrent(Location);
end;
function TGDBMIDebugger.ProcessResult(var AResult: TGDBMIExecResult): Boolean;
function DoResultRecord(Line: String): Boolean;
var
ResultClass: String;
begin
ResultClass := GetPart('^', ',', Line);
if Line = ''
then begin
if AResult.Values <> ''
then Include(AResult.Flags, rfNoMI);
end
else begin
AResult.Values := Line;
end;
Result := True;
case StringCase(ResultClass, ['done', 'running', 'exit', 'error']) of
0: begin // done
end;
1: begin // running
AResult.State := dsRun;
end;
2: begin // exit
AResult.State := dsIdle;
end;
3: begin // error
DebugLn('TGDBMIDebugger.ProcessResult Error: ', Line);
// todo implement with values
if (pos('msg=', Line) > 0)
and (pos('not being run', Line) > 0)
then AResult.State := dsStop
else AResult.State := dsError;
end;
else
Result := False;
DebugLn('[WARNING] Debugger: Unknown result class: ', ResultClass);
end;
end;
procedure DoConsoleStream(Line: String);
var
len: Integer;
begin
// check for symbol info
if Pos('no debugging symbols', Line) > 0
then begin
Exclude(FTargetFlags, tfHasSymbols);
DebugLn('[WARNING] Debugger: File ''%s'' has no debug symbols', [FileName]);
end
else begin
// Strip surrounding ~" "
len := Length(Line) - 3;
if len < 0 then Exit;
Line := Copy(Line, 3, len);
// strip trailing \n (unless it is escaped \\n)
if (len >= 2) and (Line[len - 1] = '\') and (Line[len] = 'n')
then begin
if len = 2
then Line := LineEnding
else if Line[len - 2] <> '\'
then begin
SetLength(Line, len - 2);
Line := Line + LineEnding;
end;
end;
AResult.Values := AResult.Values + Line;
end;
end;
procedure DoTargetStream(const Line: String);
begin
DebugLn('[Debugger] Target output: ', Line);
end;
procedure DoLogStream(const Line: String);
begin
DebugLn('[Debugger] Log output: ', Line);
if Line = '&"kill\n"'
then AResult.State := dsStop
else if LeftStr(Line, 8) = '&"Error '
then AResult.State := dsError;
end;
var
S: String;
begin
Result := False;
AResult.Values := '';
AResult.Flags := [];
AResult.State := dsNone;
repeat
S := StripLN(ReadLine);
if S = '' then Continue;
if S = '(gdb) ' then Break;
case S[1] of
'^': Result := DoResultRecord(S);
'~': DoConsoleStream(S);
'@': DoTargetStream(S);
'&': DoLogStream(S);
'*', '+', '=': begin
DebugLn('[WARNING] Debugger: Unexpected async-record: ', S);
end;
else
DebugLn('[WARNING] Debugger: Unknown record: ', S);
end;
{$IFDEF VerboseIDEToDo}{$message warning condition should also check end-of-file reached for process output stream}{$ENDIF}
until not DebugProcessRunning;
end;
function TGDBMIDebugger.ProcessRunning(var AStoppedParams: String): Boolean;
function DoExecAsync(var Line: String): Boolean;
var
S: String;
begin
Result := False;
S := GetPart('*', ',', Line);
case StringCase(S, ['stopped', 'started', 'disappeared']) of
0: begin // stopped
AStoppedParams := Line;
end;
1, 2:; // Known, but undocumented classes
else
// Assume targetoutput, strip char and continue
DebugLn('[DBGTGT] *');
Line := S + Line;
Result := True;
end;
end;
procedure DoStatusAsync(const Line: String);
begin
DebugLn('[Debugger] Status output: ', Line);
end;
procedure DoNotifyAsync(var Line: String);
var
S: String;
begin
S := GetPart('=', ',', Line);
case StringCase(S, ['shlibs-added', 'shlibs-updated']) of
0: begin
//TODO: track libs
end;
1:; //ignore
else
DebugLn('[Debugger] Notify output: ', Line);
end;
end;
procedure DoResultRecord(const Line: String);
begin
DebugLn('[WARNING] Debugger: unexpected result-record: ', Line);
end;
procedure DoConsoleStream(const Line: String);
begin
DebugLn('[Debugger] Console output: ', Line);
end;
procedure DoTargetStream(const Line: String);
begin
DebugLn('[Debugger] Target output: ', Line);
end;
procedure DoLogStream(const Line: String);
begin
DebugLn('[Debugger] Log output: ', Line);
end;
var
S: String;
idx: Integer;
begin
Result := True;
while DebugProcessRunning do
begin
S := StripLN(ReadLine);
if S = '(gdb) ' then Break;
while S <> '' do
begin
case S[1] of
'^': DoResultRecord(S);
'~': DoConsoleStream(S);
'@': DoTargetStream(S);
'&': DoLogStream(S);
'*': if DoExecAsync(S) then Continue;
'+': DoStatusAsync(S);
'=': DoNotifyAsync(S);
else
// since target output isn't prefixed (yet?)
// one of our known commands could be part of it.
idx := Pos('*stopped', S);
if idx > 0
then begin
DebugLn('[DBGTGT] ', Copy(S, 1, idx - 1));
Delete(S, 1, idx - 1);
Continue;
end
else begin
// normal target output
DebugLn('[DBGTGT] ', S);
end;
end;
Break;
end;
end;
end;
function TGDBMIDebugger.ProcessStopped(const AParams: String; const AIgnoreSigIntState: Boolean): Boolean;
function GetLocation: TDBGLocationRec;
var
R: TGDBMIExecResult;
S: String;
begin
Result.SrcLine := -1;
Result.SrcFile := '';
Result.FuncName := '';
if tfRTLUsesRegCall in FTargetFlags
then Result.Address := GetPtrValue(FTargetRegisters[1], [])
else Result.Address := GetData('$fp+%d', [FTargetPtrSize * 3]);
Str(Result.Address, S);
if ExecuteCommand('info line * pointer(%s)', [S], [cfIgnoreError, cfNoMiCommand], R)
then begin
Result.SrcLine := StrToIntDef(GetPart('Line ', ' of', R.Values), -1);
Result.SrcFile := ConvertPathDelims(GetPart('\"', '\"', R.Values));
end;
end;
function GetExceptionInfo: TGDBMIExceptionInfo;
begin
if tfRTLUsesRegCall in FTargetFlags
then Result.ObjAddr := FTargetRegisters[0]
else begin
if dfImplicidTypes in FDebuggerFlags
then Result.ObjAddr := Format('^pointer($fp+%d)^', [FTargetPtrSize * 2])
else Str(GetData('$fp+%d', [FTargetPtrSize * 2]), Result.ObjAddr);
end;
Result.Name := GetInstanceClassName(Result.ObjAddr, []);
if Result.Name = ''
then Result.Name := 'Unknown';
end;
procedure ProcessException(AInfo: TGDBMIExceptionInfo);
var
ExceptionMessage: String;
CanContinue: Boolean;
begin
if dfImplicidTypes in FDebuggerFlags
then begin
if tfClassIsPointer in FTargetFlags
then ExceptionMessage := GetText('Exception(%s).FMessage', [AInfo.ObjAddr])
else ExceptionMessage := GetText('^Exception(%s)^.FMessage', [AInfo.ObjAddr]);
//ExceptionMessage := GetText('^^Exception($fp+8)^^.FMessage', []);
end
else ExceptionMessage := '### Not supported on GDB < 5.3 ###';
DoException(deInternal, AInfo.Name, ExceptionMessage, CanContinue);
if CanContinue
then ExecuteCommand('-exec-continue', [])
else DoCurrent(GetLocation);
end;
procedure ProcessBreak;
var
ErrorNo: Integer;
CanContinue: Boolean;
begin
if tfRTLUsesRegCall in FTargetFlags
then ErrorNo := GetIntValue(FTargetRegisters[0], [])
else ErrorNo := Integer(GetData('$fp+%d', [FTargetPtrSize * 2]));
ErrorNo := ErrorNo and $FFFF;
DoException(deRunError, Format('RunError(%d)', [ErrorNo]), '', CanContinue);
if CanContinue
then ExecuteCommand('-exec-continue', [])
else DoCurrent(GetLocation);
end;
procedure ProcessRunError;
var
ErrorNo: Integer;
CanContinue: Boolean;
begin
if tfRTLUsesRegCall in FTargetFlags
then ErrorNo := GetIntValue(FTargetRegisters[0], [])
else ErrorNo := Integer(GetData('$fp+%d', [FTargetPtrSize * 2]));
ErrorNo := ErrorNo and $FFFF;
DoException(deRunError, Format('RunError(%d)', [ErrorNo]), '', CanContinue);
if CanContinue
then ExecuteCommand('-exec-continue', [])
else ProcessFrame(GetFrame(1));
end;
procedure ProcessSignalReceived(const AList: TGDBMINameValueList);
var
SigInt, CanContinue: Boolean;
S: String;
begin
// TODO: check to run (un)handled
S := AList.Values['signal-name'];
{$IFdef MSWindows}
SigInt := S = 'SIGTRAP';
{$ELSE}
SigInt := S = 'SIGINT';
{$ENDIF}
if not AIgnoreSigIntState
or not SigInt
then SetState(dsPause);
if not SigInt
then DoException(deExternal, 'External: ' + S, '', CanContinue);
if not AIgnoreSigIntState
or not SigInt
then ProcessFrame(AList.Values['frame']);
end;
var
List: TGDBMINameValueList;
Reason: String;
BreakID: Integer;
BreakPoint: TGDBMIBreakPoint;
CanContinue: Boolean;
ExceptionInfo: TGDBMIExceptionInfo;
begin
Result := True;
FCurrentStackFrame := 0;
List := TGDBMINameValueList.Create(AParams);
try
Reason := List.Values['reason'];
if (Reason = 'exited-normally')
then begin
SetState(dsStop);
Exit;
end;
if Reason = 'exited'
then begin
SetExitCode(StrToIntDef(List.Values['exit-code'], 0));
SetState(dsStop);
Exit;
end;
if Reason = 'exited-signalled'
then begin
SetState(dsStop);
DoException(deExternal, 'External: ' + List.Values['signal-name'], '', CanContinue);
// ProcessFrame(List.Values['frame']);
Exit;
end;
if Reason = 'signal-received'
then begin
ProcessSignalReceived(List);
Exit;
end;
if Reason = 'breakpoint-hit'
then begin
BreakID := StrToIntDef(List.Values['bkptno'], -1);
if BreakID = -1
then begin
SetState(dsError);
// ???
Exit;
end;
if BreakID = FBreakErrorBreakID
then begin
SetState(dsPause);
ProcessBreak;
Exit;
end;
if BreakID = FRunErrorBreakID
then begin
SetState(dsPause);
ProcessRunError;
Exit;
end;
if BreakID = FExceptionBreakID
then begin
ExceptionInfo := GetExceptionInfo;
// check if we should ignore this exception
if Exceptions.IgnoreAll or (Exceptions.Find(ExceptionInfo.Name) <> nil)
then ExecuteCommand('-exec-continue', [])
else begin
SetState(dsPause);
ProcessException(ExceptionInfo);
end;
Exit;
end;
BreakPoint := TGDBMIBreakPoint(FindBreakpoint(BreakID));
if BreakPoint <> nil
then begin
CanContinue := False;
BreakPoint.Hit(CanContinue);
if CanContinue
then begin
ExecuteCommand('-exec-continue', []);
end
else begin
SetState(dsPause);
ProcessFrame(List.Values['frame']);
end;
end;
Exit;
end;
if Reason = 'function-finished'
then begin
SetState(dsPause);
ProcessFrame(List.Values['frame']);
Exit;
end;
if Reason = 'end-stepping-range'
then begin
SetState(dsPause);
ProcessFrame(List.Values['frame']);
Exit;
end;
if Reason = 'location-reached'
then begin
SetState(dsPause);
ProcessFrame(List.Values['frame']);
Exit;
end;
Result := False;
DebugLn('[WARNING] Debugger: Unknown stopped reason: ', Reason);
finally
List.Free;
end;
end;
function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
begin
case ACommand of
dcRun: Result := GDBRun;
dcPause: Result := GDBPause(False);
dcStop: Result := GDBStop;
dcStepOver: Result := GDBStepOver;
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^),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^),
String(AParams[5].VPointer^), Integer(AParams[6].VPointer^));
end;
end;
procedure TGDBMIDebugger.ClearCommandQueue;
var
CmdInfo: PGDBMICmdInfo;
i: Integer;
begin
for i:=0 to FCommandQueue.Count-1 do begin
CmdInfo:=PGDBMICmdInfo(FCommandQueue.Objects[i]);
if CmdInfo<>nil then Dispose(CmdInfo);
end;
FCommandQueue.Clear;
end;
procedure TGDBMIDebugger.ClearSourceInfo;
var
n: Integer;
begin
for n := 0 to FSourceNames.Count - 1 do
FSourceNames.Objects[n].Free;
FSourceNames.Clear;
end;
procedure TGDBMIDebugger.SelectStackFrame(AIndex: Integer);
begin
ExecuteCommand('-stack-select-frame %d', [AIndex], [cfIgnoreError]);
end;
function TGDBMIDebugger.StartDebugging(const AContinueCommand: String): Boolean;
function CheckFunction(const AFunction: String): Boolean;
var
R: TGDBMIExecResult;
idx: Integer;
begin
ExecuteCommand('info functions %s', [AFunction], [cfIgnoreError, cfNoMICommand], R);
idx := Pos(AFunction, R.Values);
if idx <> 0
then begin
// Strip first
Delete(R.Values, 1, idx + Length(AFunction) - 1);
idx := Pos(AFunction, R.Values);
end;
Result := idx <> 0;
end;
procedure RetrieveRegcall;
var
R: TGDBMIExecResult;
begin
// Assume it is
Include(FTargetFlags, tfRTLUsesRegCall);
ExecuteCommand('-data-evaluate-expression FPC_THREADVAR_RELOCATE_PROC', [cfIgnoreError], R);
if R.State <> dsError then Exit; // guessed right
// next attempt, posibly no symbols, try functions
if CheckFunction('FPC_CPUINIT') then Exit; // function present --> not 1.0
// this runerror is only defined for < 1.1 ?
if not CheckFunction('$$_RUNERROR$') then Exit;
// We are here in 2 cases
// 1) there are no symbols at all
// We dont have to know the calling convention
// 2) target is compiled with an earlier version than 1.9.2
// params are passes by stack
Exclude(FTargetFlags, tfRTLUsesRegCall);
end;
function InsertBreakPoint(const AName: String): Integer;
var
R: TGDBMIExecResult;
S: String;
ResultList: TGDBMINameValueList;
begin
// Try to retrieve the address of the procedure
if ExecuteCommand('info address ' + AName, [cfNoMICommand, cfIgnoreError], R)
and (R.State <> dsError)
then begin
S := GetPart(['at address ', ' at '], ['.', ' '], R.Values);
if S <> ''
then begin
ExecuteCommand('-break-insert *%u', [StrToIntDef(S, 0)], [cfIgnoreError], R);
if R.State = dsError then Exit(-1);
ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
Result := StrToIntDef(ResultList.Values['number'], -1);
ResultList.Free;
Exit;
end;
end;
ExecuteCommand('-break-insert %s', [AName], [cfIgnoreError], R);
if R.State = dsError then Exit(-1);
ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
Result := StrToIntDef(ResultList.Values['number'], -1);
ResultList.Free;
end;
procedure SetTargetInfo(const AFileType: String);
begin
// assume some defaults
FTargetPtrSize := 4;
FTargetIsBE := False;
case StringCase(AFileType, [
'efi-app-ia32', 'elf32-i386', 'pei-i386', 'elf32-i386-freebsd',
'elf64-x86-64',
'mach-o-be',
'mach-o-le',
'pei-arm-little',
'pei-arm-big'
], True, False) of
0..3: FTargetCPU := 'x86';
4: FTargetCPU := 'x86_64';
5: begin
//mach-o-be
FTargetIsBE := True;
if FGDBCPU <> ''
then FTargetCPU := FGDBCPU
else FTargetCPU := 'powerpc'; // guess
end;
6: begin
//mach-o-le
if FGDBCPU <> ''
then FTargetCPU := FGDBCPU
else FTargetCPU := 'x86'; // guess
end;
7: begin
FTargetCPU := 'arm';
end;
8: begin
FTargetIsBE := True;
FTargetCPU := 'arm';
end;
else
// Unknown filetype, use GDB cpu
DebugLn('[WARNING] [Debugger.TargetInfo] Unknown FileType: %s, using GDB cpu', [AFileType]);
FTargetCPU := FGDBCPU;
end;
case StringCase(FTargetCPU, [
'x86', 'i386', 'i486', 'i586', 'i686',
'ia64', 'x86_64', 'powerpc',
'sparc', 'arm'
], True, False) of
0..4: begin // x86
FTargetRegisters[0] := '$eax';
FTargetRegisters[1] := '$edx';
FTargetRegisters[2] := '$ecx';
end;
5, 6: begin // ia64, x86_64
FTargetRegisters[0] := '$rdi';
FTargetRegisters[1] := '$rsi';
FTargetRegisters[2] := '$rdx';
FTargetPtrSize := 8;
end;
7: begin // powerpc
FTargetIsBE := True;
// alltough darwin can start with r2, it seems that all OS start with r3
// if UpperCase(FTargetOS) = 'DARWIN'
// then begin
// FTargetRegisters[0] := '$r2';
// FTargetRegisters[1] := '$r3';
// FTargetRegisters[2] := '$r4';
// end
// else begin
FTargetRegisters[0] := '$r3';
FTargetRegisters[1] := '$r4';
FTargetRegisters[2] := '$r5';
// end;
end;
8: begin // sparc
FTargetIsBE := True;
FTargetRegisters[0] := '$g1';
FTargetRegisters[1] := '$o0';
FTargetRegisters[2] := '$o1';
end;
9: begin // arm
FTargetRegisters[0] := '$r0';
FTargetRegisters[1] := '$r1';
FTargetRegisters[2] := '$r2';
end;
else
FTargetRegisters[0] := '';
FTargetRegisters[1] := '';
FTargetRegisters[2] := '';
DebugLn('[WARNING] [Debugger] Unknown target CPU: ', FTargetCPU);
end;
end;
function SetTempMainBreak: Boolean;
var
R: TGDBMIExecResult;
S: String;
ResultList: TGDBMINameValueList;
begin
// Try to retrieve the address of main. Setting a break on main is past initialization
if ExecuteCommand('info address main', [cfNoMICommand, cfIgnoreError], R)
and (R.State <> dsError)
then begin
S := GetPart(['at address ', ' at '], ['.', ' '], R.Values);
if S <> ''
then begin
FMainAddr := StrToIntDef(S, 0);
ExecuteCommand('-break-insert -t *%u', [FMainAddr], [cfIgnoreError], R);
Result := R.State <> dsError;
if Result then Exit;
end;
end;
ExecuteCommand('-break-insert -t main', [cfIgnoreError], R);
Result := R.State <> dsError;
if not Result then Exit;
ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
FMainAddr := StrToIntDef(ResultList.Values['addr'], 0);
ResultList.Free;
end;
var
R: TGDBMIExecResult;
FileType, EntryPoint: String;
List: TGDBMINameValueList;
TargetPIDPart: String;
TempInstalled, CanContinue: Boolean;
begin
if not (State in [dsStop])
then begin
Result := True;
Exit;
end;
DebugLn(['TGDBMIDebugger.StartDebugging WorkingDir="',WorkingDir,'"']);
if WorkingDir <> ''
then begin
// to workaround a possible bug in gdb, first set the workingdir to .
// otherwise on second run within the same gdb session the workingdir
// is set to c:\windows
ExecuteCommand('-environment-cd %s', ['.'], [cfIgnoreError]);
ExecuteCommand('-environment-cd %s', [ConvertToGDBPath(UTF8ToSys(WorkingDir))], []);
end;
FTargetFlags := [tfHasSymbols]; // Set until proven otherwise
// check if the exe is compiled with FPC >= 1.9.2
// then the rtl is compiled with regcalls
RetrieveRegCall;
// also call execute -exec-arguments if there are no arguments in this run
// 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
ExecuteCommand('-gdb-set language pascal', []);
TempInstalled := SetTempMainBreak;
end
else begin
DebugLn('TGDBMIDebugger.StartDebugging Note: Target has no symbols');
TempInstalled := False;
end;
// check whether we need class cast dereference
if ExecuteCommand('ptype TObject', [cfIgnoreError], R)
then begin
if (LeftStr(R.Values, 15) = 'type = ^TOBJECT')
then include(FTargetFlags, tfClassIsPointer);
end;
// try Insert Break breakpoint
// we might have rtl symbols
if FExceptionBreakID = -1
then FExceptionBreakID := InsertBreakPoint('FPC_RAISEEXCEPTION');
if FBreakErrorBreakID = -1
then FBreakErrorBreakID := InsertBreakPoint('FPC_BREAK_ERROR');
if FRunErrorBreakID = -1
then FRunErrorBreakID := InsertBreakPoint('FPC_RUNERROR');
FTargetCPU := '';
FTargetOS := FGDBOS; // try to detect ??
// try to retrieve the filetype and program entry point
FileType := '';
EntryPoint := '';
if ExecuteCommand('info file', [cfIgnoreError, cfNoMICommand], R)
then begin
if rfNoMI in R.Flags
then begin
FileType := GetPart('file type ', '.', R.Values);
EntryPoint := GetPart(['Entry point: '], [#10, #13, '\t'], R.Values);
end
else begin
// OS X gdb has mi output here
List := TGDBMINameValueList.Create(R, ['section-info']);
FileType := List.Values['filetype'];
EntryPoint := List.Values['entry-point'];
List.Free;
end;
DebugLn('[Debugger] File type: ', FileType);
DebugLn('[Debugger] Entry point: ', EntryPoint);
end;
SetTargetInfo(FileType);
if not TempInstalled and (EntryPoint <> '')
then begin
// We could not set our initial break to get info and allow stepping
// Try it with the program entry point
FMainAddr := StrToIntDef(EntryPoint, 0);
ExecuteCommand('-break-insert -t *%u', [FMainAddr], [cfIgnoreError], R);
TempInstalled := R.State <> dsError;
end;
FTargetPID := 0;
// fire the first step
if TempInstalled
and ExecuteCommand('-exec-run', [], R)
then begin
// some versions of gdb (OSX) output the PID here
TargetPIDPart := GetPart(['process '],
[' local'], R.Values, True);
FTargetPID := StrToIntDef(TargetPIDPart, 0);
R.State := dsNone;
end;
// try to find PID (if not already found)
if (FTargetPID = 0)
and ExecuteCommand('info program', [], [cfIgnoreError, cfNoMICommand], R)
then begin
TargetPIDPart := GetPart(['child process ', 'child thread ', 'lwp '],
[' ', '.', ')'], R.Values, True);
FTargetPID := StrToIntDef(TargetPIDPart, 0);
end;
if FTargetPID = 0
then begin
Result := False;
SetState(dsError);
Exit;
end;
DebugLn('[Debugger] Target PID: %u', [FTargetPID]);
if R.State = dsNone
then begin
SetState(dsInit);
if FBreakAtMain <> nil
then begin
CanContinue := False;
TGDBMIBreakPoint(FBreakAtMain).Hit(CanContinue);
end
else CanContinue := True;
if CanContinue and (AContinueCommand <> '')
then Result := ExecuteCommand(AContinueCommand, [])
else SetState(dsPause);
end
else SetState(R.State);
if State = dsPause
then ProcessFrame;
Result := True;
end;
procedure TGDBMIDebugger.TestCmd(const ACommand: String);
begin
ExecuteCommand(ACommand, [cfIgnoreError]);
end;
{ =========================================================================== }
{ TGDBMIBreakPoint }
{ =========================================================================== }
constructor TGDBMIBreakPoint.Create(ACollection: TCollection);
begin
inherited Create(ACollection);
FBreakID := 0;
end;
destructor TGDBMIBreakPoint.Destroy;
begin
ReleaseBreakPoint;
inherited Destroy;
end;
procedure TGDBMIBreakPoint.DoEnableChange;
begin
UpdateEnable;
inherited;
end;
procedure TGDBMIBreakPoint.DoExpressionChange;
begin
UpdateExpression;
inherited;
end;
procedure TGDBMIBreakPoint.DoStateChange(const AOldState: TDBGState);
begin
inherited DoStateChange(AOldState);
case Debugger.State of
dsInit: begin
SetBreakpoint;
end;
dsStop: begin
if AOldState = dsRun
then ReleaseBreakpoint;
end;
end;
end;
procedure TGDBMIBreakPoint.SetBreakpoint;
begin
if Debugger = nil then Exit;
if FBreakID <> 0
then ReleaseBreakPoint;
if Debugger.State = dsRun
then TGDBMIDebugger(Debugger).GDBPause(True);
TGDBMIDebugger(Debugger).ExecuteCommand('-break-insert %s:%d',
[ExtractFileName(Source), Line], [cfIgnoreError], @SetBreakPointCallback, 0);
end;
procedure TGDBMIBreakPoint.SetBreakPointCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
var
ResultList: TGDBMINameValueList;
begin
BeginUpdate;
try
ResultList := TGDBMINameValueList.Create(AResult, ['bkpt']);
FBreakID := StrToIntDef(ResultList.Values['number'], 0);
SetHitCount(StrToIntDef(ResultList.Values['times'], 0));
if FBreakID <> 0
then SetValid(vsValid)
else SetValid(vsInvalid);
UpdateExpression;
UpdateEnable;
if (FBreakID <> 0)
and Enabled
and (TGDBMIDebugger(Debugger).FBreakAtMain = nil)
then begin
// Check if this BP is at the same location as the temp break
if StrToIntDef(ResultList.Values['addr'], 0) = TGDBMIDebugger(Debugger).FMainAddr
then TGDBMIDebugger(Debugger).FBreakAtMain := Self;
end;
ResultList.Free;
finally
EndUpdate;
end;
end;
procedure TGDBMIBreakPoint.ReleaseBreakPoint;
begin
if FBreakID = 0 then Exit;
if Debugger = nil then Exit;
if Debugger.State = dsRun
then TGDBMIDebugger(Debugger).GDBPause(True);
TGDBMIDebugger(Debugger).ExecuteCommand('-break-delete %d', [FBreakID], []);
FBreakID:=0;
SetHitCount(0);
end;
procedure TGDBMIBreakPoint.SetLocation(const ASource: String; const ALine: Integer);
begin
if (Source = ASource) and (Line = ALine) then exit;
inherited;
if Debugger = nil then Exit;
if TGDBMIDebugger(Debugger).State in [dsStop, dsPause, dsRun]
then SetBreakpoint;
end;
procedure TGDBMIBreakPoint.UpdateEnable;
const
// Use shortstring as fix for fpc 1.9.5 [2004/07/15]
CMD: array[Boolean] of ShortString = ('disable', 'enable');
begin
if (FBreakID = 0)
or (Debugger = nil)
then Exit;
if Debugger.State = dsRun
then TGDBMIDebugger(Debugger).GDBPause(True);
//writeln('TGDBMIBreakPoint.UpdateEnable Line=',Line,' Enabled=',Enabled,' InitialEnabled=',InitialEnabled);
TGDBMIDebugger(Debugger).ExecuteCommand('-break-%s %d',
[CMD[Enabled], FBreakID], []);
end;
procedure TGDBMIBreakPoint.UpdateExpression;
begin
end;
{ =========================================================================== }
{ TGDBMILocals }
{ =========================================================================== }
procedure TGDBMILocals.AddLocals(const AParams: String);
var
n, e: Integer;
addr: TDbgPtr;
LocList, List: TGDBMINameValueList;
Item: PGDBMINameValue;
S, Name, Value: String;
begin
LocList := TGDBMINameValueList.Create(AParams);
List := TGDBMINameValueList.Create('');
for n := 0 to LocList.Count - 1 do
begin
Item := LocList.Items[n];
List.Init(Item^.NamePtr, Item^.NameLen);
Name := List.Values['name'];
if Name = 'this'
then Name := 'Self';
Value := DeleteEscapeChars(List.Values['value']);
// try to deref. strings
S := GetPart(['(pchar) ', '(ansistring) '], [], Value, True, False);
if S <> ''
then begin
addr := 0;
Val(S, addr, e);
if e=0 then ;
if addr = 0
then Value := ''''''
else Value := '''' + TGDBMIDebugger(Debugger).GetText(addr) + '''';
end;
FLocals.Add(Name + '=' + Value);
end;
FreeAndNil(List);
FreeAndNil(LocList);
end;
procedure TGDBMILocals.Changed;
begin
Invalidate;
inherited Changed;
end;
constructor TGDBMILocals.Create(const ADebugger: TDebugger);
begin
FLocals := TStringList.Create;
FLocals.Sorted := True;
FLocalsValid := False;
inherited;
end;
destructor TGDBMILocals.Destroy;
begin
inherited;
FreeAndNil(FLocals);
end;
procedure TGDBMILocals.DoStateChange(const AOldState: TDBGState);
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then begin
DoChange;
end
else begin
Invalidate;
end;
end;
procedure TGDBMILocals.Invalidate;
begin
FLocalsValid:=false;
FLocals.Clear;
end;
function TGDBMILocals.GetCount: Integer;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then begin
LocalsNeeded;
Result := FLocals.Count;
end
else Result := 0;
end;
function TGDBMILocals.GetName(const AnIndex: Integer): String;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then begin
LocalsNeeded;
Result := FLocals.Names[AnIndex];
end
else Result := '';
end;
function TGDBMILocals.GetValue(const AnIndex: Integer): String;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then begin
LocalsNeeded;
Result := FLocals[AnIndex];
Result := GetPart('=', '', Result);
end
else Result := '';
end;
procedure TGDBMILocals.LocalsNeeded;
var
R: TGDBMIExecResult;
List: TGDBMINameValueList;
begin
if Debugger = nil then Exit;
if FLocalsValid then Exit;
// args
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-list-arguments 1 %0:d %0:d',
[TGDBMIDebugger(Debugger).FCurrentStackFrame], [cfIgnoreError], R);
if R.State <> dsError
then begin
List := TGDBMINameValueList.Create(R, ['stack-args', 'frame']);
AddLocals(List.Values['args']);
FreeAndNil(List);
end;
// variables
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-list-locals 1', [cfIgnoreError], R);
if R.State <> dsError
then begin
List := TGDBMINameValueList.Create(R);
AddLocals(List.Values['locals']);
FreeAndNil(List);
end;
FLocalsValid := True;
end;
{ =========================================================================== }
{ TGDBMIRegisters }
{ =========================================================================== }
procedure TGDBMIRegisters.Changed;
begin
Invalidate;
inherited Changed;
end;
procedure TGDBMIRegisters.DoStateChange(const AOldState: TDBGState);
begin
if Debugger <> nil
then begin
case Debugger.State of
dsPause: DoChange;
dsStop : FRegistersValid := False;
else
Invalidate
end;
end
else Invalidate;
end;
procedure TGDBMIRegisters.Invalidate;
var
n: Integer;
begin
for n := Low(FRegisters) to High(FRegisters) do
begin
FRegisters[n].Value := '';
FRegisters[n].Modified := False;
end;
FValuesValid := False;
end;
function TGDBMIRegisters.GetCount: Integer;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then RegistersNeeded;
Result := Length(FRegisters)
end;
function TGDBMIRegisters.GetModified(const AnIndex: Integer): Boolean;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then ValuesNeeded;
if FValuesValid
and FRegistersValid
and (AnIndex >= Low(FRegisters))
and (AnIndex <= High(FRegisters))
then Result := FRegisters[AnIndex].Modified
else Result := False;
end;
function TGDBMIRegisters.GetName(const AnIndex: Integer): String;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then RegistersNeeded;
if FRegistersValid
and (AnIndex >= Low(FRegisters))
and (AnIndex <= High(FRegisters))
then Result := FRegisters[AnIndex].Name
else Result := '';
end;
function TGDBMIRegisters.GetValue(const AnIndex: Integer): String;
begin
if (Debugger <> nil)
and (Debugger.State = dsPause)
then ValuesNeeded;
if FValuesValid
and FRegistersValid
and (AnIndex >= Low(FRegisters))
and (AnIndex <= High(FRegisters))
then Result := FRegisters[AnIndex].Value
else Result := '';
end;
procedure TGDBMIRegisters.RegistersNeeded;
var
R: TGDBMIExecResult;
List: TGDBMINameValueList;
n: Integer;
begin
if Debugger = nil then Exit;
if FRegistersValid then Exit;
FRegistersValid := True;
TGDBMIDebugger(Debugger).ExecuteCommand('-data-list-register-names', [cfIgnoreError], R);
if R.State = dsError then Exit;
List := TGDBMINameValueList.Create(R, ['register-names']);
SetLength(FRegisters, List.Count);
for n := 0 to List.Count - 1 do
begin
FRegisters[n].Name := UnQuote(List.GetString(n));
FRegisters[n].Value := '';
FRegisters[n].Modified := False;
end;
FreeAndNil(List);
end;
procedure TGDBMIRegisters.ValuesNeeded;
var
R: TGDBMIExecResult;
List, ValList: TGDBMINameValueList;
Item: PGDBMINameValue;
n, idx: Integer;
begin
if Debugger = nil then Exit;
if FValuesValid then Exit;
RegistersNeeded;
FValuesValid := True;
for n := Low(FRegisters) to High(FRegisters) do
begin
FRegisters[n].Value := '';
FRegisters[n].Modified := False;
end;
TGDBMIDebugger(Debugger).ExecuteCommand('-data-list-register-values N', [cfIgnoreError], R);
if R.State = dsError then Exit;
ValList := TGDBMINameValueList.Create('');
List := TGDBMINameValueList.Create(R, ['register-values']);
for n := 0 to List.Count - 1 do
begin
Item := List.Items[n];
ValList.Init(Item^.NamePtr, Item^.NameLen);
idx := StrToIntDef(Unquote(ValList.Values['number']), -1);
if idx < Low(FRegisters) then Continue;
if idx > High(FRegisters) then Continue;
FRegisters[idx].Value := Unquote(ValList.Values['value']);
end;
FreeAndNil(List);
FreeAndNil(ValList);
TGDBMIDebugger(Debugger).ExecuteCommand('-data-list-changed-registers', [cfIgnoreError], R);
if R.State = dsError then Exit;
List := TGDBMINameValueList.Create(R, ['changed-registers']);
for n := 0 to List.Count - 1 do
begin
idx := StrToIntDef(Unquote(List.GetString(n)), -1);
if idx < Low(FRegisters) then Continue;
if idx > High(FRegisters) then Continue;
FRegisters[idx].Modified := True;
end;
FreeAndNil(List);
end;
{ =========================================================================== }
{ TGDBMIWatch }
{ =========================================================================== }
constructor TGDBMIWatch.Create(ACollection: TCollection);
begin
FEvaluated := False;
inherited;
end;
destructor TGDBMIWatch.Destroy;
begin
FreeAndNil(FTypeInfo);
inherited;
end;
procedure TGDBMIWatch.DoEnableChange;
begin
inherited;
end;
procedure TGDBMIWatch.DoExpressionChange;
begin
FEvaluated := False;
inherited;
end;
procedure TGDBMIWatch.DoChange;
begin
Changed;
end;
procedure TGDBMIWatch.DoStateChange(const AOldState: TDBGState);
begin
if Debugger = nil then Exit;
if Debugger.State in [dsPause, dsStop]
then begin
ClearOwned;
FEvaluated := False;
end;
if Debugger.State = dsPause then Changed;
end;
procedure TGDBMIWatch.Invalidate;
begin
ClearOwned;
FEvaluated := False;
end;
procedure TGDBMIWatch.EvaluationNeeded;
var
ExprIsValid: Boolean;
begin
if FEvaluated then Exit;
if Debugger = nil then Exit;
if (Debugger.State in [dsPause, dsStop])
and Enabled
then begin
ClearOwned;
ExprIsValid:=TGDBMIDebugger(Debugger).GDBEvaluate(Expression, FValue, FTypeInfo);
if ExprIsValid then
SetValid(vsValid)
else
SetValid(vsInvalid);
end
else begin
SetValid(vsInvalid);
end;
FEvaluated := True;
end;
procedure TGDBMIWatch.ClearOwned;
begin
FreeAndNil(FTypeInfo);
FValue:='';
end;
function TGDBMIWatch.GetValue: String;
begin
if (Debugger <> nil)
and (Debugger.State in [dsStop, dsPause])
and Enabled
then begin
EvaluationNeeded;
Result := FValue;
end
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;
Result := inherited GetValid;
end;
{ =========================================================================== }
{ TGDBMIWatches }
{ =========================================================================== }
procedure TGDBMIWatches.Changed;
var
n: Integer;
begin
for n := 0 to Count - 1 do
TGDBMIWatch(Items[n]).Invalidate;
inherited Changed;
end;
{ =========================================================================== }
{ TGDBMICallStack }
{ =========================================================================== }
function TGDBMICallStack.CheckCount: Boolean;
var
R: TGDBMIExecResult;
List: TGDBMINameValueList;
i, cnt: longint;
begin
Result := inherited CheckCount;
if not Result then Exit;
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-info-depth', [cfIgnoreError], R);
List := TGDBMINameValueList.Create(R);
cnt := StrToIntDef(List.Values['depth'], -1);
FreeAndNil(List);
if cnt = -1 then
begin
{ In case of error some stackframes still can be accessed.
Trying to find out how many...
We try maximum 40 frames, because sometimes a corrupt stack and a bug in
gdb may cooperate, so that -stack-info-depth X returns always X }
i:=0;
repeat
inc(i);
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-info-depth %d', [i], [cfIgnoreError], R);
List := TGDBMINameValueList.Create(R);
cnt := StrToIntDef(List.Values['depth'], -1);
FreeAndNil(List);
if (cnt = -1) then begin
// no valid stack-info-depth found, so the previous was the last valid one
cnt:=i - 1;
end;
until (cnt<i) or (i=40);
end;
SetCount(cnt);
end;
function TGDBMICallStack.InternalCreateEntry(AIndex: Integer; AArgInfo, AFrameInfo : TGDBMINameValueList) : TCallStackEntry;
var
n, e: Integer;
Arguments: TStringList;
List: TGDBMINameValueList;
Arg: PGDBMINameValue;
addr: TDbgPtr;
func, filename, fullname, line : String;
begin
Arguments := TStringList.Create;
if (AArgInfo <> nil) and (AArgInfo.Count > 0)
then begin
List := TGDBMINameValueList.Create('');
for n := 0 to AArgInfo.Count - 1 do
begin
Arg := AArgInfo.Items[n];
List.Init(Arg^.NamePtr, Arg^.NameLen);
Arguments.Add(List.Values['name'] + '=' + DeleteEscapeChars(List.Values['value']));
end;
FreeAndNil(List);
end;
addr := 0;
func := '';
filename := '';
fullname := '';
line := '';
if AFrameInfo <> nil
then begin
Val(AFrameInfo.Values['addr'], addr, e);
if e=0 then ;
func := AFrameInfo.Values['func'];
filename := ConvertPathDelims(AFrameInfo.Values['file']);
fullname := ConvertPathDelims(AFrameInfo.Values['fullname']);
line := AFrameInfo.Values['line'];
end;
Result := TCallStackEntry.Create(
AIndex,
addr,
Arguments,
func,
filename,
fullname,
StrToIntDef(line, 0)
);
Arguments.Free;
end;
function TGDBMICallStack.CreateStackEntry(AIndex: Integer): TCallStackEntry;
var
R: TGDBMIExecResult;
ArgList, FrameList: TGDBMINameValueList;
begin
if Debugger = nil then Exit;
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-list-arguments 1 %0:d %0:d',
[AIndex], [cfIgnoreError], R);
// TODO: check what to display on error
if R.State <> dsError
then ArgList := TGDBMINameValueList.Create(R, ['stack-args', 'frame', 'args'])
else ArgList := nil;
TGDBMIDebugger(Debugger).ExecuteCommand('-stack-list-frames %0:d %0:d',
[AIndex], [cfIgnoreError], R);
if R.State <> dsError
then FrameList := TGDBMINameValueList.Create(R, ['stack', 'frame'])
else FrameList := nil;
Result := InternalCreateEntry(AIndex, ArgList, FrameList);
FreeAndNil(ArgList);
FreeAndNil(FrameList);
end;
function TGDBMICallStack.GetCurrent: TCallStackEntry;
var
idx: Integer;
begin
idx := TGDBMIDebugger(Debugger).FCurrentStackFrame;
if (idx < 0) or (idx >= Count)
then Result := nil
else Result := Entries[idx];
end;
procedure TGDBMICallStack.PrepareEntries(AIndex, ACount: Integer);
type
TGDBMINameValueListArray = array of TGDBMINameValueList;
procedure PrepareArgs(var ADest: TGDBMINameValueListArray; AStart, AStop: Integer;
const ACmd, APath1, APath2: String);
var
R: TGDBMIExecResult;
i, lvl : Integer;
ResultList, SubList: TGDBMINameValueList;
begin
TGDBMIDebugger(Debugger).ExecuteCommand(ACmd, [AStart, AStop], [cfIgnoreError], R);
if R.State = dsError
then begin
i := AStop - AStart;
case i of
0 : exit;
1..5: begin
while i >= 0 do
begin
PrepareArgs(ADest, AStart+i, AStart+i, ACmd, APath1, APath2);
dec(i);
end;
end;
else
i := i div 2;
PrepareArgs(ADest, AStart, AStart+i, ACmd, APath1, APath2);
PrepareArgs(ADest, AStart+i+1, AStop, ACmd, APath1, APath2);
end;
end;
ResultList := TGDBMINameValueList.Create(R, [APath1]);
for i := 0 to ResultList.Count - 1 do
begin
SubList := TGDBMINameValueList.Create(ResultList.GetString(i), ['frame']);
lvl := StrToIntDef(SubList.Values['level'], -1);
if (lvl >= AStart) and (lvl <= AStop)
then begin
if APath2 <> ''
then SubList.SetPath(APath2);
ADest[lvl-AIndex] := SubList;
end
else SubList.Free;
end;
ResultList.Free;
end;
procedure FreeList(var AList: TGDBMINameValueListArray);
var
i : Integer;
begin
for i := low(AList) to high(AList) do
AList[i].Free;
end;
var
Args, Frames: TGDBMINameValueListArray;
i, idx, endidx: Integer;
begin
if Debugger = nil then Exit;
if ACount <= 0 then exit;
endidx := AIndex + ACount - 1;
SetLength(Args, ACount);
PrepareArgs(Args, AIndex, endidx, '-stack-list-arguments 1 %d %d', 'stack-args', 'args');
SetLength(Frames, ACount);
PrepareArgs(Frames, AIndex, endidx, '-stack-list-frames %d %d', 'stack', '');
idx := 0;
for i := AIndex to endidx do
begin
InternalSetEntry(i, InternalCreateEntry(i, Args[idx], Frames[idx]));
inc(idx);
end;
FreeList(Args);
FreeList(Frames);
end;
procedure TGDBMICallStack.SetCurrent(AValue: TCallStackEntry);
begin
TGDBMIDebugger(Debugger).CallStackSetCurrent(AValue.Index);
end;
{ =========================================================================== }
{ TGDBMIExpression }
{ =========================================================================== }
function GetSubExpression(var AExpression: PChar; var ALength: Integer; out AOperator: TDBGExpressionOperator; out AOperand: String): Boolean;
type
TScanState = (
ssNone, // start scanning
ssString, // inside string
ssEndString, // just left a string, we may reenter if another ' is present
ssOperand, // reading operand
ssOperator // delimeter found, next must be operator
);
var
State: TScanState;
function GetOperand(const AOperand: String): String;
begin
if (AOperand = '')
or (AOperand[1] <> '''')
then Result := AOperand
else Result := ConvertToCString(AOperand);
end;
function GetOperator(AOperator: PChar; ALen: Integer): TDBGExpressionOperator;
begin
case AOperator[0] of
'-': Result := eoSubstract;
'+': Result := eoAdd;
'*': begin
if ALen = 1
then Result := eoMultiply
else Result := eoPower;
end;
'/': Result := eoDivide;
'^': Result := eoDereference;
'@': Result := eoAddress;
'=': Result := eoEqual;
'<': begin
if ALen = 1
then Result := eoLess
else if AOperator[1] = '='
then Result := eoLessOrEqual
else Result := eoNotEqual;
end;
'>': begin
if ALen = 1
then Result := eoGreater
else Result := eoGreaterOrEqual;
end;
'.': Result := eoDot;
',': Result := eoComma;
'(': Result := eoBracket;
'[': Result := eoIndex;
')': Result := eoClose;
']': Result := eoClose;
'a', 'A': begin
if AOperator[1] in ['s', 'S']
then Result := eoAs
else Result := eoAnd;
end;
'o', 'O': Result := eoOr;
'i', 'I': begin
if AOperator[1] in ['s', 'S']
then Result := eoIs
else Result := eoIn;
end;
'm', 'M': Result := eoMod;
'n', 'N': Result := eoNot;
'd', 'D': Result := eoDiv;
'x', 'X': Result := eoXor;
's', 'S': begin
if AOperator[2] in ['l', 'L']
then Result := eoShl
else Result := eoShr;
end;
end;
Inc(AExpression, ALen);
Dec(ALength, ALen);
end;
function CheckOperator(const AOperator: String): Boolean;
var
len: Integer;
begin
len := Length(AOperator);
if ALength <= len then Exit(False); // net char after operator too
if not (AExpression[len] in [' ', #9, '(']) then Exit(False);
if StrLIComp(AExpression, @AOperator[1], len) <> 0 then Exit(False);
Result := True;
end;
var
Sub: String;
len: Integer;
begin
while (ALength > 0) and (AExpression^ in [#9, ' ']) do
begin
Dec(ALength);
Inc(AExpression);
end;
if ALength = 0 then Exit;
State := ssNone;
Sub:='';
while ALength > 0 do
begin
if AExpression^ = ''''
then begin
case State of
ssOperand,
ssOperator: Exit(False); //illegal
ssNone: State := ssString;
ssString:State := ssEndString;
ssEndString: State := ssString;
end;
Sub := Sub + AExpression^;
Inc(AExpression);
Dec(ALength);
Continue;
end;
case State of
ssString: begin
Sub := Sub + AExpression^;
Inc(AExpression);
Dec(ALength);
Continue;
end;
ssEndString: State := ssOperator;
ssNone: State := ssOperand;
end;
case AExpression^ of
' ', #9: begin
State := ssOperator;
Inc(AExpression);
Dec(ALength);
Continue;
end;
'(', '[': begin
AOperand := GetOperand(Sub);
AOperator := GetOperator(AExpression, 1);
Exit(True);
end;
')', ']': begin
AOperand := GetOperand(Sub);
AOperator := GetOperator(AExpression, 1);
Exit(True);
end;
'-', '+': begin
if Sub = ''
then begin
//unary
AOperand := '';
if AExpression^ = '-'
then AOperator := eoNegate
else AOperator := eoPlus;
Inc(AExpression);
Dec(ALength);
end
else begin
AOperand := GetOperand(Sub);
end;
Exit(True);
end;
'/', '^', '@', '=', ',': begin
AOperand := GetOperand(Sub);
AOperator := GetOperator(AExpression, 1);
Exit(True);
end;
'*', '<', '>': begin
AOperand := GetOperand(Sub);
if ALength > 1
then begin
if AExpression[0] = '*'
then begin
if AExpression[1] = '*'
then AOperator := GetOperator(AExpression, 2)
else AOperator := GetOperator(AExpression, 1);
end
else begin
if AExpression[1] = '='
then AOperator := GetOperator(AExpression, 2)
else AOperator := GetOperator(AExpression, 1);
end;
end
else AOperator := GetOperator(AExpression, 1);
Exit(True);
end;
'.': begin
if (State <> ssOperand) or (Length(Sub) = 0) or not (Sub[1] in ['0'..'9'])
then begin
AOperand := GetOperand(Sub);
AOperator := GetOperator(AExpression, 1);
Exit(True);
end;
end;
end;
if (State = ssOperator)
then begin
len := 3;
case AExpression^ of
'a', 'A': begin
if not CheckOperator('and') then Exit(False);
if not CheckOperator('as') then Exit(False);
end;
'o', 'O': begin
if not CheckOperator('or') then Exit(False);
len := 2;
end;
'i', 'I': begin
if not CheckOperator('in') then Exit(False);
if not CheckOperator('is') then Exit(False);
end;
'm', 'M': begin
if not CheckOperator('mod') then Exit(False);
end;
'd', 'D': begin
if not CheckOperator('div') then Exit(False);
end;
'x', 'X': begin
if not CheckOperator('xor') then Exit(False);
end;
's', 'S': begin
if not (CheckOperator('shl') or CheckOperator('shr')) then Exit(False);
end;
else
Exit(False);
end;
AOperand := GetOperand(Sub);
AOperator := GetOperator(AExpression, len);
Exit(True);
end;
if (State = ssOperand)
and (Sub = '')
and CheckOperator('not')
then begin
AOperand := '';
AOperator := GetOperator(AExpression, 3);
Exit(True);
end;
Sub := Sub + AExpression^;
Inc(AExpression);
Dec(ALength);
end;
if not (State in [ssOperator, ssOperand, ssEndString]) then Exit(False);
AOperand := GetOperand(Sub);
AOperator := eoNone;
Result := True;
end;
constructor TGDBMIExpression.Create(const AExpression: String);
var
len: Integer;
P: PChar;
Run, Work: PGDBMISubExpression;
Opertor: TDBGExpressionOperator;
Operand: String;
begin
inherited Create;
len := Length(AExpression);
p := PChar(AExpression);
Run := nil;
while (len > 0) and GetSubExpression(p, len, Opertor, Operand) do
begin
New(Work);
Work^.Opertor := Opertor;
Work^.Operand := Operand;
Work^.Prev := Run;
Work^.Next := nil;
if FList = nil
then FList := Work
else Run^.Next := Work;
Run := Work;
end;
end;
destructor TGDBMIExpression.Destroy;
var
Run, Work: PGDBMISubExpression;
begin
Run := FList;
while Run <> nil do
begin
Work := Run;
Run := Work^.Next;
Dispose(Work);
end;
inherited;
end;
procedure TGDBMIExpression.DisposeList(AList: PGDBMIExpressionResult);
var
Temp: PGDBMIExpressionResult;
begin
while AList <> nil do
begin
AList^.Info.Free;
Temp := AList;
AList := Alist^.Next;
Dispose(Temp);
end;
end;
function TGDBMIExpression.DumpExpression: String;
// Mainly used for debugging purposes
const
OPERATOR_TEXT: array[TDBGExpressionOperator] of string = (
'eoNone',
'eoNegate',
'eoPlus',
'eoSubstract',
'eoAdd',
'eoMultiply',
'eoPower',
'eoDivide',
'eoDereference',
'eoAddress',
'eoEqual',
'eoLess',
'eoLessOrEqual',
'eoGreater',
'eoGreaterOrEqual',
'eoNotEqual',
'eoIn',
'eoIs',
'eoAs',
'eoDot',
'eoComma',
'eoBracket',
'eoIndex',
'eoClose',
'eoAnd',
'eoOr',
'eoMod',
'eoNot',
'eoDiv',
'eoXor',
'eoShl',
'eoShr'
);
var
Sub: PGDBMISubExpression;
begin
Result := '';
Sub := FList;
while Sub <> nil do
begin
Result := Result + Sub^.Operand + ' ' + OPERATOR_TEXT[Sub^.Opertor] + ' ';
Sub := Sub^.Next;
end;
end;
function TGDBMIExpression.Evaluate(const ADebugger: TGDBMIDebugger; out AResult: String; out AResultInfo: TGDBType): Boolean;
const
OPER_UNARY = [eoNot, eoNegate, eoPlus, eoAddress, eoBracket];
var
Sub: PGDBMISubExpression;
R: PGDBMIExpressionResult;
begin
Result := True;
Sub := FList;
FStack := nil;
FStackPtr := nil;
New(R);
FillByte(R^, SizeOf(R^), 0);
while Sub <> nil do
begin
R^.Opertor := Sub^.Opertor;
if Sub^.Operand = ''
then begin
if not (Sub^.OperTor in OPER_UNARY)
then begin
// check if we have a 2nd operator
Result := False;
if FStackPtr = nil then Break;
case FStackPtr^.OperTor of
eoClose, eoDereference: begin
if not (Sub^.OperTor in [eoDot, eoDereference, eoIndex]) then Break;
end;
eoBracket: begin
if Sub^.OperTor <> eoBracket then Break;
end;
end;
Result := True;
end;
Push(R);
Sub := Sub^.Next;
Continue;
end;
if Sub^.OperTor in OPER_UNARY then Break;
if (FStackPtr = nil)
or (OPER_LEVEL[Sub^.OperTor] < OPER_LEVEL[FStackPtr^.OperTor])
then begin
if not Evaluate(ADebugger, Sub^.Operand, R^.Value, R^.Info)
then begin
Result := False;
Break;
end;
end
else begin
if not Solve(ADebugger, OPER_LEVEL[Sub^.OperTor], Sub^.Operand, R^.Value, R^.Info)
then begin
Result := False;
Break;
end;
end;
Push(R);
Sub := Sub^.Next;
end;
if Result and (FStackPtr <> nil)
then begin
New(R);
FillByte(R^, SizeOf(R^), 0);
Result := Solve(ADebugger, 255, '', R^.Value, R^.Info);
Push(R); // make sure it gets cleaned later
end;
if Result
then begin
AResult := R^.Value;
AResultInfo := R^.Info;
R^.Info := nil;
end;
while FStackPtr <> nil do
begin
Pop(R);
R^.Info.Free;
Dispose(R);
end;
end;
function TGDBMIExpression.Evaluate(const ADebugger: TGDBMIDebugger; const AText: String; out AResult: String; out AResultInfo: TGDBType): Boolean;
var
R: TGDBMIExecResult;
ResultList: TGDBMINameValueList;
begin
// special cases
if ATExt = ''
then begin
AResult := '';
AResultInfo := nil;
Exit(True);
end;
if AText = '""'
then begin
AResult := '0x0';
AResultInfo := TGDBType.CreateFromValues('type = ^character');
Exit(True);
end;
Result := ADebugger.ExecuteCommand('-data-evaluate-expression %s', [AText], [cfIgnoreError, cfExternal], R)
and (R.State <> dsError);
ResultList := TGDBMINameValueList.Create(R);
if R.State = dsError
then AResult := ResultList.Values['msg']
else AResult := ResultList.Values['value'];
// AResult := DeleteEscapeChars(AResult);
ResultList.Free;
if Result
then AResultInfo := ADebugger.GetGDBTypeInfo(AText)
else AResultInfo := nil;
if AResultInfo = nil then Exit;
//post format some results (for inscance a char is returned as "ord 'Value'"
if AResultInfo.Kind <> skSimple then Exit;
case StringCase(AResultInfo.TypeName, ['character'], true, false) of
0: AResult := GetPart([' '], [], AResult);
end;
end;
procedure TGDBMIExpression.Pop(var AResult: PGDBMIExpressionResult);
begin
AResult := FStackPtr;
if AResult = nil then Exit;
FStackPtr := AResult^.Prev;
if FStackPtr = nil
then FStack := nil;
AResult^.Next := nil;
AResult^.Prev := nil;
end;
procedure TGDBMIExpression.Push(var AResult: PGDBMIExpressionResult);
begin
if FStack = nil
then begin
FStack := AResult;
FStackPtr := AResult;
end
else begin
FStackPtr^.Next := AResult;
AResult^.Prev := FStackPtr;
FStackPtr := AResult;
end;
New(AResult);
FillByte(AResult^, SizeOf(AResult^), 0);
end;
function TGDBMIExpression.Solve(const ADebugger: TGDBMIDebugger; ALimit: Byte; const ARight: String; out AValue: String; out AInfo: TGDBType): Boolean;
var
StartPtr, Left: PGDBMIExpressionResult;
Right: TGDBMIExpressionResult;
Value: String;
Info: TGDBType;
begin
StartPtr := FStackPtr;
while (ALimit >= OPER_LEVEL[StartPtr^.OperTor]) and (StartPtr^.Prev <> nil) do
StartPtr := StartPtr^.Prev;
// we will solve this till end of stack
FStackPtr := StartPtr^.Prev;
if FStackPtr = nil
then FStack := nil
else FStackPtr^.Next := nil;
StartPtr^.Prev := nil;
Left := StartPtr;
FillChar(Right, SizeOf(Right), 0);
repeat
Info := nil;
Value := '';
case Left^.Opertor of
eoNone: begin
// only posible as first and only item on stack
Result := (FStackPtr = nil) and (Left = StartPtr) and (ARight = '');
if Result
then begin
Value := Left^.Value;
Info := Left^.Info;
Left^.Info := nil;
end;
end;
eoNegate, eoPlus, eoSubstract, eoAdd,
eoMultiply, eoPower, eoDivide, eoEqual,
eoLess, eoLessOrEqual, eoGreater, eoGreaterOrEqual,
eoNotEqual, eoAnd, eoOr, eoMod,
eoNot, eoDiv, eoXor, eoShl,
eoShr: begin
if Left^.Next = nil
then begin
Result := Evaluate(ADebugger, ARight, Right.Value, Right.Info)
and SolveMath(ADebugger, Left, @Right, Value, Info);
FreeAndNil(Right.Info);
end
else Result := SolveMath(ADebugger, Left, Left^.Next, Value, Info);
end;
eoDereference: begin
Result := (ARight = '') // right part cant have value
and SolveDeref(ADebugger, Left, Value, Info);
end;
eoAddress: begin
Result := (Left^.Info = nil);
if not Result then Break;
if Left^.Next = nil
then begin
Result := Evaluate(ADebugger, ARight, Right.Value, Right.Info)
and SolveAddress(ADebugger, @Right, Value, Info);
FreeAndNil(Right.Info);
end
else Result := SolveIn(ADebugger, Left, Left^.Next, Value, Info);
end;
eoDot: begin
// its impossible to have next already resolved. Its a member of left
Result := (Left^.Next = nil) and SolveDot(ADebugger, Left, ARight, Value, Info);
end;
// eoComma: begin
// end;
eoBracket: begin
Result := Evaluate(ADebugger, ARight, Value, Info);
// we can finish when closed
end;
eoIndex: begin
if Left^.Info = nil
then begin
// only possible when part of "in"
Result := (Left^.Prev <> nil)
and (Left^.Prev^.OperTor = eoIn)
and Evaluate(ADebugger, ARight, Value, Info);
end
else begin
Result := Evaluate(ADebugger, ARight, Value, Info);
// we can finish when closed
end;
end;
eoIn: begin
if Left^.Next = nil
then begin
Result := Evaluate(ADebugger, ARight, Right.Value, Right.Info)
and SolveIn(ADebugger, Left, @Right, Value, Info);
FreeAndNil(Right.Info);
end
else Result := SolveIn(ADebugger, Left, Left^.Next, Value, Info);
end;
eoIs: begin
if Left^.Next = nil
then begin
Result := Evaluate(ADebugger, ARight, Right.Value, Right.Info)
and SolveIs(ADebugger, Left, @Right, Value, Info);
FreeAndNil(Right.Info);
end
else Result := SolveIs(ADebugger, Left, Left^.Next, Value, Info);
end;
eoAs: begin
if Left^.Next = nil
then begin
Result := Evaluate(ADebugger, ARight, Right.Value, Right.Info)
and SolveAs(ADebugger, Left, @Right, Value, Info);
FreeAndNil(Right.Info);
end
else Result := SolveAs(ADebugger, Left, Left^.Next, Value, Info);
end;
else
Result := False;
end;
if not Result then Break;
if Left^.Next = nil then Break;
Left := Left^.Next;
Left^.Info.Free;
Left^.Info := Info;
Left^.Value := Value;
until False;
DisposeList(StartPtr);
if Result
then begin
AValue := Value;
AInfo := Info;
end
else begin
AValue := '';
AInfo := nil;
end;
end;
function TGDBMIExpression.SolveAddress(const ADebugger: TGDBMIDebugger; ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
begin
Result := False;
end;
function TGDBMIExpression.SolveAs(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
begin
Result := False;
end;
function TGDBMIExpression.SolveDeref(const ADebugger: TGDBMIDebugger; ALeft: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
var
Eval: String;
begin
Result := ALeft^.Info.Kind = skPointer;
if not Result then Exit;
Eval := '^' + ALeft^.Info.TypeName + '(' + ALeft^.Value + ')^';
Result := Evaluate(ADebugger, Eval, AValue, AInfo);
end;
function TGDBMIExpression.SolveDot(const ADebugger: TGDBMIDebugger; ALeft: PGDBMIExpressionResult; const ARight: String; out AValue: String; out AInfo: TGDBType): Boolean;
var
Prefix: String;
begin
if not (ALeft^.Info.Kind in [skClass, skRecord]) then Exit(False);
Prefix := '^' + ALeft^.Info.TypeName + '(' + ALeft^.Value + ')^.';
Result := Evaluate(ADebugger, Prefix + ARight, AValue, AInfo);
if Result then Exit;
// maybe property
Result := Evaluate(ADebugger, Prefix + 'F' + ARight, AValue, AInfo);
//todo: method call
end;
function TGDBMIExpression.SolveIn(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
begin
Result := False;
end;
function TGDBMIExpression.SolveIs(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
begin
Result := False;
end;
function TGDBMIExpression.SolveMath(const ADebugger: TGDBMIDebugger; ALeft, ARight: PGDBMIExpressionResult; out AValue: String; out AInfo: TGDBType): Boolean;
const
OPERATOR_TEXT: array[TDBGExpressionOperator] of string = (
{eoNone } '',
{eoNegate } '-',
{eoPlus } '',
{eoSubstact } '-',
{eoAdd } '+',
{eoMultiply } '*',
{eoPower } '',
{eoDivide } '/',
{eoDereference } '',
{eoAddress } '',
{eoEqual } '=',
{eoLess } '<',
{eoLessOrEqual } '<=',
{eoGreater } '>',
{eoGreaterOrEqual } '>=',
{eoNotEqual } '<>',
{eoIn } '',
{eoIs } '',
{eoAs } '',
{eoDot } '',
{eoComma } '',
{eoBracket } '',
{eoIndex } '',
{eoClose } '',
{eoAnd } 'and',
{eoOr } 'or',
{eoMod } 'mod',
{eoNot } 'not',
{eoDiv } 'div',
{eoXor } 'xor',
{eoShl } 'shl',
{eoShr } 'shr'
);
var
Eval: String;
begin
case ALeft^.Opertor of
eoAnd, eoOr, eoMod, eoNot,
eoDiv, eoXor, eoShl, eoShr: begin
Eval := '(' + ALeft^.Value + ')' + OPERATOR_TEXT[ALeft^.Opertor] + '(' + ARight^.Value + ')';
end
else
Eval := ALeft^.Value + OPERATOR_TEXT[ALeft^.Opertor] + ARight^.Value;
end;
Result := Evaluate(ADebugger, Eval, AValue, AInfo);
end;
{ TGDBMIType }
constructor TGDBMIType.CreateFromResult(const AResult: TGDBMIExecResult);
begin
// TODO: add check ?
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);
end.
Reference in New Issue View Git Blame Copy Permalink