1{ $Id: gdbmidebugger.pp 63916 2020-09-24 05:28:24Z martin $ }
2{                        ----------------------------------------------
3                         GDBDebugger.pp  -  Debugger class forGDB
4                         ----------------------------------------------
5
6 @created(Wed Feb 23rd WET 2002)
7 @lastmod($Date: 2020-09-24 07:28:24 +0200 (Do, 24 Sep 2020) $)
8 @author(Marc Weustink <marc@@lazarus.dommelstein.net>)
9
10 This unit contains debugger class for the GDB/MI debugger.
11
12
13 ***************************************************************************
14 *                                                                         *
15 *   This source is free software; you can redistribute it and/or modify   *
16 *   it under the terms of the GNU General Public License as published by  *
17 *   the Free Software Foundation; either version 2 of the License, or     *
18 *   (at your option) any later version.                                   *
19 *                                                                         *
20 *   This code is distributed in the hope that it will be useful, but      *
21 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
22 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
23 *   General Public License for more details.                              *
24 *                                                                         *
25 *   A copy of the GNU General Public License is available on the World    *
26 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
27 *   obtain it by writing to the Free Software Foundation,                 *
28 *   Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.   *
29 *                                                                         *
30 ***************************************************************************
31}
32unit GDBMIDebugger;
33
34{$mode objfpc}
35{$ifdef WIN64}{$MODESWITCH ADVANCEDRECORDS}{$endif}
36{$H+}
37
38{$ifndef VER2}
39  {$define disassemblernestedproc}
40{$endif VER2}
41
42{$ifdef disassemblernestedproc}
43  {$modeswitch nestedprocvars}
44{$endif disassemblernestedproc}
45
46{$IFDEF linux} {$DEFINE DBG_ENABLE_TERMINAL} {$ENDIF}
47
48interface
49
50uses
51{$IFdef MSWindows}
52  Windows,
53{$ENDIF}
54{$IFDEF UNIX}
55   Unix,BaseUnix,termio,
56{$ENDIF}
57  Classes, SysUtils, strutils, math, {$ifdef WIN64}fgl,{$endif} Variants,
58  // LCL
59  Controls, Dialogs, Forms,
60  LCLProc,
61  // LazUtils
62  FileUtil, LazUTF8, LazClasses, LazLoggerBase, Maps,
63  // IdeIntf
64  BaseIDEIntf,
65  {$IFDEF Darwin}
66  LazFileUtils,
67  {$ENDIF}
68  DebugUtils, GDBTypeInfo, GDBMIDebugInstructions, GDBMIMiscClasses,
69  DbgIntfBaseTypes, DbgIntfDebuggerBase, DbgIntfPseudoTerminal, GdbmiStringConstants;
70
71type
72  TGDBMIProgramInfo = record
73    State: TDBGState;
74    BreakPoint: Integer; // ID of Breakpoint hit
75    Signal: Integer;     // Signal no if we hit one
76    SignalText: String;  // Signal text if we hit one
77  end;
78
79  // The internal ExecCommand of the new Commands (object queue)
80  TGDBMICommandFlag = (
81    cfCheckState, // Copy CmdResult to DebuggerState, EXCEPT dsError,dsNone (e.g copy dsRun, dsPause, dsStop, dsIdle)
82    cfCheckError, // Copy CmdResult to DebuggerState, ONLY if dsError
83    cfTryAsync,   // try with " &"
84    cfNoThreadContext,
85    cfNoStackContext,
86    //used for old commands, TGDBMIDebuggerSimpleCommand.Create
87    cfscIgnoreState, // ignore the result state of the command
88    cfscIgnoreError  // ignore errors
89  );
90  TGDBMICommandFlags = set of TGDBMICommandFlag;
91
92
93  TGDBMICallback = procedure(const AResult: TGDBMIExecResult; const ATag: PtrInt) of object;
94  TGDBMIPauseWaitState = (pwsNone, pwsInternal, pwsExternal);
95
96  TGDBMITargetFlag = (
97    tfHasSymbols,     // Debug symbols are present
98    tfRTLUsesRegCall, // the RTL is compiled with RegCall calling convention
99    tfClassIsPointer,  // with dwarf class names are pointer. with stabs they are not
100    tfExceptionIsPointer, // Can happen, if stabs and dwarf are mixed
101    tfFlagHasTypeObject,
102    tfFlagHasTypeException,
103    tfFlagHasTypeShortstring,
104    //tfFlagHasTypePShortString,
105    tfFlagHasTypePointer,
106    tfFlagHasTypeByte
107    //tfFlagHasTypeChar
108  );
109  TGDBMITargetFlags = set of TGDBMITargetFlag;
110
111  TGDBMIDebuggerFlags = set of (
112    dfImplicidTypes,     // Debugger supports implicit types (^Type)
113    dfForceBreak,        // Debugger supports insertion of not yet known brekpoints
114    dfForceBreakDetected,
115    dfSetBreakFailed,
116    dfSetBreakPending
117  );
118
119  // Target info
120  TGDBMITargetInfo = record
121    TargetPID: Integer;
122    TargetFlags: TGDBMITargetFlags;
123    TargetCPU: String;
124    TargetOS: (osUnknown, osWindows); // osUnix or osLinux, osMac
125    TargetRegisters: array[0..2] of String;
126    TargetPtrSize: Byte; // size in bytes
127    TargetIsBE: Boolean;
128  end;
129  PGDBMITargetInfo = ^TGDBMITargetInfo;
130
131  TConvertToGDBPathType = (cgptNone, cgptCurDir, cgptExeName);
132
133  TGDBMIDebuggerFilenameEncoding = (
134    gdfeNone, gdfeDefault, gdfeEscSpace, gdfeQuote
135  );
136  TGDBMIDebuggerStartBreak = (
137    gdsbDefault, gdsbEntry, gdsbMainAddr, gdsbMain, gdsbAddZero
138  );
139  TGDBMIUseNoneMiRunCmdsState = (
140    gdnmNever, gdnmAlways, gdnmFallback
141  );
142  TGDBMIWarnOnSetBreakpointError = (
143    gdbwNone, gdbwAll, gdbwUserBreakPoint, gdbwExceptionsAndRunError
144  );
145  TGDBMIDebuggerCaseSensitivity = (
146    gdcsSmartOff, gdcsAlwaysOff, gdcsAlwaysOn, gdcsGdbDefault
147  );
148  TGDBMIDebuggerAssemblerStyle = (
149    gdasDefault, gdasIntel, gdasATT
150  );
151
152  {$scopedenums on}
153  TGDBMIDebuggerShowWarning = ( // need true/false to read old config
154    True, False, OncePerRun
155  );
156  {$scopedenums off}
157
158  { TGDBMIDebuggerPropertiesBase }
159
160  TGDBMIDebuggerPropertiesBase = class(TDebuggerProperties)
161  private
162    FAssemblerStyle: TGDBMIDebuggerAssemblerStyle;
163    FCaseSensitivity: TGDBMIDebuggerCaseSensitivity;
164    FDisableForcedBreakpoint: Boolean;
165    FDisableLoadSymbolsForLibraries: Boolean;
166    FDisableStartupShell: Boolean;
167    FEncodeCurrentDirPath: TGDBMIDebuggerFilenameEncoding;
168    FEncodeExeFileName: TGDBMIDebuggerFilenameEncoding;
169    FFixIncorrectStepOver: Boolean;
170    FFixStackFrameForFpcAssert: Boolean;
171    FGdbLocalsValueMemLimit: Integer;
172    {$IFDEF UNIX}
173    FConsoleTty: String;
174    {$ENDIF}
175    FGDBOptions: String;
176    FGdbValueMemLimit: Integer;
177    FInternalStartBreak: TGDBMIDebuggerStartBreak;
178    FMaxDisplayLengthForStaticArray: Integer;
179    FMaxDisplayLengthForString: Integer;
180    FMaxLocalsLengthForStaticArray: Integer;
181    FTimeoutForEval: Integer;
182    FUseAsyncCommandMode: Boolean;
183    FUseNoneMiRunCommands: TGDBMIUseNoneMiRunCmdsState;
184    FWarnOnSetBreakpointError: TGDBMIWarnOnSetBreakpointError;
185    FWarnOnInternalError: TGDBMIDebuggerShowWarning;
186    FWarnOnTimeOut: Boolean;
187    procedure SetGdbLocalsValueMemLimit(AValue: Integer);
188    procedure SetMaxDisplayLengthForStaticArray(AValue: Integer);
189    procedure SetMaxDisplayLengthForString(AValue: Integer);
190    procedure SetMaxLocalsLengthForStaticArray(AValue: Integer);
191    procedure SetTimeoutForEval(const AValue: Integer);
192    procedure SetWarnOnTimeOut(const AValue: Boolean);
193  public
194    constructor Create; override;
195    procedure Assign(Source: TPersistent); override;
196  public
197    property Debugger_Startup_Options: String read FGDBOptions write FGDBOptions;
198    {$IFDEF UNIX}
199    property ConsoleTty: String read FConsoleTty write FConsoleTty;
200    {$ENDIF}
201    property MaxDisplayLengthForString: Integer read FMaxDisplayLengthForString write SetMaxDisplayLengthForString default 2500;
202    property MaxDisplayLengthForStaticArray: Integer read FMaxDisplayLengthForStaticArray write SetMaxDisplayLengthForStaticArray default 500;
203    property MaxLocalsLengthForStaticArray: Integer read FMaxLocalsLengthForStaticArray write SetMaxLocalsLengthForStaticArray default 25;
204    property TimeoutForEval: Integer read FTimeoutForEval write SetTimeoutForEval;
205    property WarnOnTimeOut: Boolean  read FWarnOnTimeOut write SetWarnOnTimeOut;
206    property WarnOnInternalError: TGDBMIDebuggerShowWarning
207             read FWarnOnInternalError write FWarnOnInternalError default TGDBMIDebuggerShowWarning.OncePerRun;
208    property EncodeCurrentDirPath: TGDBMIDebuggerFilenameEncoding
209             read FEncodeCurrentDirPath write FEncodeCurrentDirPath default gdfeDefault;
210    property EncodeExeFileName: TGDBMIDebuggerFilenameEncoding
211             read FEncodeExeFileName write FEncodeExeFileName default gdfeDefault;
212    property InternalStartBreak: TGDBMIDebuggerStartBreak
213             read FInternalStartBreak write FInternalStartBreak default gdsbDefault;
214    property UseAsyncCommandMode: Boolean read FUseAsyncCommandMode write FUseAsyncCommandMode;
215    property UseNoneMiRunCommands: TGDBMIUseNoneMiRunCmdsState
216             read FUseNoneMiRunCommands write FUseNoneMiRunCommands default gdnmFallback;
217    property CaseSensitivity: TGDBMIDebuggerCaseSensitivity
218             read FCaseSensitivity write FCaseSensitivity default gdcsSmartOff;
219    property DisableLoadSymbolsForLibraries: Boolean read FDisableLoadSymbolsForLibraries
220             write FDisableLoadSymbolsForLibraries default False;
221    property DisableForcedBreakpoint: Boolean read FDisableForcedBreakpoint
222             write FDisableForcedBreakpoint default False;
223    property WarnOnSetBreakpointError: TGDBMIWarnOnSetBreakpointError read FWarnOnSetBreakpointError
224             write FWarnOnSetBreakpointError default gdbwAll;
225    property GdbValueMemLimit: Integer read FGdbValueMemLimit write FGdbValueMemLimit default $60000000;
226    property GdbLocalsValueMemLimit: Integer read FGdbLocalsValueMemLimit write SetGdbLocalsValueMemLimit default 32000;
227    property AssemblerStyle: TGDBMIDebuggerAssemblerStyle read FAssemblerStyle write FAssemblerStyle default gdasDefault;
228    property DisableStartupShell: Boolean read FDisableStartupShell
229             write FDisableStartupShell default False;
230    property FixStackFrameForFpcAssert: Boolean read FFixStackFrameForFpcAssert
231             write FFixStackFrameForFpcAssert default True;
232    property FixIncorrectStepOver: Boolean read FFixIncorrectStepOver write FFixIncorrectStepOver default False;
233  end;
234
235  TGDBMIDebuggerProperties = class(TGDBMIDebuggerPropertiesBase)
236  published
237    property Debugger_Startup_Options;
238    {$IFDEF UNIX}
239    property ConsoleTty;
240    {$ENDIF}
241    property MaxDisplayLengthForString;
242    property MaxDisplayLengthForStaticArray;
243    property MaxLocalsLengthForStaticArray;
244    property TimeoutForEval;
245    property WarnOnTimeOut;
246    property WarnOnInternalError;
247    property EncodeCurrentDirPath;
248    property EncodeExeFileName;
249    property InternalStartBreak;
250    property UseAsyncCommandMode;
251    property UseNoneMiRunCommands;
252    property DisableLoadSymbolsForLibraries;
253    property DisableForcedBreakpoint;
254    //property WarnOnSetBreakpointError;
255    property CaseSensitivity;
256    property GdbValueMemLimit;
257    property GdbLocalsValueMemLimit;
258    property AssemblerStyle;
259    property DisableStartupShell;
260    property FixStackFrameForFpcAssert;
261    property FixIncorrectStepOver;
262  end;
263
264  TGDBMIDebugger = class;
265  TGDBMIDebuggerCommand = class;
266
267  { TGDBMIDebuggerInstruction }
268
269  TGDBMIDebuggerInstruction = class(TGDBInstruction)
270  private
271    FCmd: TGDBMIDebuggerCommand;
272    FFullCmdReply: String;
273    FHasResult: Boolean;
274    FInLogWarning: Boolean;
275    FLogWarnings: String;
276    FResultData: TGDBMIExecResult;
277  protected
278    function ProcessInputFromGdb(const AData: String): Boolean; override;
279    function GetTimeOutVerifier: TGDBInstruction; override;
280    procedure Init; override;
281  public
282    procedure HandleNoGdbRunning; override;
283    procedure HandleReadError; override;
284    procedure HandleTimeOut; override;
285    property ResultData: TGDBMIExecResult read FResultData;
286    property HasResult: Boolean read FHasResult; // seen a "^foo" msg from gdb
287    property FullCmdReply: String read FFullCmdReply;
288    property LogWarnings: String read FLogWarnings;
289    property Cmd: TGDBMIDebuggerCommand read FCmd write FCmd;
290  end;
291
292  { TGDBMIDbgInstructionQueue }
293
294  TGDBMIDbgInstructionQueue = class(TGDBInstructionQueue)
295  protected
296    procedure HandleGdbDataBeforeInstruction(var AData: String; var SkipData: Boolean;
297      const TheInstruction: TGDBInstruction); override;
298    function Debugger: TGDBMIDebugger; reintroduce;
299  end;
300
301  { TGDBMIDebuggerCommand }
302
303  TGDBMIDebuggerCommandState =
304    ( dcsNone,         // Initial State
305      dcsQueued,       // [None] => Queued behind other commands
306      dcsExecuting,    // [None, Queued] => currently running
307      // Final States, those lead to the object being freed, unless it still is referenced (Add/Release-Reference)
308      dcsFinished,     // [Executing] => Finished Execution
309      dcsCanceled,     // [Queued] => Never Executed
310      // Flags, for Seenstates
311      dcsInternalRefReleased // The internal reference has been released
312    );
313  TGDBMIDebuggerCommandStates = set of TGDBMIDebuggerCommandState;
314
315  TGDBMIDebuggerCommandProperty = (dcpCancelOnRun);
316  TGDBMIDebuggerCommandProperts = set of TGDBMIDebuggerCommandProperty;
317
318  TGDBMIExecCommandType =
319    ( ectNone,
320      ectContinue,         // -exec-continue
321      ectRun,              // -exec-run
322      ectRunTo,            // -exec-until [Source, Line]
323      ectStepOver,         // -exec-next
324      ectStepOut,          // -exec-finish
325      ectStepInto,         // -exec-step
326      // not yet used
327      ectStepOverInstruction,  // -exec-next-instruction
328      ectStepIntoInstruction,  // -exec-step-instruction
329      ectReturn            // -exec-return (step out immediately, skip execution)
330    );
331
332  TGDBMIBreakpointReason = (gbrBreak, gbrWatchTrigger, gbrWatchScope);
333
334  TGDBMIProcessResultOpt = (
335    prNoLeadingTab,      // Do not require/strip the leading #9
336    prKeepBackSlash,    // Workaround, backslash may have been removed already
337
338    // for structures
339    prStripAddressFromString,
340    prMakePrintAble
341  );
342  TGDBMIProcessResultOpts = set of TGDBMIProcessResultOpt;
343
344  TGDBMICommandContextKind = (ccNotRequired, ccUseGlobal, ccUseLocal);
345  TGDBMICommandContext = record
346    ThreadContext: TGDBMICommandContextKind;
347    ThreadId: Integer;
348    StackContext: TGDBMICommandContextKind;
349    StackFrame: Integer;
350  end;
351
352  TGDBMIDebuggerCommand = class(TRefCountedObject)
353  private
354    FDefaultTimeOut: Integer;
355    FLastExecwasTimeOut: Boolean;
356    FOnCancel: TNotifyEvent;
357    FOnDestroy: TNotifyEvent;
358    FOnExecuted: TNotifyEvent;
359    FPriority: Integer;
360    FProcessResultTimedOut: Boolean;
361    FProperties: TGDBMIDebuggerCommandProperts;
362    FQueueRunLevel: Integer;
363    FState : TGDBMIDebuggerCommandState;
364    FSeenStates: TGDBMIDebuggerCommandStates;
365    FLastExecCommand: String;
366    FLastExecResult: TGDBMIExecResult; // deprecated;
367    FLogWarnings, FFullCmdReply: String;
368    FGotStopped: Boolean; // used in ProcessRunning
369    function GetDebuggerProperties: TGDBMIDebuggerPropertiesBase;
370    function GetDebuggerState: TDBGState;
371    function GetTargetInfo: PGDBMITargetInfo;
372  protected
373    FTheDebugger: TGDBMIDebugger; // Set during Execute
374    FContext: TGDBMICommandContext;
375    function  ContextThreadId: Integer;   // does not check validy, only ccUseGlobal or ccUseLocal
376    function  ContextStackFrame: Integer; // does not check validy, only ccUseGlobal or ccUseLocal
377    procedure CopyGlobalContextToLocal;
378
379    procedure SetDebuggerState(const AValue: TDBGState);
380    procedure SetDebuggerErrorState(const AMsg: String; const AInfo: String = '');
381    function  ErrorStateMessage: String; virtual;
382    function  ErrorStateInfo: String; virtual;
383    property  DebuggerState: TDBGState read GetDebuggerState;
384    property  DebuggerProperties: TGDBMIDebuggerPropertiesBase read GetDebuggerProperties;
385    property  TargetInfo: PGDBMITargetInfo read GetTargetInfo;
386  protected
387    procedure SetCommandState(NewState: TGDBMIDebuggerCommandState);
388    procedure DoStateChanged({%H-}OldState: TGDBMIDebuggerCommandState); virtual;
389    procedure DoLockQueueExecute; virtual;
390    procedure DoUnLockQueueExecute; virtual;
391    procedure DoLockQueueExecuteForInstr; virtual;
392    procedure DoUnLockQueueExecuteForInstr; virtual;
393    function  DoExecute: Boolean; virtual; abstract;
394    procedure DoOnExecuted;
395    procedure DoCancel; virtual;
396    procedure DoOnCanceled;
397    property  SeenStates: TGDBMIDebuggerCommandStates read FSeenStates;
398    property  QueueRunLevel: Integer read FQueueRunLevel write FQueueRunLevel;  // if queue is nested
399  protected
400    // ExecuteCommand does execute direct. It does not use the queue
401    function  ExecuteCommand(const ACommand: String;
402                             AFlags: TGDBMICommandFlags = [];
403                             ATimeOut: Integer = -1
404                            ): Boolean; overload;
405    function  ExecuteCommand(const ACommand: String;
406                             out AResult: TGDBMIExecResult;
407                             AFlags: TGDBMICommandFlags = [];
408                             ATimeOut: Integer = -1
409                            ): Boolean; overload;
410    function  ExecuteCommand(const ACommand: String; const AValues: array of const;
411                             AFlags: TGDBMICommandFlags;
412                             ATimeOut: Integer = -1
413                            ): Boolean; overload;
414    function  ExecuteCommand(const ACommand: String; const AValues: array of const;
415                             out AResult: TGDBMIExecResult;
416                             AFlags: TGDBMICommandFlags = [];
417                             ATimeOut: Integer = -1
418                            ): Boolean; overload;
419    procedure DoTimeoutFeedback;
420    function  ProcessGDBResultStruct(S: String; Opts: TGDBMIProcessResultOpts = []): String; // Must have at least one flag for structs
421    function  ProcessGDBResultText(S: String; Opts: TGDBMIProcessResultOpts = []): String;
422    function  GetStackDepth(MaxDepth: integer): Integer;
423    function  FindStackFrame(FP: TDBGPtr; StartAt, MaxDepth: Integer): Integer;
424    function  GetFrame(const AIndex: Integer): String;
425    function  GetText(const ALocation: TDBGPtr): String; overload;
426    function  GetText(const AExpression: String; const AValues: array of const): String; overload;
427    function  GetChar(const AExpression: String; const AValues: array of const): String; overload;
428    function  GetFloat(const AExpression: String; const AValues: array of const): String;
429    function  GetWideText(const ALocation: TDBGPtr): String;
430    function  GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False;
431                             AFlags: TGDBTypeCreationFlags = [];
432                             {%H-}AFormat: TWatchDisplayFormat = wdfDefault;
433                             ARepeatCount: Integer = 0): TGDBType;
434    function  GetClassName(const AClass: TDBGPtr): String; overload;
435    function  GetClassName(const AExpression: String; const AValues: array of const): String; overload;
436    function  GetInstanceClassName(const AInstance: TDBGPtr): String; overload;
437    function  GetInstanceClassName(const AExpression: String; const AValues: array of const): String; overload;
438    function  GetData(const ALocation: TDbgPtr): TDbgPtr; overload;
439    function  GetData(const AExpression: String; const AValues: array of const): TDbgPtr; overload;
440    function  GetStrValue(const AExpression: String; const AValues: array of const): String;
441    function  GetIntValue(const AExpression: String; const AValues: array of const): Integer;
442    function  GetPtrValue(const AExpression: String; const AValues: array of const; {%H-}ConvertNegative: Boolean = False): TDbgPtr;
443    function  CheckHasType(TypeName: String; TypeFlag: TGDBMITargetFlag): TGDBMIExecResult;
444    function  PointerTypeCast: string;
445    function  FrameToLocation(const AFrame: String = ''): TDBGLocationRec;
446    procedure ProcessFrame(ALocation: TDBGLocationRec; ASeachStackForSource: Boolean = True); overload;
447    procedure ProcessFrame(const AFrame: String = ''; ASeachStackForSource: Boolean = True); overload;
448    procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String);
449    property  LastExecResult: TGDBMIExecResult read FLastExecResult;
450    property  DefaultTimeOut: Integer read FDefaultTimeOut write FDefaultTimeOut;
451    property  ProcessResultTimedOut: Boolean read FProcessResultTimedOut;       // single gdb command, took to long.Used to trigger timeout detection
452    property  LastExecwasTimeOut: Boolean read FLastExecwasTimeOut;             // timeout, was confirmed (additional commands send and returned)
453  public
454    constructor Create(AOwner: TGDBMIDebugger);
455    destructor Destroy; override;
456    // DoQueued:   Called if queued *behind* others
457    procedure DoQueued;
458    // DoFinished: Called after processing is done
459    //             defaults to Destroy the object
460    procedure DoFinished;
461    function  Execute: Boolean;
462    procedure Cancel;
463    function  KillNow: Boolean; virtual;
464
465    function  DebugText: String; virtual;
466    property  State: TGDBMIDebuggerCommandState read FState;
467    property  OnExecuted: TNotifyEvent read FOnExecuted write FOnExecuted;
468    property  OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
469    property  OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
470    property  Priority: Integer read FPriority write FPriority;
471    property  Properties: TGDBMIDebuggerCommandProperts read FProperties write FProperties;
472  end;
473
474  { TGDBMIDebuggerCommandList }
475
476  TGDBMIDebuggerCommandList = class(TRefCntObjList)
477  private
478    function Get(Index: Integer): TGDBMIDebuggerCommand;
479    procedure Put(Index: Integer; const AValue: TGDBMIDebuggerCommand);
480  public
481    property Items[Index: Integer]: TGDBMIDebuggerCommand read Get write Put; default;
482  end;
483
484  {%region       *****  TGDBMIDebuggerCommands  *****   }
485
486  { TGDBMIDebuggerSimpleCommand }
487
488  // not to be used for anything that runs/steps the app
489  TGDBMIDebuggerSimpleCommand = class(TGDBMIDebuggerCommand)
490  private
491    FCommand: String;
492    FFlags: TGDBMICommandFlags;
493    FCallback: TGDBMICallback;
494    FTag: PtrInt;
495    FResult: TGDBMIExecResult;
496  protected
497    function  DoExecute: Boolean; override;
498  public
499    constructor Create(AOwner: TGDBMIDebugger;
500                       const ACommand: String;
501                       const AValues: array of const;
502                       const AFlags: TGDBMICommandFlags;
503                       const ACallback: TGDBMICallback;
504                       const ATag: PtrInt);
505    function  DebugText: String; override;
506    property  Result: TGDBMIExecResult read FResult;
507  end;
508
509  { TGDBMIDebuggerCommandInitDebugger }
510
511  TGDBMIDebuggerCommandInitDebugger = class(TGDBMIDebuggerCommand)
512  protected
513    FSuccess: Boolean;
514    function DoSetInternalError: Boolean;
515    function  DoExecute: Boolean; override;
516  public
517    property Success: Boolean read FSuccess;
518  end;
519
520  { TGDBMIDebuggerChangeFilenameBase }
521
522  TGDBMIDebuggerChangeFilenameBase = class(TGDBMIDebuggerCommand)
523  protected
524    FErrorMsg: String;
525    function DoChangeFilename: Boolean;
526    function DoSetPascal: Boolean;
527    function DoSetCaseSensitivity: Boolean;
528    function DoSetMaxValueMemLimit: Boolean;
529    function DoSetAssemblerStyle: Boolean;
530    function DoSetDisableStartupShell: Boolean;
531  end;
532
533  { TGDBMIDebuggerCommandChangeFilename }
534
535  TGDBMIDebuggerCommandChangeFilename = class(TGDBMIDebuggerChangeFilenameBase)
536  private
537    FSuccess: Boolean;
538    FFileName: String;
539  protected
540    function  DoExecute: Boolean; override;
541  public
542    constructor Create(AOwner: TGDBMIDebugger; AFileName: String);
543    property Success: Boolean read FSuccess;
544    property ErrorMsg: String read FErrorMsg;
545  end;
546
547  { TGDBMIDebuggerCommandExecuteBase }
548
549  TGDBMIDebuggerCommandExecuteBase = class(TGDBMIDebuggerChangeFilenameBase)
550  private
551    FCanKillNow, FDidKillNow: Boolean;
552  protected
553    function ProcessRunning(out AStoppedParams: String; out AResult: TGDBMIExecResult; ATimeOut: Integer = 0): Boolean;
554    function ParseBreakInsertError(var AText: String; out AnId: Integer): Boolean;
555    function  ProcessStopped(const {%H-}AParams: String; const {%H-}AIgnoreSigIntState: Boolean): Boolean; virtual;
556  public
557    constructor Create(AOwner: TGDBMIDebugger);
558    function KillNow: Boolean; override;
559  end;
560
561  { TGDBMIDebuggerCommandStartBase }
562
563  TGDBMIDebuggerCommandStartBase = class(TGDBMIDebuggerCommandExecuteBase)
564  protected
565    procedure SetTargetInfo(const AFileType: String);
566    function  CheckFunction(const AFunction: String): Boolean;
567    procedure RetrieveRegcall;
568    procedure CheckAvailableTypes;
569    procedure DetectForceableBreaks;
570    procedure CommonInit;  // Before any run/exec
571    procedure DetectTargetPid(InAttach: Boolean = False); virtual;
572  end;
573
574  { TGDBMIDebuggerCommandStartDebugging }
575
576  TGDBMIDebuggerCommandStartDebugging = class(TGDBMIDebuggerCommandStartBase)
577  private
578    FContinueCommand: TGDBMIDebuggerCommand;
579    FSuccess: Boolean;
580  protected
581    function  DoExecute: Boolean; override;
582    function  GdbRunCommand: String; virtual;
583    function  DoTargetDownload: boolean; virtual;
584  public
585    constructor Create(AOwner: TGDBMIDebugger; AContinueCommand: TGDBMIDebuggerCommand);
586    destructor Destroy; override;
587    function  DebugText: String; override;
588    property ContinueCommand: TGDBMIDebuggerCommand read FContinueCommand;
589    property Success: Boolean read FSuccess;
590  end;
591
592  { TGDBMIDebuggerCommandAttach }
593
594  TGDBMIDebuggerCommandAttach = class(TGDBMIDebuggerCommandStartBase)
595  private
596    FProcessID: String;
597    FSuccess: Boolean;
598  protected
599    function  DoExecute: Boolean; override;
600  public
601    constructor Create(AOwner: TGDBMIDebugger; AProcessID: String);
602    function  DebugText: String; override;
603    property Success: Boolean read FSuccess;
604  end;
605
606  { TGDBMIDebuggerCommandDetach }
607
608  TGDBMIDebuggerCommandDetach = class(TGDBMIDebuggerCommand)
609  protected
610    function  DoExecute: Boolean; override;
611  end;
612
613  { TGDBMIDebuggerCommandExecute }
614
615  TGDBMIDebuggerCommandExecute = class(TGDBMIDebuggerCommandExecuteBase)
616  private
617    FNextExecQueued: Boolean;
618    FResult: TGDBMIExecResult;
619    FExecType: TGDBMIExecCommandType;
620    FCurrentExecCmd:  TGDBMIExecCommandType;
621    FCurrentExecArg: String;
622    FRunToSrc: String;
623    FRunToLine: Integer;
624    FStepBreakPoint: Integer;
625    FInitialFP: TDBGPtr;
626    FStepOverFixNeeded: (sofNotNeeded, sofStepAgain, sofStepOut);
627  protected
628    procedure DoLockQueueExecute; override;
629    procedure DoUnLockQueueExecute; override;
630    function  ProcessStopped(const AParams: String; const AIgnoreSigIntState: Boolean): Boolean; override;
631    {$IFDEF MSWindows}
632    function FixThreadForSigTrap: Boolean;
633    {$ENDIF}
634    function  DoExecute: Boolean; override;
635  public
636    constructor Create(AOwner: TGDBMIDebugger; const ExecType: TGDBMIExecCommandType);
637    constructor Create(AOwner: TGDBMIDebugger; const ExecType: TGDBMIExecCommandType; Args: array of const);
638    function  DebugText: String; override;
639    property  Result: TGDBMIExecResult read FResult;
640    property  NextExecQueued: Boolean read FNextExecQueued;
641  end;
642
643  { TGDBMIDebuggerCommandKill }
644
645  TGDBMIDebuggerCommandKill = class(TGDBMIDebuggerCommand)
646  protected
647    function  DoExecute: Boolean; override;
648  end;
649
650  {%endregion}
651
652  { TGDBMIInternalBreakPoint }
653
654  TGDBMIInternalBreakPoint = class
655  private type
656    TClearOpt = (coClearIfSet, coKeepIfSet);
657    TBlockOpt = (boNone, boBlock, boUnblock);
658    TInternalBreakLocation = (iblNamed, iblAddrOfNamed, iblCustomAddr,
659                              iblAddOffset, iblFileLine);
660    TInternalBreakData = record
661      BreakGdbId: Integer;
662      BreakAddr: TDBGPtr;
663      BreakFunction: String;
664      BreakFile: String;
665      BreakLine: String;
666    end;
667  private
668    FBreaks: array[TInternalBreakLocation] of TInternalBreakData;
669    (*  F...ID: -1 not set,  -2 blocked
670    *)
671    FEnabled: Boolean;
672    FName: string;                 // The (function) name of the location "main" or "FPC_RAISE"
673    FMainAddrFound: TDBGPtr;       // The address found for this named location
674    FUseForceFlag: Boolean;
675    function  BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
676                       ALoc: TInternalBreakLocation;
677                       AClearIfSet: TClearOpt): Boolean;
678    function GetBreakAddr(ALoc: TInternalBreakLocation): TDBGPtr;
679    function GetBreakFile(ALoc: TInternalBreakLocation): String;
680    function GetBreakId(ALoc: TInternalBreakLocation): Integer;
681    function GetBreakLine(ALoc: TInternalBreakLocation): String;
682    function  GetInfoAddr(ACmd: TGDBMIDebuggerCommand): TDBGPtr;
683    function  HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
684    function  HasBreakWithId(AnId: Integer): Boolean;
685    procedure InternalSetAddr(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
686                              AnAddr: TDBGPtr);
687  protected
688    procedure Clear(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
689                    ABlock: TBlockOpt = boNone);
690    property  BreakId[ALoc: TInternalBreakLocation]: Integer read GetBreakId;
691    property  BreakAddr[ALoc: TInternalBreakLocation]: TDBGPtr read GetBreakAddr;
692    property  BreakFile[ALoc: TInternalBreakLocation]: String read GetBreakFile;
693    property  BreakLine[ALoc: TInternalBreakLocation]: String read GetBreakLine;
694  public
695    constructor Create(AName: string);
696
697    procedure SetBoth(ACmd: TGDBMIDebuggerCommand);
698    procedure SetByName(ACmd: TGDBMIDebuggerCommand);
699    procedure SetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
700    procedure SetAtCustomAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
701    procedure SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
702    procedure SetAtFileLine(ACmd: TGDBMIDebuggerCommand; AFile, ALine: String);
703
704    procedure Clear(ACmd: TGDBMIDebuggerCommand);
705    function  ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
706    // a blocked id can not be set, until after the next clear (clear all)
707    function  ClearAndBlockId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
708    function  MatchAddr(AnAddr: TDBGPtr): boolean;
709    function  MatchId(AnId: Integer): boolean;
710    function  IsBreakSet: boolean;
711    function  BreakSetCount: Integer;
712    procedure EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
713    procedure Enable(ACmd: TGDBMIDebuggerCommand);
714    procedure Disable(ACmd: TGDBMIDebuggerCommand);
715    property  MainAddrFound: TDBGPtr read FMainAddrFound;
716    property  UseForceFlag: Boolean read FUseForceFlag write FUseForceFlag;
717    property  Enabled: Boolean read FEnabled;
718  end;
719
720
721{$ifdef WIN64}
722  { TGDBMIInternalAddrBreakPointList }
723
724  TGDBMIInternalAddrBreakPointList = class
725  private type
726
727    { TGDBMIInternalAddrBreakPointListEntry }
728
729    TGDBMIInternalAddrBreakPointListEntry = record
730      FAddr: TDBGPtr;
731      FId: Integer;
732      FCount: Integer;
733      class Operator =(a,b:TGDBMIInternalAddrBreakPointListEntry)c:Boolean;
734    end;
735    TBPEntryList = specialize TFPGList<TGDBMIInternalAddrBreakPointListEntry>;
736  private
737    FList: TBPEntryList;
738    function IndexOfAddr(AnAddr: TDBGPtr): Integer;
739    function IndexOfId(AnId: integer): Integer;
740    procedure RemoveIndex(ACmd: TGDBMIDebuggerCommand; AnIndex: Integer);
741  public
742    constructor Create;
743    destructor Destroy; override;
744    procedure AddAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
745    procedure RemoveAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
746    procedure RemoveId(ACmd: TGDBMIDebuggerCommand; AnId: Integer);
747    procedure ClearAll(ACmd: TGDBMIDebuggerCommand);
748    function HasBreakId(AnId: Integer): boolean;
749  end;
750{$endif}
751
752  { TGDBMIWatches }
753
754  TGDBMIDebuggerParentFrameCache = record
755      ThreadId: Integer;
756      ParentFPList: Array of
757        record
758          fp, parentfp: string; // empty=unknown / '-'=evaluated-no-data
759        end;
760    end;
761    PGDBMIDebuggerParentFrameCache = ^TGDBMIDebuggerParentFrameCache;
762
763  TGDBMIWatches = class(TWatchesSupplier)
764  private
765    FCommandList: TList;
766    FParentFPList: Array of TGDBMIDebuggerParentFrameCache;
767    FParentFPListChangeStamp: Integer;
768    procedure DoEvaluationDestroyed(Sender: TObject);
769  protected
770    function  GetParentFPList(AThreadId: Integer): PGDBMIDebuggerParentFrameCache;
771    procedure DoStateChange(const AOldState: TDBGState); override;
772    procedure Changed;
773    procedure Clear;
774    function  ForceQueuing: Boolean;
775    procedure InternalRequestData(AWatchValue: TWatchValue); override;
776    property  ParentFPListChangeStamp: Integer read FParentFPListChangeStamp;
777  public
778    constructor Create(const ADebugger: TDebuggerIntf);
779    destructor Destroy; override;
780  end;
781
782  { TGDBMILocals }
783
784  TGDBMILocals = class(TLocalsSupplier)
785  private
786    FCommandList: TList;
787    procedure CancelEvaluation; deprecated;
788    procedure DoEvaluationDestroyed(Sender: TObject);
789  protected
790    procedure CancelAllCommands;
791    function  ForceQueuing: Boolean;
792  public
793    procedure Changed;
794    constructor Create(const ADebugger: TDebuggerIntf);
795    destructor Destroy; override;
796    procedure RequestData(ALocals: TLocals); override;
797  end;
798
799  { TGDBMIDebugger }
800
801  TGDBMIDebugger = class(TGDBMICmdLineDebugger) // TODO: inherit from TDebugger direct
802  private
803    FInstructionQueue: TGDBMIDbgInstructionQueue;
804    FCommandQueue: TGDBMIDebuggerCommandList;
805    FCurrentCommand: TGDBMIDebuggerCommand;
806    FCommandQueueExecLock: Integer;
807    FCommandProcessingLock: Integer;
808
809    FMainAddrBreak: TGDBMIInternalBreakPoint;
810    FBreakAtMain: TDBGBreakPoint;
811    FBreakErrorBreak: TGDBMIInternalBreakPoint;
812    FRunErrorBreak: TGDBMIInternalBreakPoint;
813    FExceptionBreak: TGDBMIInternalBreakPoint;
814    FPopExceptStack, FCatchesBreak, FReRaiseBreak: TGDBMIInternalBreakPoint;
815    {$ifdef WIN64}
816    FRtlUnwindExBreak: TGDBMIInternalBreakPoint; // SEH, win64
817    FSehRaiseBreaks: TGDBMIInternalAddrBreakPointList;
818    {$endif}
819    FPauseWaitState: TGDBMIPauseWaitState;
820    FStoppedReason: (srNone, srRaiseExcept, srReRaiseExcept, srPopExceptStack, srCatches {$ifdef WIN64}, srRtlUnwind, srSehCatches{$endif});
821    FInExecuteCount: Integer;
822    FInIdle: Boolean;
823    FRunQueueOnUnlock: Boolean;
824    FDebuggerFlags: TGDBMIDebuggerFlags;
825    FSourceNames: TStringList; // Objects[] -> TMap[Integer|Integer] -> TDbgPtr
826    FInProcessStopped: Boolean; // paused, but maybe state run
827    FCommandNoneMiState: Array [TGDBMIExecCommandType] of Boolean;
828    FCommandAsyncState: Array [TGDBMIExecCommandType] of Boolean;
829    FCurrentCmdIsAsync: Boolean;
830    FAsyncModeEnabled: Boolean;
831    FWasDisableLoadSymbolsForLibraries: Boolean;
832
833    // Internal Current values
834    FCurrentStackFrame, FCurrentThreadId: Integer; // User set values
835    FCurrentStackFrameValid, FCurrentThreadIdValid: Boolean; // Internal (update for every temporary change)
836    FCurrentLocation: TDBGLocationRec;
837
838    // GDB info (move to ?)
839    FGDBVersion: String;
840    FGDBVersionMajor, FGDBVersionMinor, FGDBVersionRev: Integer;
841    FGDBCPU: String;
842    FGDBPtrSize: integer; // PointerSize of the GDB-cpu
843    FGDBOS: String;
844
845    // Target info (move to record ?)
846    FTargetInfo: TGDBMITargetInfo;
847
848    FThreadGroups: TStringList;
849    FTypeRequestCache: TGDBPTypeRequestCache;
850    FMaxLineForUnitCache: TStringList;
851
852    procedure DoPseudoTerminalRead(Sender: TObject);
853    // Implementation of external functions
854    function  GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
855    function  GDBEvaluate(const AExpression: String; EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
856    procedure GDBEvaluateCommandCancelled(Sender: TObject);
857    procedure GDBEvaluateCommandExecuted(Sender: TObject);
858    function  GDBModify(const AExpression, ANewValue: String): Boolean;
859    procedure GDBModifyDone(const {%H-}AResult: TGDBMIExecResult; const {%H-}ATag: PtrInt);
860    function  GDBRun: Boolean;
861    function  GDBPause(const AInternal: Boolean): Boolean;
862    function  GDBStop: Boolean;
863    function  GDBStepOver: Boolean;
864    function  GDBStepInto: Boolean;
865    function  GDBStepOverInstr: Boolean;
866    function  GDBStepIntoInstr: Boolean;
867    function  GDBStepOut: Boolean;
868    function  GDBRunTo(const ASource: String; const ALine: Integer): Boolean;
869    function  GDBJumpTo(const {%H-}ASource: String; const {%H-}ALine: Integer): Boolean;
870    function  GDBAttach(AProcessID: String): Boolean;
871    function  GDBDetach: Boolean;
872    function  GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr;
873                             out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
874              deprecated;
875    function  GDBSourceAdress(const ASource: String; ALine, {%H-}AColumn: Integer; out AAddr: TDbgPtr): Boolean;
876
877    // ---
878    procedure ClearSourceInfo;
879    function  FindBreakpoint(const ABreakpoint: Integer): TDBGBreakPoint;
880
881    // All ExecuteCommand functions are wrappers for the real (full) implementation
882    // ExecuteCommandFull is never called directly
883    function  ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags): Boolean; overload;
884    function  ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags; var AResult: TGDBMIExecResult): Boolean; overload;
885    function  ExecuteCommandFull(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags; const ACallback: TGDBMICallback; const ATag: PtrInt; var AResult: TGDBMIExecResult): Boolean; overload;
886    procedure RunQueue;
887    procedure CancelAllQueued;
888    procedure CancelBeforeRun;
889    procedure CancelAfterStop;
890    procedure RunQueueASync;
891    procedure RemoveRunQueueASync;
892    procedure DoRunQueueFromASync({%H-}Data: PtrInt);
893    function  StartDebugging(AContinueCommand: TGDBMIExecCommandType): Boolean;
894    function  StartDebugging(AContinueCommand: TGDBMIExecCommandType; AValues: array of const): Boolean;
895    function  StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
896    procedure TerminateGDB;
897  protected
898    FNeedStateToIdle, FNeedReset, FWarnedOnInternal: Boolean;
899    {$IFDEF MSWindows}
900    FPauseRequestInThreadID: Cardinal;
901    {$ENDIF}
902    {$IFDEF DBG_ENABLE_TERMINAL}
903    FPseudoTerminal: TPseudoTerminal;
904    procedure ProcessWhileWaitForHandles; override;
905    function GetPseudoTerminal: TPseudoTerminal; override;
906    {$ENDIF}
907    procedure QueueExecuteLock;
908    procedure QueueExecuteUnlock;
909    procedure QueueCommand(const ACommand: TGDBMIDebuggerCommand; ForceQueue: Boolean = False);
910    procedure UnQueueCommand(const ACommand: TGDBMIDebuggerCommand);
911
912    function ConvertToGDBPath(APath: string; ConvType: TConvertToGDBPathType = cgptNone): string;
913    function  ChangeFileName: Boolean; override;
914    function  CreateBreakPoints: TDBGBreakPoints; override;
915    function  CreateLocals: TLocalsSupplier; override;
916    function  CreateLineInfo: TDBGLineInfo; override;
917    function  CreateRegisters: TRegisterSupplier; override;
918    function  CreateCallStack: TCallStackSupplier; override;
919    function  CreateDisassembler: TDBGDisassembler; override;
920    function  CreateWatches: TWatchesSupplier; override;
921    function  CreateThreads: TThreadsSupplier; override;
922    function  GetSupportedCommands: TDBGCommands; override;
923    function  GetCommands: TDBGCommands; override;
924    function  GetTargetWidth: Byte; override;
925    procedure InterruptTarget; virtual;
926    function  ParseInitialization: Boolean; virtual;
927    function  CreateCommandInit: TGDBMIDebuggerCommandInitDebugger; virtual;
928    function  CreateCommandStartDebugging(AContinueCommand: TGDBMIDebuggerCommand): TGDBMIDebuggerCommandStartDebugging; virtual;
929    function  RequestCommand(const ACommand: TDBGCommand; const AParams: array of const; const ACallback: TMethod): Boolean; override;
930    property  CurrentCmdIsAsync: Boolean read FCurrentCmdIsAsync;
931    property  CurrentCommand: TGDBMIDebuggerCommand read FCurrentCommand;
932
933    procedure ClearCommandQueue;
934    function  GetIsIdle: Boolean; override;
935    procedure ResetStateToIdle; override;
936    procedure DoState(const OldState: TDBGState); override;
937    procedure DoBeforeState(const OldState: TDBGState); override;
938    function LineEndPos(const s: string; out LineEndLen: integer): integer; override;
939    procedure DoThreadChanged;
940    property  TargetPID: Integer read FTargetInfo.TargetPID;
941    property  TargetPtrSize: Byte read FTargetInfo.TargetPtrSize;
942    property  TargetFlags: TGDBMITargetFlags read FTargetInfo.TargetFlags write FTargetInfo.TargetFlags;
943    property  PauseWaitState: TGDBMIPauseWaitState read FPauseWaitState;
944    property  DebuggerFlags: TGDBMIDebuggerFlags read FDebuggerFlags;
945    procedure DoUnknownException(Sender: TObject; AnException: Exception);
946
947    function  CheckForInternalError(ALine, ACurCommandText: String): Boolean;
948    procedure DoNotifyAsync(Line: String);
949    procedure DoDbgBreakpointEvent(ABreakpoint: TDBGBreakPoint; ALocation: TDBGLocationRec;
950                                   AReason: TGDBMIBreakpointReason;
951                                   AOldVal: String = ''; ANewVal: String = '');
952    procedure AddThreadGroup(const S: String);
953    procedure RemoveThreadGroup(const {%H-}S: String);
954    function ParseLibraryLoaded(const S: String): String;
955    function ParseLibraryUnLoaded(const S: String): String;
956    function ParseThread(const S, EventText: String): String;
957
958    property CurrentStackFrame: Integer read FCurrentStackFrame;
959    property CurrentThreadId: Integer read FCurrentThreadId;
960    property CurrentStackFrameValid: Boolean read FCurrentStackFrameValid;
961    property CurrentThreadIdValid: Boolean read FCurrentThreadIdValid;
962
963    function CreateTypeRequestCache: TGDBPTypeRequestCache; virtual;
964    property TypeRequestCache: TGDBPTypeRequestCache read FTypeRequestCache;
965  public
966    class function CreateProperties: TDebuggerProperties; override; // Creates debuggerproperties
967    class function Caption: String; override;
968    class function ExePaths: String; override;
969
970    constructor Create(const AExternalDebugger: String); override;
971    destructor Destroy; override;
972
973    procedure Init; override;         // Initializes external debugger
974    procedure Done; override;         // Kills external debugger
975    procedure BeginReset; override;
976    function GetLocation: TDBGLocationRec; override;
977    function GetProcessList({%H-}AList: TRunningProcessInfoList): boolean; override;
978
979    //LockCommandProcessing is more than just QueueExecuteLock
980    //LockCommandProcessing also takes care to run the queue, if unlocked and not already running
981    procedure LockCommandProcessing; override;
982    procedure UnLockCommandProcessing; override;
983
984    property AsyncModeEnabled: Boolean read FAsyncModeEnabled;
985
986    // internal testing
987    procedure TestCmd(const ACommand: String); override;
988    function NeedReset: Boolean; override;
989  end;
990
991  {%region       *****  TGDBMINameValueList and Parsers  *****   }
992
993  { TGDBMINameValueBasedList }
994
995  TGDBMINameValueBasedList = class
996  protected
997    FNameValueList: TGDBMINameValueList;
998    procedure PreParse; virtual; abstract;
999  public
1000    constructor Create;
1001    constructor Create(const AResultValues: String);
1002    constructor Create(AResult: TGDBMIExecResult);
1003    destructor  Destroy; override;
1004    procedure Init(AResultValues: string);
1005    procedure Init(AResult: TGDBMIExecResult);
1006  end;
1007
1008  { TGDBMIMemoryDumpResultList }
1009
1010  TGDBMIMemoryDumpResultList = class(TGDBMINameValueBasedList)
1011  private
1012    FAddr: TDBGPtr;
1013    function GetItem(Index: Integer): TPCharWithLen;
1014    function GetItemNum(Index: Integer): Integer;
1015    function GetItemTxt(Index: Integer): string;
1016  protected
1017    procedure PreParse; override;
1018  public
1019    // Expected input format: 1 row with hex values
1020    function Count: Integer;
1021    property Item[Index: Integer]: TPCharWithLen read GetItem;
1022    property ItemTxt[Index: Integer]: string  read GetItemTxt;
1023    property ItemNum[Index: Integer]: Integer read GetItemNum;
1024    property Addr: TDBGPtr read FAddr;
1025    function AsText(AStartOffs, ACount: Integer; AAddrWidth: Integer): string;
1026  end;
1027
1028  {%endregion    *^^^*  TGDBMINameValueList and Parsers  *^^^*   }
1029
1030procedure Register;
1031
1032implementation
1033
1034var
1035  DBGMI_QUEUE_DEBUG, DBGMI_STRUCT_PARSER, DBG_VERBOSE, DBG_WARNINGS,
1036  DBG_DISASSEMBLER, DBG_THREAD_AND_FRAME: PLazLoggerLogGroup;
1037
1038
1039const
1040  GDBMIBreakPointReasonNames: Array[TGDBMIBreakpointReason] of string =
1041    ('Breakpoint', 'Watchpoint', 'Watchpoint (scope)');
1042
1043  GDBMIExecCommandMap: array [TGDBMIExecCommandType] of string =
1044    ( '',                        // ectNone
1045      '-exec-continue',           // ectContinue,
1046      '-exec-run',                // ectRun,
1047      '-exec-until',              // ectRunTo,  // [Source, Line]
1048      '-exec-next',               // ectStepOver,
1049      '-exec-finish',             // ectStepOut,
1050      '-exec-step',               // ectStepInto,
1051      '-exec-next-instruction',   // ectStepOverInstruction,
1052      '-exec-step-instruction',   // ectStepIntoInstruction,
1053      '-exec-return'              // ectReturn      // (step out immediately, skip execution)
1054    );
1055  GDBMIExecCommandMapNoneMI: array [TGDBMIExecCommandType] of string =
1056    ( '',                        // ectNone
1057      'continue',           // ectContinue,
1058      'run',                // ectRun,
1059      'until',              // ectRunTo,  // [Source, Line]
1060      'next',               // ectStepOver,
1061      'finish',             // ectStepOut,
1062      'step',               // ectStepInto,
1063      'nexti',   // ectStepOverInstruction,
1064      'stepi',   // ectStepIntoInstruction,
1065      'return'              // ectReturn      // (step out immediately, skip execution)
1066    );
1067
1068type
1069  THackDBGType = class(TGDBType) end;
1070
1071const
1072  // priorities for commands
1073  GDCMD_PRIOR_IMMEDIATE = 999; // run immediate (request without callback)
1074  GDCMD_PRIOR_LINE_INFO = 100; // Line info should run asap
1075  GDCMD_PRIOR_DISASS    = 30;  // Run before watches
1076  GDCMD_PRIOR_USER_ACT  = 10;  // set/change/remove brkpoint
1077  GDCMD_PRIOR_THREAD    = 5;   // Run before watches, stack or locals
1078  GDCMD_PRIOR_STACK     = 2;   // Run before watches
1079  GDCMD_PRIOR_LOCALS    = 1;   // Run before watches (also registers etc)
1080
1081type
1082
1083  {%region      *****  Locals  *****   }
1084
1085  { TGDBMIDebuggerCommandLocals }
1086
1087  TGDBMIDebuggerCommandLocals = class(TGDBMIDebuggerCommand)
1088  private
1089    FLocals: TLocals;
1090  protected
1091    procedure DoLockQueueExecute; override;
1092    procedure DoUnLockQueueExecute; override;
1093    procedure DoLockQueueExecuteForInstr; override;
1094    procedure DoUnLockQueueExecuteForInstr; override;
1095    function DoExecute: Boolean; override;
1096  public
1097    constructor Create(AOwner: TGDBMIDebugger; ALocals: TLocals);
1098    destructor Destroy; override;
1099    function DebugText: String; override;
1100  end;
1101
1102  {%endregion   ^^^^^  Locals  ^^^^^   }
1103
1104  {%region      *****  LineSymbolInfo  *****   }
1105
1106  { TGDBMIDebuggerCommandLineSymbolInfo }
1107
1108  TGDBMIDebuggerCommandLineSymbolInfo = class(TGDBMIDebuggerCommand)
1109  private
1110    FResult: TGDBMIExecResult;
1111    FSource: string;
1112  protected
1113    function DoExecute: Boolean; override;
1114  public
1115    constructor Create(AOwner: TGDBMIDebugger; Source: string);
1116    function DebugText: String; override;
1117    property Result: TGDBMIExecResult read FResult;
1118    property Source: string read FSource;
1119  end;
1120
1121  { TGDBMILineInfo }
1122
1123  TGDBMILineInfo = class(TDBGLineInfo)
1124  private
1125    FSourceIndex: TStringList;
1126    FRequestedSources: TStringList;
1127    FSourceMaps: array of record
1128      Source: String;
1129      Map: TMap;
1130    end;
1131    FGetLineSymbolsCmdObj: TGDBMIDebuggerCommandLineSymbolInfo;
1132    procedure DoGetLineSymbolsDestroyed(Sender: TObject);
1133    procedure ClearSources;
1134    procedure AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
1135    procedure DoGetLineSymbolsFinished(Sender: TObject);
1136  protected
1137    function GetSource(const AIndex: integer): String; override;
1138    procedure DoStateChange(const {%H-}AOldState: TDBGState); override;
1139  public
1140    constructor Create(const ADebugger: TDebuggerIntf);
1141    destructor Destroy; override;
1142    function Count: Integer; override;
1143    function HasAddress(const AIndex: Integer; const ALine: Integer): Boolean; override;
1144    function GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr;
1145    function GetInfo({%H-}AAdress: TDbgPtr; out {%H-}ASource, {%H-}ALine, {%H-}AOffset: Integer): Boolean; override;
1146    function IndexOf(const ASource: String): integer; override;
1147    procedure Request(const ASource: String); override;
1148    procedure Cancel(const ASource: String); override;
1149  end;
1150
1151  {%endregion   ^^^^^  LineSymbolInfo  ^^^^^   }
1152
1153  {%region      *****  BreakPoints  *****  }
1154
1155  { TGDBMIDebuggerCommandBreakPointBase }
1156
1157  TGDBMIDebuggerCommandBreakPointBase = class(TGDBMIDebuggerCommand)
1158  protected
1159    function ExecCheckLineInUnit(ASource: string; ALine: Integer): Boolean;
1160    function ExecBreakDelete(ABreakId: Integer): Boolean;
1161    function ExecBreakEnabled(ABreakId: Integer; AnEnabled: Boolean): Boolean;
1162    function ExecBreakCondition(ABreakId: Integer; AnExpression: string): Boolean;
1163  end;
1164
1165  { TGDBMIDebuggerCommandBreakInsert }
1166
1167  TGDBMIDebuggerCommandBreakInsert = class(TGDBMIDebuggerCommandBreakPointBase)
1168  private
1169    FKind: TDBGBreakPointKind;
1170    FAddress: TDBGPtr;
1171    FSource: string;
1172    FLine: Integer;
1173    FEnabled: Boolean;
1174    FExpression: string;
1175    FReplaceId: Integer;
1176
1177    FAddr: TDBGPtr;
1178    FBreakID: Integer;
1179    FHitCnt: Integer;
1180    FValid: TValidState;
1181    FWatchData: String;
1182    FWatchKind: TDBGWatchPointKind;
1183    FWatchScope: TDBGWatchPointScope;
1184  protected
1185    function ExecBreakInsert(out ABreakId, AHitCnt: Integer; out AnAddr: TDBGPtr;
1186                             out APending: Boolean): Boolean;
1187    function DoExecute: Boolean; override;
1188  public
1189    constructor Create(AOwner: TGDBMIDebugger; ASource: string; ALine: Integer;
1190                       AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
1191    constructor Create(AOwner: TGDBMIDebugger; AAddress: TDBGPtr;
1192                       AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
1193    constructor Create(AOwner: TGDBMIDebugger; AData: string; AScope: TDBGWatchPointScope;
1194                       AKind: TDBGWatchPointKind; AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
1195    function DebugText: String; override;
1196    property Kind: TDBGBreakPointKind read FKind write FKind;
1197    property Address: TDBGPtr read FAddress write FAddress;
1198    property Source: string read FSource write FSource;
1199    property Line: Integer read FLine write FLine;
1200    property WatchData: String read FWatchData write FWatchData;
1201    property WatchScope: TDBGWatchPointScope read FWatchScope write FWatchScope;
1202    property WatchKind: TDBGWatchPointKind read FWatchKind write FWatchKind;
1203    property Enabled: Boolean read FEnabled write FEnabled;
1204    property Expression: string read FExpression write FExpression;
1205    property ReplaceId: Integer read FReplaceId write FReplaceId;
1206    // result values
1207    property Addr: TDBGPtr read FAddr;
1208    property BreakID: Integer read FBreakID;
1209    property HitCnt: Integer read FHitCnt;
1210    property Valid: TValidState read FValid;
1211  end;
1212
1213  { TGDBMIDebuggerCommandBreakRemove }
1214
1215  TGDBMIDebuggerCommandBreakRemove = class(TGDBMIDebuggerCommandBreakPointBase)
1216  private
1217    FBreakId: Integer;
1218  protected
1219    function DoExecute: Boolean; override;
1220  public
1221    constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
1222    function DebugText: String; override;
1223  end;
1224
1225  { TGDBMIDebuggerCommandBreakUpdate }
1226
1227  TGDBMIDebuggerCommandBreakUpdate = class(TGDBMIDebuggerCommandBreakPointBase)
1228  private
1229    FBreakID: Integer;
1230    FEnabled: Boolean;
1231    FExpression: string;
1232    FUpdateEnabled: Boolean;
1233    FUpdateExpression: Boolean;
1234  protected
1235    function DoExecute: Boolean; override;
1236  public
1237    constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
1238    constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnEnabled: Boolean);
1239    constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnExpression: string);
1240    constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnEnabled: Boolean; AnExpression: string);
1241    function DebugText: String; override;
1242    property UpdateEnabled: Boolean read FUpdateEnabled write FUpdateEnabled;
1243    property UpdateExpression: Boolean read FUpdateExpression write FUpdateExpression;
1244    property Enabled: Boolean read FEnabled write FEnabled;
1245    property Expression: string read FExpression write FExpression;
1246  end;
1247
1248  { TGDBMIBreakPoint       *****  BreakPoints  *****   }
1249
1250  TGDBMIBreakPointUpdateFlag = (bufSetBreakPoint, bufEnabled, bufCondition);
1251  TGDBMIBreakPointUpdateFlags = set of TGDBMIBreakPointUpdateFlag;
1252
1253  TGDBMIBreakPoint = class(TDBGBreakPoint)
1254  private
1255    FParsedExpression: String;
1256    FCurrentCmd: TGDBMIDebuggerCommandBreakPointBase;
1257    FUpdateFlags: TGDBMIBreakPointUpdateFlags;
1258    procedure DoLogExpressionCallback(Sender: TObject; ASuccess: Boolean;
1259      ResultText: String; ResultDBGType: TDBGType);
1260    procedure SetBreakPoint;
1261    procedure ReleaseBreakPoint;
1262    procedure UpdateProperties(AFlags: TGDBMIBreakPointUpdateFlags);
1263    procedure DoCommandDestroyed(Sender: TObject);
1264    procedure DoCommandExecuted(Sender: TObject);
1265  protected
1266    FBreakID: Integer;
1267    procedure DoEndUpdate; override;
1268    procedure DoEnableChange; override;
1269    procedure DoExpressionChange; override;
1270    procedure DoStateChange(const AOldState: TDBGState); override;
1271    procedure MakeInvalid;
1272  public
1273    constructor Create(ACollection: TCollection); override;
1274    destructor Destroy; override;
1275    procedure DoLogExpression(const AnExpression: String); override;
1276    procedure SetLocation(const ASource: String; const ALine: Integer); override;
1277    procedure SetWatch(const AData: String; const AScope: TDBGWatchPointScope;
1278                       const AKind: TDBGWatchPointKind); override;
1279    procedure SetAddress(const AValue: TDBGPtr); override;
1280  end;
1281
1282  { TGDBMIBreakPoints }
1283
1284  TGDBMIBreakPoints = class(TDBGBreakPoints)
1285  protected
1286    function FindById(AnId: Integer): TGDBMIBreakPoint;
1287  end;
1288  {%endregion   ^^^^^  BreakPoints  ^^^^^   }
1289
1290  {%region      *****  Register  *****   }
1291
1292  TStringArray = Array of string;
1293
1294  TGDBMIRegisterSupplier = class;
1295
1296  { TGDBMIDebuggerCommandRegisterUpdate }
1297
1298  TGDBMIDebuggerCommandRegisterUpdate = class(TGDBMIDebuggerCommand)
1299  private
1300    FRegisters: TRegisters;
1301    FGDBMIRegSupplier: TGDBMIRegisterSupplier;
1302  protected
1303    function DoExecute: Boolean; override;
1304    procedure DoCancel; override;
1305  public
1306    constructor Create(AOwner: TGDBMIDebugger; AGDBMIRegSupplier: TGDBMIRegisterSupplier; ARegisters: TRegisters);
1307    destructor Destroy; override;
1308    //function DebugText: String; override;
1309  end;
1310
1311  { TGDBMIRegisterSupplier }
1312
1313  TGDBMIRegisterSupplier = class(TRegisterSupplier)
1314  private
1315    FRegNamesCache: TStringArray;
1316  protected
1317    procedure DoStateChange(const AOldState: TDBGState); override;
1318  public
1319    procedure Changed;
1320    procedure RequestData(ARegisters: TRegisters); override;
1321  end;
1322
1323  {%endregion   ^^^^^  Register  ^^^^^   }
1324
1325  {%region      *****  Watches  *****   }
1326
1327  { TGDBMIDebuggerCommandEvaluate }
1328
1329  TGDBMIDebuggerCommandEvaluate = class(TGDBMIDebuggerCommand)
1330  private
1331    FCallback: TDBGEvaluateResultCallback;
1332    FEvalFlags: TDBGEvaluateFlags;
1333    FExpression: String;
1334    FDisplayFormat: TWatchDisplayFormat;
1335    FWatchValue: TWatchValue;
1336    FTextValue: String;
1337    FTypeInfo: TGDBType;
1338    FValidity: TDebuggerDataState;
1339    FTypeInfoAutoDestroy: Boolean;
1340    FLockFlag: Boolean;
1341    function GetTypeInfo: TGDBType;
1342    procedure DoWatchFreed(Sender: TObject);
1343  protected
1344    procedure DoLockQueueExecute; override;
1345    procedure DoUnLockQueueExecute; override;
1346    procedure DoLockQueueExecuteForInstr; override;
1347    procedure DoUnLockQueueExecuteForInstr; override;
1348    function DoExecute: Boolean; override;
1349    function SelectContext: Boolean;
1350    procedure UnSelectContext;
1351  public
1352    constructor Create(AOwner: TGDBMIDebugger; AExpression: String; ADisplayFormat: TWatchDisplayFormat);
1353    constructor Create(AOwner: TGDBMIDebugger; AWatchValue: TWatchValue);
1354    destructor Destroy; override;
1355    function DebugText: String; override;
1356    property Expression: String read FExpression;
1357    property EvalFlags: TDBGEvaluateFlags read FEvalFlags write FEvalFlags;
1358    property DisplayFormat: TWatchDisplayFormat read FDisplayFormat;
1359    property TextValue: String read FTextValue;
1360    property TypeInfo: TGDBType read GetTypeInfo;
1361    property TypeInfoAutoDestroy: Boolean read FTypeInfoAutoDestroy write FTypeInfoAutoDestroy;
1362    property Callback: TDBGEvaluateResultCallback read FCallback write FCallback;
1363  end;
1364
1365  {%endregion   ^^^^^  Watches  ^^^^^   }
1366
1367  {%region      *****  Stack  *****   }
1368
1369  TGDBMINameValueListArray = array of TGDBMINameValueList;
1370
1371  { TGDBMIDebuggerCommandStack }
1372
1373  TGDBMIDebuggerCommandStack = class(TGDBMIDebuggerCommand)
1374  private
1375    procedure DoCallstackFreed(Sender: TObject);
1376  protected
1377    FCallstack: TCallStackBase;
1378    procedure DoLockQueueExecute; override;
1379    procedure DoUnLockQueueExecute; override;
1380    procedure DoLockQueueExecuteForInstr; override;
1381    procedure DoUnLockQueueExecuteForInstr; override;
1382  public
1383    constructor Create(AOwner: TGDBMIDebugger; ACallstack: TCallStackBase);
1384    destructor Destroy; override;
1385    property Callstack: TCallStackBase read FCallstack;
1386  end;
1387
1388  { TGDBMIDebuggerCommandStackFrames }
1389
1390  TGDBMIDebuggerCommandStackFrames = class(TGDBMIDebuggerCommandStack)
1391  protected
1392    function DoExecute: Boolean; override;
1393  end;
1394
1395  { TGDBMIDebuggerCommandStackDepth }
1396
1397  TGDBMIDebuggerCommandStackDepth = class(TGDBMIDebuggerCommandStack)
1398  private
1399    FDepth: Integer;
1400    FLimit: Integer;
1401  protected
1402    function DoExecute: Boolean; override;
1403  public
1404    constructor Create(AOwner: TGDBMIDebugger; ACallstack: TCallStackBase);
1405    function DebugText: String; override;
1406    property Depth: Integer read FDepth;
1407    property Limit: Integer read FLimit write FLimit;
1408  end;
1409
1410  { TGDBMICallStack }
1411
1412  TGDBMICallStack = class(TCallStackSupplier)
1413  private
1414    FCommandList: TList;
1415    FDepthEvalCmdObj: TGDBMIDebuggerCommandStackDepth;
1416    FLimitSeen: Integer;
1417    procedure DoDepthCommandExecuted(Sender: TObject);
1418    //procedure DoFramesCommandExecuted(Sender: TObject);
1419    procedure DoCommandDestroyed(Sender: TObject);
1420  protected
1421    procedure Clear;
1422    procedure DoThreadChanged;
1423  public
1424    constructor Create(const ADebugger: TDebuggerIntf);
1425    destructor Destroy; override;
1426    procedure RequestCount(ACallstack: TCallStackBase); override;
1427    procedure RequestAtLeastCount(ACallstack: TCallStackBase; ARequiredMinCount: Integer); override;
1428    procedure RequestCurrent(ACallstack: TCallStackBase); override;
1429    procedure RequestEntries(ACallstack: TCallStackBase); override;
1430    procedure UpdateCurrentIndex; override;
1431  end;
1432
1433  {%endregion   ^^^^^  Stack  ^^^^^   }
1434
1435  {%region      *****  Disassembler  *****   }
1436
1437const
1438  (*  Some values to calculate how many bytes to disassemble for a given amount of lines
1439      Those values are only guesses *)
1440  // Max possible len of a statement in byte. Only used for up to 5 lines
1441  DAssBytesPerCommandMax = 24;
1442  // Maximum alignment between to procedures (for detecion of gaps, after dis-ass with source)
1443  DAssBytesPerCommandAlign = 16;
1444
1445type
1446
1447  { TGDBMIDisassembleResultList }
1448
1449  TGDBMIDisassembleResultList = class(TGDBMINameValueBasedList)
1450  private
1451    FCount: Integer;
1452    FHasSourceInfo: Boolean;
1453    FItems: array of record
1454        AsmEntry: TPCharWithLen;
1455        SrcFile: TPCharWithLen;
1456        SrcLine: TPCharWithLen;
1457        ParsedInfo: TDisassemblerEntry;
1458      end;
1459    HasItemPointerList: Boolean;
1460    ItemPointerList: Array of PDisassemblerEntry;
1461    function GetItem(Index: Integer): PDisassemblerEntry;
1462    function GetLastItem: PDisassemblerEntry;
1463    procedure ParseItem(Index: Integer);
1464    procedure SetCount(const AValue: Integer);
1465    procedure SetItem(Index: Integer; const AValue: PDisassemblerEntry);
1466    procedure SetLastItem(const AValue: PDisassemblerEntry);
1467  protected
1468    procedure PreParse; override;
1469  public
1470    property Count: Integer read FCount write SetCount;
1471    property HasSourceInfo: Boolean read FHasSourceInfo;
1472    property Item[Index: Integer]: PDisassemblerEntry read GetItem write SetItem;
1473    property LastItem: PDisassemblerEntry read GetLastItem write SetLastItem;
1474    function SortByAddress: Boolean;
1475  public
1476    // only valid as long a src object exists, and not modified
1477    constructor CreateSubList(ASource: TGDBMIDisassembleResultList; AStartIdx, ACount: Integer);
1478    procedure   InitSubList(ASource: TGDBMIDisassembleResultList; AStartIdx, ACount: Integer);
1479  end;
1480
1481  { TGDBMIDisassembleResultFunctionIterator }
1482
1483  TGDBMIDisassembleResultFunctionIterator = class
1484  private
1485    FCurIdx: Integer;
1486    FIndexOfLocateAddress: Integer;
1487    FOffsetOfLocateAddress: Integer;
1488    FIndexOfCounterAddress: Integer;
1489    FList: TGDBMIDisassembleResultList;
1490    FStartedAtIndex: Integer;
1491    FStartIdx, FMaxIdx: Integer;
1492    FLastSubListEndAddr: TDBGPtr;
1493    FAddressToLocate, FAddForLineAfterCounter: TDBGPtr;
1494    FSublistNumber: Integer;
1495  public
1496    constructor Create(AList: TGDBMIDisassembleResultList; AStartIdx: Integer;
1497                       ALastSubListEndAddr: TDBGPtr;
1498                       AnAddressToLocate, AnAddForLineAfterCounter: TDBGPtr);
1499    function EOL: Boolean;
1500    function NextSubList(var AResultList: TGDBMIDisassembleResultList): Boolean;
1501
1502    // Current SubList
1503    function IsFirstSubList: Boolean;
1504    function CurrentFixedAddr(AOffsLimit: Integer): TDBGPtr; // Addr[0] - Offs[0]
1505    // About the next SubList
1506    function NextStartAddr: TDBGPtr;
1507    function NextStartOffs: Integer;
1508    // Overall
1509    function CountLinesAfterCounterAddr: Integer; // count up to Start of Current SubList
1510
1511    property CurrentIndex: Integer read FCurIdx;
1512    property NextIndex: Integer read FStartIdx;
1513    property SublistNumber: Integer read FSublistNumber; // running count of sublists found
1514
1515    property StartedAtIndex: Integer read FStartedAtIndex;
1516    property IndexOfLocateAddress: Integer read FIndexOfLocateAddress;
1517    property OffsetOfLocateAddress: Integer read FOffsetOfLocateAddress;
1518    property IndexOfCounterAddress: Integer read FIndexOfCounterAddress;
1519    property List: TGDBMIDisassembleResultList read FList;
1520  end;
1521
1522  { TGDBMIDebuggerCommandDisassemble }
1523
1524  TGDBMIDisAssAddrRange = record
1525     FirstAddr, LastAddr: TDBGPtr;
1526  end;
1527
1528  TGDBMIDebuggerCommandDisassemble = class(TGDBMIDebuggerCommand)
1529  private
1530    FEndAddr: TDbgPtr;
1531    FLinesAfter: Integer;
1532    FLinesBefore: Integer;
1533    FOnProgress: TNotifyEvent;
1534    FStartAddr: TDbgPtr;
1535    FKnownRanges: TDBGDisassemblerEntryMap;
1536    FRangeIterator: TDBGDisassemblerEntryMapIterator;
1537    FMemDumpsNeeded: array of TGDBMIDisAssAddrRange;
1538    procedure DoProgress;
1539    {$ifndef disassemblernestedproc}
1540    function AdjustToKnowFunctionStart(var AStartAddr: TDisassemblerAddress): Boolean;
1541    function DoDisassembleRange(AnEntryRanges: TDBGDisassemblerEntryMap; AFirstAddr, ALastAddr: TDisassemblerAddress; StopAfterAddress: TDBGPtr; StopAfterNumLines: Integer): Boolean;
1542    function ExecDisassmble(AStartAddr, AnEndAddr: TDbgPtr; WithSrc: Boolean;
1543                            AResultList: TGDBMIDisassembleResultList = nil;
1544                            ACutBeforeEndAddr: Boolean = False): TGDBMIDisassembleResultList;
1545    function OnCheckCancel: boolean;
1546    {$endif}
1547  protected
1548    function DoExecute: Boolean; override;
1549  public
1550    constructor Create(AOwner: TGDBMIDebugger; AKnownRanges: TDBGDisassemblerEntryMap;
1551                       AStartAddr, AEndAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer);
1552    destructor Destroy; override;
1553    function DebugText: String; override;
1554    property StartAddr: TDbgPtr read FStartAddr write FStartAddr;
1555    property EndAddr:   TDbgPtr read FEndAddr   write FEndAddr;
1556    property LinesBefore: Integer read FLinesBefore write FLinesBefore;
1557    property LinesAfter:  Integer read FLinesAfter  write FLinesAfter;
1558    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
1559  end;
1560
1561  TGDBMIDisassembler = class(TDBGDisassembler)
1562  private
1563    FDisassembleEvalCmdObj: TGDBMIDebuggerCommandDisassemble;
1564    FLastExecAddr, FCancelledAddr: TDBGPtr;
1565    FIsCancelled: Boolean;
1566    procedure DoDisassembleExecuted(Sender: TObject);
1567    procedure DoDisassembleProgress(Sender: TObject);
1568    procedure DoDisassembleDestroyed(Sender: TObject);
1569  protected
1570    function PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override;
1571    function  HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;AnAddr:
1572                 TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean; override;
1573  public
1574    procedure Clear; override;
1575    function PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override;
1576  end;
1577
1578  {%endregion   ^^^^^  Disassembler  ^^^^^   }
1579
1580  {%region      *****  Threads  *****   }
1581
1582  { TGDBMIDebuggerCommandThreads }
1583
1584  TGDBMIDebuggerCommandThreads = class(TGDBMIDebuggerCommand)
1585  private
1586    FCurrentThreadId: Integer;
1587    FCurrentThreads: TThreads;
1588    FSuccess: Boolean;
1589    FThreads: Array of TThreadEntry;
1590    function GetThread(AnIndex: Integer): TThreadEntry;
1591  protected
1592    function DoExecute: Boolean; override;
1593  public
1594    constructor Create(AOwner: TGDBMIDebugger);
1595    destructor Destroy; override;
1596    //function DebugText: String; override;
1597    function Count: Integer;
1598    property Threads[AnIndex: Integer]: TThreadEntry read GetThread;
1599    property CurrentThreadId: Integer read FCurrentThreadId;
1600    property Success: Boolean read FSuccess;
1601    property  CurrentThreads: TThreads read FCurrentThreads write FCurrentThreads;
1602  end;
1603
1604  { TGDBMIThreads }
1605
1606  TGDBMIThreads = class(TThreadsSupplier)
1607  private
1608    FGetThreadsCmdObj: TGDBMIDebuggerCommandThreads;
1609
1610    function GetDebugger: TGDBMIDebugger;
1611    procedure ThreadsNeeded;
1612    procedure CancelEvaluation;
1613    procedure DoThreadsDestroyed(Sender: TObject);
1614    procedure DoThreadsFinished(Sender: TObject);
1615  protected
1616    property Debugger: TGDBMIDebugger read GetDebugger;
1617    procedure DoCleanAfterPause; override;
1618  public
1619    destructor Destroy; override;
1620    procedure RequestMasterData; override;
1621    procedure ChangeCurrentThread(ANewId: Integer); override;
1622  end;
1623
1624  {%endregion   ^^^^^  Threads  ^^^^^   }
1625
1626  { TGDBStringIterator }
1627
1628  TGDBStringIterator=class
1629  protected
1630    FDataSize: Integer;
1631    FReadPointer: Integer;
1632    FParsableData: String;
1633  public
1634    constructor Create(const AParsableData: String);
1635    function ParseNext(out ADecomposable: Boolean; out APayload: String; out ACharStopper: Char): Boolean;
1636  end;
1637
1638  TGDBMIExceptionInfo = record
1639    ObjAddr: String;
1640    Name: String;
1641  end;
1642
1643{ =========================================================================== }
1644{ Some win32 stuff }
1645{ =========================================================================== }
1646{$IFdef MSWindows}
1647var
1648  DebugBreakAddr: Pointer = nil;
1649  // use our own version. Win9x doesn't support this, so it is a nice check
1650  _CreateRemoteThread: function(hProcess: THandle; lpThreadAttributes: Pointer; dwStackSize: DWORD; lpStartAddress: TFNThreadStartRoutine; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall = nil;
1651
1652procedure InitWin32;
1653var
1654  hMod: THandle;
1655begin
1656  // Check if we already are initialized
1657  if DebugBreakAddr <> nil then Exit;
1658
1659  // normally you would load a lib, but since kernel32 is
1660  // always loaded we can use this (and we don't have to free it
1661  hMod := GetModuleHandle(kernel32);
1662  if hMod = 0 then Exit; //????
1663
1664  DebugBreakAddr := GetProcAddress(hMod, 'DebugBreak');
1665  Pointer(_CreateRemoteThread) := GetProcAddress(hMod, 'CreateRemoteThread');
1666end;
1667{$ENDIF}
1668
1669{ =========================================================================== }
1670{ Helpers }
1671{ =========================================================================== }
1672
1673function CpuNameToPtrSize(const CpuName: String): Integer;
1674var
1675  lcCpu: String;
1676begin
1677  //'x86', 'i386', 'i486', 'i586', 'i686',
1678  //'ia64', 'x86_64', 'powerpc', aarch64
1679  //'sparc', 'arm'
1680  Result := 4;
1681  lcCpu := LowerCase(CpuName);
1682  if (lcCpu='ia64') or (lcCpu='x86_64') or (lcCpu='aarch64') or (lcCpu='powerpc64')
1683  then Result := 8;
1684end;
1685
1686{ TGDBMIDebuggerCommandRegisterUpdate }
1687
1688function TGDBMIDebuggerCommandRegisterUpdate.DoExecute: Boolean;
1689  procedure UpdateFormat(AFormat: TRegisterDisplayFormat);
1690  const
1691    // rdDefault, rdHex, rdBinary, rdOctal, rdDecimal, rdRaw
1692    FormatChar : array [TRegisterDisplayFormat] of string =
1693      ('N', 'x', 't', 'o', 'd', 'r');
1694  var
1695    i, idx: Integer;
1696    Num: QWord;
1697    List, ValList: TGDBMINameValueList;
1698    Item: PGDBMINameValue;
1699    RegVal: TRegisterValue;
1700    RegValObj: TRegisterDisplayValue;
1701    t: String;
1702    NumErr: word;
1703    R: TGDBMIExecResult;
1704  begin
1705    if (not ExecuteCommand('-data-list-register-values %s', [FormatChar[AFormat]], R)) or
1706       (R.State = dsError)
1707    then begin
1708      for i := 0 to FRegisters.Count - 1 do
1709        if FRegisters[i].DataValidity in [ddsRequested, ddsEvaluating] then
1710          FRegisters[i].DataValidity := ddsInvalid;
1711      Exit;
1712    end;
1713
1714    ValList := TGDBMINameValueList.Create('');
1715    List := TGDBMINameValueList.Create(R, ['register-values']);
1716    for i := 0 to List.Count - 1 do
1717    begin
1718      Item := List.Items[i];
1719      ValList.Init(Item^.Name);
1720      idx := StrToIntDef(Unquote(ValList.Values['number']), -1);
1721      if (idx < 0) or (idx > High(FGDBMIRegSupplier.FRegNamesCache)) then Continue;
1722      RegVal := FRegisters.EntriesByName[FGDBMIRegSupplier.FRegNamesCache[idx]];
1723      if (RegVal.DataValidity = ddsValid) and (RegVal.HasValueFormat[AFormat]) then continue;
1724
1725      t := Unquote(ValList.Values['value']);
1726      RegValObj := RegVal.ValueObjFormat[AFormat];
1727      if (AFormat in [rdDefault, rdRaw]) or (RegValObj.SupportedDispFormats = [AFormat]) then
1728        RegValObj.SetAsText(t);
1729      Val(t, Num, NumErr);
1730      if NumErr <> 0 then
1731        RegValObj.SetAsText(t)
1732      else
1733      begin
1734        RegValObj.SetAsNum(Num, FTheDebugger.TargetPtrSize);
1735        RegValObj.AddFormats([rdBinary, rdDecimal, rdOctal, rdHex]);
1736      end;
1737      if AFormat = RegVal.DisplayFormat then
1738        RegVal.DataValidity := ddsValid;
1739    end;
1740    FreeAndNil(List);
1741    FreeAndNil(ValList);
1742
1743  end;
1744var
1745  R: TGDBMIExecResult;
1746  List: TGDBMINameValueList;
1747  i, idx: Integer;
1748  ChangedRegList: TGDBMINameValueList;
1749begin
1750  Result := True;
1751  if FRegisters.DataValidity = ddsEvaluating then // in process
1752    exit;
1753
1754  FContext.ThreadContext := ccUseLocal;
1755  FContext.StackContext := ccUseLocal;
1756  FContext.ThreadId := FRegisters.ThreadId;
1757  FContext.StackFrame := FRegisters.StackFrame;
1758
1759  FGDBMIRegSupplier.BeginUpdate;
1760  try
1761    if length(FGDBMIRegSupplier.FRegNamesCache) = 0 then begin
1762      if (not ExecuteCommand('-data-list-register-names', R, [cfNoThreadContext, cfNoStackContext])) or
1763         (R.State = dsError)
1764      then begin
1765        if FRegisters.DataValidity in [ddsRequested, ddsEvaluating] then
1766          FRegisters.DataValidity := ddsInvalid;
1767        exit;
1768      end;
1769
1770      List := TGDBMINameValueList.Create(R, ['register-names']);
1771      SetLength(FGDBMIRegSupplier.FRegNamesCache, List.Count);
1772      for i := 0 to List.Count - 1 do
1773        FGDBMIRegSupplier.FRegNamesCache[i] := UnQuote(List.GetString(i));
1774      FreeAndNil(List);
1775    end;
1776
1777
1778    if FRegisters.DataValidity = ddsRequested then begin
1779      ChangedRegList := nil;
1780      if (FRegisters.StackFrame = 0) and      // need modified, run before all others
1781         ExecuteCommand('-data-list-changed-registers', R, [cfscIgnoreError]) and
1782         (R.State <> dsError)
1783      then
1784        ChangedRegList := TGDBMINameValueList.Create(R, ['changed-registers']);
1785
1786      // Need all registers
1787      FRegisters.DataValidity := ddsEvaluating;
1788      UpdateFormat(rdDefault);
1789      FRegisters.DataValidity := ddsValid;
1790
1791      if ChangedRegList <> nil then begin
1792        for i := 0 to FRegisters.Count - 1 do
1793          FRegisters[i].Modified := False;
1794        for i := 0 to ChangedRegList.Count - 1 do begin
1795          idx := StrToIntDef(Unquote(ChangedRegList.GetString(i)), -1);
1796          if (idx < 0) or (idx > High(FGDBMIRegSupplier.FRegNamesCache)) then Continue;
1797          FRegisters.EntriesByName[FGDBMIRegSupplier.FRegNamesCache[idx]].Modified := True;
1798        end;
1799        FreeAndNil(ChangedRegList);
1800      end;
1801    end;
1802
1803    // check for individual updates / displayformat
1804    for i := 0 to FRegisters.Count - 1 do begin
1805      if not FRegisters[i].HasValue then
1806        UpdateFormat(FRegisters[i].DisplayFormat);
1807    end;
1808  finally
1809    FGDBMIRegSupplier.EndUpdate;
1810  end;
1811end;
1812
1813procedure TGDBMIDebuggerCommandRegisterUpdate.DoCancel;
1814begin
1815  if FRegisters.DataValidity in [ddsRequested, ddsEvaluating] then
1816    FRegisters.DataValidity := ddsInvalid;
1817  inherited DoCancel;
1818end;
1819
1820constructor TGDBMIDebuggerCommandRegisterUpdate.Create(AOwner: TGDBMIDebugger;
1821  AGDBMIRegSupplier: TGDBMIRegisterSupplier; ARegisters: TRegisters);
1822begin
1823  inherited Create(AOwner);
1824  FGDBMIRegSupplier := AGDBMIRegSupplier;
1825  FRegisters := ARegisters;
1826  FRegisters.AddReference;
1827end;
1828
1829destructor TGDBMIDebuggerCommandRegisterUpdate.Destroy;
1830begin
1831  inherited Destroy;
1832  FRegisters.ReleaseReference;
1833end;
1834
1835{ TGDBMIRegisterSupplier }
1836
1837procedure TGDBMIRegisterSupplier.DoStateChange(const AOldState: TDBGState);
1838begin
1839  if not( (AOldState in [dsPause, dsInternalPause]) and (Debugger.State in [dsPause, dsInternalPause]) )
1840  then
1841    SetLength(FRegNamesCache, 0);
1842  inherited DoStateChange(AOldState);
1843end;
1844
1845procedure TGDBMIRegisterSupplier.Changed;
1846begin
1847  if CurrentRegistersList <> nil
1848  then CurrentRegistersList.Clear;
1849end;
1850
1851procedure TGDBMIRegisterSupplier.RequestData(ARegisters: TRegisters);
1852var
1853  ForceQueue: Boolean;
1854  Cmd: TGDBMIDebuggerCommandRegisterUpdate;
1855begin
1856  if (Debugger = nil) or not(Debugger.State in [dsPause, dsStop]) then
1857    exit;
1858
1859  Cmd := TGDBMIDebuggerCommandRegisterUpdate.Create(TGDBMIDebugger(Debugger), Self, ARegisters);
1860  //Cmd.OnExecuted := @DoGetRegisterNamesFinished;
1861  //Cmd.OnDestroy   := @DoGetRegisterNamesDestroyed;
1862  Cmd.Priority := GDCMD_PRIOR_LOCALS;
1863  Cmd.Properties := [dcpCancelOnRun];
1864  ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
1865            and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
1866            and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
1867            and (Debugger.State <> dsInternalPause);
1868  TGDBMIDebugger(Debugger).QueueCommand(Cmd, ForceQueue);
1869end;
1870
1871{ TGDBMIDebuggerChangeFilenameBase }
1872
1873function TGDBMIDebuggerChangeFilenameBase.DoChangeFilename: Boolean;
1874var
1875  R: TGDBMIExecResult;
1876  List: TGDBMINameValueList;
1877  S: String;
1878begin
1879  Result := False;
1880  FContext.ThreadContext := ccNotRequired;
1881  FContext.StackContext := ccNotRequired;
1882
1883  //Cleanup our own breakpoints
1884  FTheDebugger.FExceptionBreak.Clear(Self);
1885  FTheDebugger.FBreakErrorBreak.Clear(Self);
1886  FTheDebugger.FRunErrorBreak.Clear(Self);
1887  FTheDebugger.FPopExceptStack.Clear(Self);
1888  FTheDebugger.FCatchesBreak.Clear(Self);
1889  FTheDebugger.FReRaiseBreak.Clear(Self);
1890  {$ifdef WIN64}
1891  FTheDebugger.FRtlUnwindExBreak.Clear(Self);
1892  FTheDebugger.FSehRaiseBreaks.ClearAll(Self);
1893  {$endif}
1894  if DebuggerState = dsError then Exit;
1895
1896  S := FTheDebugger.ConvertToGDBPath(FTheDebugger.FileName, cgptExeName);
1897  Result := ExecuteCommand('-file-exec-and-symbols %s', [S], R);
1898  if not Result then exit;
1899  {$IFDEF darwin}
1900  if  (R.State = dsError) and (FTheDebugger.FileName <> '')
1901  then begin
1902    S := FTheDebugger.FileName + '/Contents/MacOS/' + ExtractFileNameOnly(FTheDebugger.FileName);
1903    S := FTheDebugger.ConvertToGDBPath(S, cgptExeName);
1904    Result := ExecuteCommand('-file-exec-and-symbols %s', [S], R);
1905    if not Result then exit;
1906  end;
1907  {$ENDIF}
1908
1909  if  (R.State = dsError) and (FTheDebugger.FileName <> '')
1910  then begin
1911    List := TGDBMINameValueList.Create(R);
1912    FErrorMsg := DeleteEscapeChars((List.Values['msg']));
1913    List.Free;
1914    Result := False;
1915    Exit;
1916  end;
1917end;
1918
1919function TGDBMIDebuggerChangeFilenameBase.DoSetPascal: Boolean;
1920begin
1921  Result := True;
1922
1923  FContext.ThreadContext := ccNotRequired;
1924  FContext.StackContext := ccNotRequired;
1925  // Force setting language
1926  // Setting extensions dumps GDB (bug #508)
1927  Result := ExecuteCommand('-gdb-set language pascal', [], [cfCheckError]);
1928  Result := Result and (DebuggerState <> dsError);
1929(*
1930    ExecuteCommand('-gdb-set extension-language .lpr pascal', False);
1931    if not FHasSymbols then Exit; // file-exec-and-symbols not allways result in no symbols
1932    ExecuteCommand('-gdb-set extension-language .lrs pascal', False);
1933    ExecuteCommand('-gdb-set extension-language .dpr pascal', False);
1934    ExecuteCommand('-gdb-set extension-language .pas pascal', False);
1935    ExecuteCommand('-gdb-set extension-language .pp pascal', False);
1936    ExecuteCommand('-gdb-set extension-language .inc pascal', False);
1937*)
1938end;
1939
1940function TGDBMIDebuggerChangeFilenameBase.DoSetCaseSensitivity: Boolean;
1941begin
1942  case TGDBMIDebuggerProperties(FTheDebugger.GetProperties).CaseSensitivity of
1943  	gdcsSmartOff:  if (FTheDebugger.FGDBVersionMajor > 7) or
1944      ( (FTheDebugger.FGDBVersionMajor = 7) and (FTheDebugger.FGDBVersionMinor >= 4) )
1945      then
1946        ExecuteCommand('-gdb-set case-sensitive off', [], []);
1947    gdcsAlwaysOff: ExecuteCommand('-gdb-set case-sensitive off', [], []);
1948    gdcsAlwaysOn:  ExecuteCommand('-gdb-set case-sensitive on', [], []);
1949    gdcsGdbDefault: ; // do nothing
1950  end;
1951  Result:=true;
1952end;
1953
1954function TGDBMIDebuggerChangeFilenameBase.DoSetMaxValueMemLimit: Boolean;
1955var
1956  i: Integer;
1957begin
1958  if (FTheDebugger.FGDBVersionMajor < 7) then
1959    exit(false);
1960  // available from GDB 7.11
1961  i := TGDBMIDebuggerProperties(FTheDebugger.GetProperties).GdbValueMemLimit;
1962  if i > 0 then
1963    ExecuteCommand('set max-value-size %d', [i], [])
1964  else
1965  if i = 0 then
1966    ExecuteCommand('set max-value-size unlimited', [], []);
1967  Result:=true;
1968end;
1969
1970function TGDBMIDebuggerChangeFilenameBase.DoSetAssemblerStyle: Boolean;
1971begin
1972  case TGDBMIDebuggerProperties(FTheDebugger.GetProperties).AssemblerStyle of
1973    gdasIntel: ExecuteCommand('-gdb-set disassembly-flavor intel', [], []);
1974    gdasATT: ExecuteCommand('-gdb-set disassembly-flavor att', [], []);
1975  end;
1976  Result:=true;
1977end;
1978
1979function TGDBMIDebuggerChangeFilenameBase.DoSetDisableStartupShell: Boolean;
1980begin
1981  if TGDBMIDebuggerProperties(FTheDebugger.GetProperties).DisableStartupShell then
1982    ExecuteCommand('set startup-with-shell off', [], []);
1983  Result:=true;
1984end;
1985
1986
1987{ TGDBMIDbgInstructionQueue }
1988
1989procedure TGDBMIDbgInstructionQueue.HandleGdbDataBeforeInstruction(var AData: String;
1990  var SkipData: Boolean; const TheInstruction: TGDBInstruction);
1991
1992  procedure DoConsoleStream(Line: String);
1993  begin
1994    // check for symbol info
1995    if Pos('no debugging symbols', Line) > 0
1996    then begin
1997      Debugger.TargetFlags := Debugger.TargetFlags - [tfHasSymbols];
1998      Debugger.DoDbgEvent(ecDebugger, etDefault, Format(gdbmiEventLogNoSymbols, [Debugger.FileName]));
1999    end;
2000  end;
2001
2002  procedure DoLogStream(const Line: String);
2003  begin
2004    // check for symbol info
2005    if Pos('No symbol table is loaded.  Use the \"file\" command.', Line) > 0
2006    then begin
2007      Debugger.TargetFlags := Debugger.TargetFlags - [tfHasSymbols];
2008      Debugger.DoDbgEvent(ecDebugger, etDefault,
2009        Format(gdbmiEventLogNoSymbols, [Debugger.FileName]));
2010    end;
2011
2012    // check internal error
2013    Debugger.CheckForInternalError(Line, TheInstruction.DebugText);
2014
2015  end;
2016
2017begin
2018  if AData <> ''
2019  then case AData[1] of
2020    '~': DoConsoleStream(AData);
2021    //'@': DoTargetStream(AData);
2022    '&': DoLogStream(AData);
2023    //'*': DoExecAsync(AData);
2024    //'+': DoStatusAsync(AData);
2025    //'=': DoMsgAsync(AData);
2026  end;
2027
2028  inherited HandleGdbDataBeforeInstruction(AData, SkipData, TheInstruction);
2029end;
2030
2031function TGDBMIDbgInstructionQueue.Debugger: TGDBMIDebugger;
2032begin
2033  Result := TGDBMIDebugger(inherited Debugger);
2034end;
2035
2036{ TGDBMIDebuggerInstruction }
2037
2038function TGDBMIDebuggerInstruction.ProcessInputFromGdb(const AData: String): Boolean;
2039
2040  function DoResultRecord(Line: String; CurRes: Boolean): Boolean;
2041  var
2042    ResultClass: String;
2043    OldResult: Boolean;
2044  begin
2045    ResultClass := GetPart('^', ',', Line);
2046
2047    if Line = ''
2048    then begin
2049      if FResultData.Values <> ''
2050      then Include(FResultData.Flags, rfNoMI);
2051    end
2052    else begin
2053      FResultData.Values := Line;
2054    end;
2055
2056    OldResult := CurRes;
2057    Result := True;
2058    case StringCase(ResultClass, ['done', 'running', 'exit', 'error', 'stopped']) of
2059      0: begin // done
2060      end;
2061      1: begin // running
2062        FResultData.State := dsRun;
2063      end;
2064      2: begin // exit
2065        FResultData.State := dsIdle;
2066      end;
2067      3: begin // error
2068        DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessResult Error: ', Line);
2069        // todo: implement with values
2070        if  (pos('msg=', Line) > 0)
2071        and (pos('not being run', Line) > 0)
2072        then FResultData.State := dsStop
2073        else FResultData.State := dsError;
2074      end;
2075      4: begin
2076        FCmd.FGotStopped := True;
2077        //AStoppedParams := Line;
2078      end;
2079    else
2080      //TODO: should that better be dsError ?
2081      if OldResult and (FResultData.State in [dsError, dsStop]) and
2082         (copy(ResultClass,1,6) = 'error"')
2083      then begin
2084        // Gdb 6.3.5 on Mac, does sometime return a 2nd mis-formatted error line
2085        // The line seems truncated, it simply is (note the misplaced quote): ^error"
2086        DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class (IGNORING): ', ResultClass);
2087      end
2088      else begin
2089        Result := False;
2090        DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
2091      end;
2092    end;
2093  end;
2094
2095  procedure DoConsoleStream(Line: String);
2096  var
2097    len: Integer;
2098  begin
2099    // Strip surrounding ~" "
2100    len := Length(Line) - 3;
2101    if len < 0 then Exit;
2102    Line := Copy(Line, 3, len);
2103    // strip trailing \n (unless it is escaped \\n)
2104    if (len >= 2) and (Line[len - 1] = '\') and (Line[len] = 'n')
2105    then begin
2106      if len = 2
2107      then Line := LineEnding
2108      else if Line[len - 2] <> '\'
2109      then begin
2110        SetLength(Line, len - 2);
2111        Line := Line + LineEnding;
2112      end;
2113    end;
2114
2115    FResultData.Values := FResultData.Values + Line;
2116  end;
2117
2118  procedure DoTargetStream(const Line: String);
2119  begin
2120    DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
2121  end;
2122
2123  procedure DoLogStream(const Line: String);
2124  //const
2125  //  LogWarning = '&"warning:"';
2126  begin
2127    DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
2128    if Line = '&"kill\n"'
2129    then FResultData.State := dsStop
2130    else if LeftStr(Line, 8) = '&"Error '
2131    then FResultData.State := dsError;
2132    if LowerCase(copy(Line, 1, length(FLogWarnings))) = FLogWarnings
2133    then FInLogWarning := True;
2134    if FInLogWarning
2135    then FLogWarnings := FLogWarnings + copy(Line, 3, length(Line)-5) + LineEnding;
2136    if Line = '&"\n"' then
2137      FInLogWarning := False;
2138  end;
2139
2140  procedure DoExecAsync(Line: String);
2141  var
2142    S: String;
2143    ct: TThreads;
2144    i: Integer;
2145    t: TThreadEntry;
2146  begin
2147    S := GetPart(['*'], [','], Line);
2148    if S = 'running'
2149    then begin
2150      if (FCmd.FTheDebugger.Threads.CurrentThreads <> nil)
2151      then begin
2152        ct := FCmd.FTheDebugger.Threads.CurrentThreads;
2153        S := GetPart('thread-id="', '"', Line);
2154        if s = 'all' then begin
2155          for i := 0 to  ct.Count - 1 do
2156            ct[i].ThreadState := 'running'; // TODO enum?
2157        end
2158        else begin
2159          S := S + ',';
2160          while s <> '' do begin
2161            i := StrToIntDef(GetPart('', ',', s), -1);
2162            if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
2163            else begin
2164              debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
2165              break
2166            end;
2167            if i < 0 then Continue;
2168            t := ct.EntryById[i];
2169            if t <> nil then
2170              t.ThreadState := 'running'; // TODO enum?
2171          end;
2172        end;
2173        FCmd.FTheDebugger.Threads.Changed;
2174      end;
2175
2176      FCmd.DoDbgEvent(ecProcess, etProcessStart,
2177        Format(gdbmiEventLogProcessStart, [FCmd.FTheDebugger.FileName]));
2178    end
2179    else
2180    if S = 'stopped' then begin
2181      FCmd.FGotStopped := True;
2182      // StoppedParam ??
2183    end
2184    else
2185      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
2186  end;
2187
2188  procedure DoMsgAsync(Line: String);
2189  var
2190    S: String;
2191  begin
2192    S := GetPart('=', ',', Line, False, False);
2193    if s = 'thread-group-started' then begin  // thread-group-started // needed in RunToMain
2194      // Todo, store in seperate field
2195      if FCmd is TGDBMIDebuggerCommandStartDebugging then
2196        FLogWarnings := FLogWarnings + Line + LineEnding;
2197    end;
2198
2199     FCmd.FTheDebugger.DoNotifyAsync(Line);
2200  end;
2201
2202  procedure DoStatusAsync(const Line: String);
2203  begin
2204    DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
2205  end;
2206
2207begin
2208  Result := True;
2209  FFullCmdReply := FFullCmdReply + AData + LineEnding;
2210  if AData = '(gdb) ' then begin
2211    MarkAsSuccess;
2212    exit;
2213  end;
2214  //if (AData = '^exit') and (FCmd = '-gdb-exit') then begin
2215  //  // no (gdb) expected
2216  //  MarkAsSuccess;
2217  //end;
2218
2219  if AData <> '' then begin
2220    if AData[1] <> '&' then
2221      FInLogWarning := False;
2222    case AData[1] of
2223      '^': FHasResult := DoResultRecord(AData, Result);
2224      '~': DoConsoleStream(AData);
2225      '@': DoTargetStream(AData);
2226      '&': DoLogStream(AData);
2227      '*': DoExecAsync(AData);
2228      '+': DoStatusAsync(AData);
2229      '=': DoMsgAsync(AData);
2230    else
2231      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown record: ', AData);
2232    end;
2233  end;
2234  {$IFDEF VerboseIDEToDo}{$message warning condition should also check end-of-file reached for process output stream}{$ENDIF}
2235end;
2236
2237procedure TGDBMIDebuggerInstruction.HandleNoGdbRunning;
2238begin
2239  if FHasResult and (Command = '-gdb-exit') then begin
2240    // no (gdb) expected
2241    MarkAsSuccess;
2242  end
2243  else
2244    inherited HandleNoGdbRunning;
2245end;
2246
2247procedure TGDBMIDebuggerInstruction.HandleReadError;
2248begin
2249  if FHasResult and (Command = '-gdb-exit') then begin
2250    // no (gdb) expected
2251    MarkAsSuccess;
2252  end
2253  else
2254    inherited HandleReadError;
2255end;
2256
2257procedure TGDBMIDebuggerInstruction.HandleTimeOut;
2258begin
2259  if FHasResult and (Command = '-gdb-exit') then begin
2260    // no (gdb) expected
2261    MarkAsSuccess;
2262  end
2263  else
2264    inherited HandleTimeOut;
2265end;
2266
2267function TGDBMIDebuggerInstruction.GetTimeOutVerifier: TGDBInstruction;
2268begin
2269  if FHasResult and (Command = '-gdb-exit') then
2270    Result := nil
2271  else
2272    Result := inherited GetTimeOutVerifier;
2273end;
2274
2275procedure TGDBMIDebuggerInstruction.Init;
2276begin
2277  inherited Init;
2278  FHasResult := False;
2279  FResultData.Values := '';
2280  FResultData.Flags := [];
2281  FResultData.State := dsNone;
2282  FFullCmdReply := '';
2283  FLogWarnings := '';
2284  FInLogWarning := False;
2285end;
2286
2287{ TGDBMIDebuggerCommandStartBase }
2288
2289procedure TGDBMIDebuggerCommandStartBase.SetTargetInfo(const AFileType: String);
2290var
2291  FoundPtrSize, UseWin64ABI: Boolean;
2292begin
2293  UseWin64ABI := False;
2294  // assume some defaults
2295  TargetInfo^.TargetPtrSize := GetIntValue('sizeof(%s)', [PointerTypeCast]);
2296  FoundPtrSize := (FLastExecResult.State <> dsError) and (TargetInfo^.TargetPtrSize > 0);
2297  if not FoundPtrSize
2298  then TargetInfo^.TargetPtrSize := 4;
2299  TargetInfo^.TargetIsBE := False;
2300
2301  if LeftStr(AFileType,4) = 'pei-' then
2302    TargetInfo^.TargetOS := osWindows;
2303
2304  case StringCase(AFileType, [
2305    'efi-app-ia32', 'elf32-i386', 'pei-i386', 'elf32-i386-freebsd',
2306    'elf64-x86-64', 'pei-x86-64',
2307    'mach-o-be',
2308    'mach-o-le',
2309    'pei-arm-little',
2310    'pei-arm-big',
2311    'elf64-littleaarch64',
2312    'elf64-bigaarch64'
2313  ], True, False) of
2314    0..3: TargetInfo^.TargetCPU := 'x86';
2315    4: TargetInfo^.TargetCPU := 'x86_64'; //TODO: should we check, PtrSize must be 8, but what if not?
2316    5: begin
2317      TargetInfo^.TargetCPU := 'x86_64'; //TODO: should we check, PtrSize must be 8, but what if not?
2318      UseWin64ABI := True;
2319    end;
2320    6: begin
2321       //mach-o-be
2322      TargetInfo^.TargetIsBE := True;
2323      if FTheDebugger.FGDBCPU <> ''
2324      then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
2325      else TargetInfo^.TargetCPU := 'powerpc'; // guess
2326    end;
2327    7: begin
2328      //mach-o-le
2329      if FoundPtrSize then begin
2330        if FTheDebugger.FGDBPtrSize = TargetInfo^.TargetPtrSize
2331        then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
2332        else // guess
2333          case TargetInfo^.TargetPtrSize of
2334            4: TargetInfo^.TargetCPU := 'x86'; // guess
2335            8: TargetInfo^.TargetCPU := 'x86_64'; // guess
2336            else TargetInfo^.TargetCPU := 'x86'; // guess
2337          end
2338      end
2339      else begin
2340        if FTheDebugger.FGDBCPU <> ''
2341        then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
2342        else TargetInfo^.TargetCPU := 'x86'; // guess
2343      end;
2344    end;
2345    8: begin
2346      TargetInfo^.TargetCPU := 'arm';
2347    end;
2348    9: begin
2349      TargetInfo^.TargetIsBE := True;
2350      TargetInfo^.TargetCPU := 'arm';
2351    end;
2352    10: begin
2353      TargetInfo^.TargetCPU := 'aarch64';
2354    end;
2355    11: begin
2356      TargetInfo^.TargetIsBE := True;
2357      TargetInfo^.TargetCPU := 'aarch64';
2358    end;
2359  else
2360    // Unknown filetype, use GDB cpu
2361    DebugLn(DBG_WARNINGS, '[WARNING] [Debugger.TargetInfo] Unknown FileType: %s, using GDB cpu', [AFileType]);
2362
2363    TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU;
2364    // Todo: check PtrSize and downgrade 64 bit cpu to 32 bit cpu, if required
2365  end;
2366
2367  if not FoundPtrSize
2368  then TargetInfo^.TargetPtrSize := CpuNameToPtrSize(TargetInfo^.TargetCPU);
2369
2370  case StringCase(TargetInfo^.TargetCPU, [
2371    'x86', 'i386', 'i486', 'i586', 'i686',
2372    'ia64', 'x86_64', 'powerpc', 'powerpc64',
2373    'sparc', 'arm', 'aarch64'
2374  ], True, False) of
2375    0..4: begin // x86
2376      TargetInfo^.TargetRegisters[0] := '$eax';
2377      TargetInfo^.TargetRegisters[1] := '$edx';
2378      TargetInfo^.TargetRegisters[2] := '$ecx';
2379    end;
2380    5, 6: begin // ia64, x86_64
2381      if TargetInfo^.TargetPtrSize = 4
2382      then begin
2383        TargetInfo^.TargetRegisters[0] := '$eax';
2384        TargetInfo^.TargetRegisters[1] := '$edx';
2385        TargetInfo^.TargetRegisters[2] := '$ecx';
2386      end
2387      else if UseWin64ABI
2388      then begin
2389        TargetInfo^.TargetRegisters[0] := '$rcx';
2390        TargetInfo^.TargetRegisters[1] := '$rdx';
2391        TargetInfo^.TargetRegisters[2] := '$r8';
2392      end else
2393      begin
2394        TargetInfo^.TargetRegisters[0] := '$rdi';
2395        TargetInfo^.TargetRegisters[1] := '$rsi';
2396        TargetInfo^.TargetRegisters[2] := '$rdx';
2397      end;
2398    end;
2399    7, 8: begin // powerpc,powerpc64
2400      TargetInfo^.TargetIsBE := True;
2401      // alltough darwin can start with r2, it seems that all OS start with r3
2402//        if UpperCase(FTargetInfo.TargetOS) = 'DARWIN'
2403//        then begin
2404//          FTargetInfo.TargetRegisters[0] := '$r2';
2405//          FTargetInfo.TargetRegisters[1] := '$r3';
2406//          FTargetInfo.TargetRegisters[2] := '$r4';
2407//        end
2408//        else begin
2409        TargetInfo^.TargetRegisters[0] := '$r3';
2410        TargetInfo^.TargetRegisters[1] := '$r4';
2411        TargetInfo^.TargetRegisters[2] := '$r5';
2412//        end;
2413    end;
2414    9: begin // sparc
2415      TargetInfo^.TargetIsBE := True;
2416      TargetInfo^.TargetRegisters[0] := '$g1';
2417      TargetInfo^.TargetRegisters[1] := '$o0';
2418      TargetInfo^.TargetRegisters[2] := '$o1';
2419    end;
2420    10: begin // arm
2421      TargetInfo^.TargetRegisters[0] := '$r0';
2422      TargetInfo^.TargetRegisters[1] := '$r1';
2423      TargetInfo^.TargetRegisters[2] := '$r2';
2424    end;
2425    11: begin // aarch64
2426      //TargetInfo^.TargetRegisters[0] := '$r0';
2427      //TargetInfo^.TargetRegisters[1] := '$r1';
2428      //TargetInfo^.TargetRegisters[2] := '$r2';
2429      TargetInfo^.TargetRegisters[0] := '$x0';
2430      TargetInfo^.TargetRegisters[1] := '$x1';
2431      TargetInfo^.TargetRegisters[2] := '$x2';
2432    end;
2433  else
2434    TargetInfo^.TargetRegisters[0] := '';
2435    TargetInfo^.TargetRegisters[1] := '';
2436    TargetInfo^.TargetRegisters[2] := '';
2437    DebugLn(DBG_WARNINGS, '[WARNING] [Debugger] Unknown target CPU: ', TargetInfo^.TargetCPU);
2438  end;
2439end;
2440
2441function TGDBMIDebuggerCommandStartBase.CheckFunction(const AFunction: String
2442  ): Boolean;
2443var
2444  R: TGDBMIExecResult;
2445  idx: Integer;
2446begin
2447  ExecuteCommand('info functions %s', [AFunction], R, [cfCheckState]);
2448  idx := Pos(AFunction, R.Values);
2449  if idx <> 0
2450  then begin
2451    // Strip first
2452    Delete(R.Values, 1, idx + Length(AFunction) - 1);
2453    idx := Pos(AFunction, R.Values);
2454  end;
2455  Result := idx <> 0;
2456end;
2457
2458procedure TGDBMIDebuggerCommandStartBase.RetrieveRegcall;
2459var
2460  R: TGDBMIExecResult;
2461begin
2462  // Assume it is
2463  Include(TargetInfo^.TargetFlags, tfRTLUsesRegCall);
2464
2465  ExecuteCommand('-data-evaluate-expression FPC_THREADVAR_RELOCATE_PROC', R);
2466  if R.State <> dsError then Exit; // guessed right
2467
2468  // next attempt, posibly no symbols, try functions
2469  if CheckFunction('FPC_CPUINIT') then Exit; // function present --> not 1.0
2470
2471  // this runerror is only defined for < 1.1 ?
2472  if not CheckFunction('$$_RUNERROR$') then Exit;
2473
2474  // We are here in 2 cases
2475  // 1) there are no symbols at all
2476  //    We do not have to know the calling convention
2477  // 2) target is compiled with an earlier version than 1.9.2
2478  //    params are passes by stack
2479  Exclude(TargetInfo^.TargetFlags, tfRTLUsesRegCall);
2480end;
2481
2482procedure TGDBMIDebuggerCommandStartBase.CheckAvailableTypes;
2483var
2484  HadTimeout: Boolean;
2485  R: TGDBMIExecResult;
2486begin
2487  // collect timeouts
2488  HadTimeout := False;
2489  // check whether we need class cast dereference
2490  R := CheckHasType('TObject', tfFlagHasTypeObject);
2491  HadTimeout := HadTimeout and LastExecwasTimeOut;
2492  if R.State <> dsError
2493  then begin
2494    if UpperCase(LeftStr(R.Values, 15)) = UpperCase('type = ^TOBJECT')
2495    then include(TargetInfo^.TargetFlags, tfClassIsPointer);
2496  end;
2497  R := CheckHasType('Exception', tfFlagHasTypeException);
2498  HadTimeout := HadTimeout and LastExecwasTimeOut;
2499  if R.State <> dsError
2500  then begin
2501    if UpperCase(LeftStr(R.Values, 17)) = UpperCase('type = ^EXCEPTION')
2502    then include(TargetInfo^.TargetFlags, tfExceptionIsPointer);
2503  end;
2504  CheckHasType('Shortstring', tfFlagHasTypeShortstring);
2505  HadTimeout := HadTimeout and LastExecwasTimeOut;
2506  //CheckHasType('PShortstring', tfFlagHasTypePShortString);
2507  //HadTimeout := HadTimeout and LastExecwasTimeOut;
2508  CheckHasType('pointer', tfFlagHasTypePointer);
2509  HadTimeout := HadTimeout and LastExecwasTimeOut;
2510  CheckHasType('byte', tfFlagHasTypeByte);
2511  HadTimeout := HadTimeout and LastExecwasTimeOut;
2512  //CheckHasType('char', tfFlagHasTypeChar);
2513  //HadTimeout := HadTimeout and LastExecwasTimeOut;
2514
2515  if HadTimeout then DoTimeoutFeedback;
2516end;
2517
2518procedure TGDBMIDebuggerCommandStartBase.DetectForceableBreaks;
2519var
2520  R: TGDBMIExecResult;
2521  List: TGDBMINameValueList;
2522begin
2523  if DebuggerProperties.DisableForcedBreakpoint then
2524    exit;
2525
2526  if not (dfForceBreakDetected in FTheDebugger.FDebuggerFlags) then begin
2527    // detect if we can insert a not yet known break
2528    ExecuteCommand('-break-insert -f foo', R);
2529    if R.State <> dsError
2530    then begin
2531      Include(FTheDebugger.FDebuggerFlags, dfForceBreak);
2532      List := TGDBMINameValueList.Create(R, ['bkpt']);
2533      ExecuteCommand('-break-delete ' + List.Values['number']);
2534      List.Free;
2535    end
2536    else Exclude(FTheDebugger.FDebuggerFlags, dfForceBreak);
2537    Include(FTheDebugger.FDebuggerFlags, dfForceBreakDetected);
2538  end;
2539end;
2540
2541procedure TGDBMIDebuggerCommandStartBase.CommonInit;
2542var
2543  i: TGDBMIExecCommandType;
2544begin
2545  for i := low(TGDBMIExecCommandType) to high(TGDBMIExecCommandType) do begin
2546    FTheDebugger.FCommandAsyncState[i] := True;
2547    FTheDebugger.FCommandNoneMiState[i] := DebuggerProperties.UseNoneMiRunCommands = gdnmAlways;
2548  end;
2549  FTheDebugger.FCurrentCmdIsAsync := False;
2550  ExecuteCommand('set print elements %d',
2551                 [TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).MaxDisplayLengthForString],
2552                 []);
2553
2554  if DebuggerProperties.DisableLoadSymbolsForLibraries then begin
2555    ExecuteCommand('set auto-solib-add off', [cfscIgnoreState, cfscIgnoreError]);
2556    FTheDebugger.FWasDisableLoadSymbolsForLibraries := True;
2557  end
2558  else begin
2559    // Only unset, if it was set due to this property
2560    if FTheDebugger.FWasDisableLoadSymbolsForLibraries then
2561      ExecuteCommand('set auto-solib-add on', [cfscIgnoreState, cfscIgnoreError]);
2562    FTheDebugger.FWasDisableLoadSymbolsForLibraries := False;
2563  end;
2564end;
2565
2566procedure TGDBMIDebuggerCommandStartBase.DetectTargetPid(InAttach: Boolean);
2567var
2568  R: TGDBMIExecResult;
2569  s: String;
2570  List: TGDBMINameValueList;
2571begin
2572  if TargetInfo^.TargetPID <> 0 then
2573    exit;
2574    (* PID via "info program"
2575
2576       Somme linux, gdb 7.1
2577         ~"\tUsing the running image of child Thread 0xb7fd8820 (LWP 2125).\n"
2578
2579       On FreeBSD LWP may differ from PID
2580       FreeBSD 9.0 GDB 6.1 (modified ?, supplied by FreeBSD)
2581       PID is not equal to LWP.
2582         Using the running image of child Thread 807407400 (LWP 100229/project1).
2583
2584       Win GDB 7.4
2585         ~"\tUsing the running image of child Thread 8876.0x21c0.\n"
2586*)
2587    if not InAttach then begin
2588      // "info program" may crash after attach
2589      if ExecuteCommand('info program', [], R, [cfCheckState])
2590      then begin
2591        s := GetPart(['child process ', 'child thread ', 'lwp '], [' ', '.', ')'],
2592                     R.Values, True);
2593        TargetInfo^.TargetPID := StrToIntDef(s, 0);
2594        if TargetInfo^.TargetPID <> 0 then exit;
2595      end;
2596    end;
2597
2598    // apple
2599    if ExecuteCommand('info pid', [], R, [cfCheckState]) and (R.State <> dsError)
2600    then begin
2601      List := TGDBMINameValueList.Create(R);
2602      TargetInfo^.TargetPID := StrToIntDef(List.Values['process-id'], 0);
2603      List.Free;
2604      if TargetInfo^.TargetPID <> 0 then exit;
2605    end;
2606
2607    if not InAttach then begin
2608      // gdb server
2609      if ExecuteCommand('info proc', [], R, [cfCheckState]) and (R.State <> dsError)
2610      then begin
2611        s := GetPart(['process '], [#10,#13#10], R.Values, True);
2612        TargetInfo^.TargetPID := StrToIntDef(s, 0);
2613        if TargetInfo^.TargetPID <> 0 then exit;
2614      end;
2615    end;
2616
2617    // apple / MacPort 7.1 / 32 bit dwarf
2618    if ExecuteCommand('info threads', [], R, [cfCheckState]) and (R.State <> dsError)
2619    then begin
2620      s := GetPart(['of process '], [' '], R.Values, True);
2621      TargetInfo^.TargetPID := StrToIntDef(s, 0);
2622      if TargetInfo^.TargetPID <> 0 then exit;
2623
2624      // returned by gdb server (maybe others)
2625      s := GetPart(['Thread '], [' ', '.'], R.Values, True);
2626      TargetInfo^.TargetPID := StrToIntDef(s, 0);
2627      if TargetInfo^.TargetPID <> 0 then exit;
2628    end;
2629
2630    // no PID found
2631    if not InAttach then
2632      SetDebuggerErrorState(Format(gdbmiCommandStartMainRunNoPIDError, [LineEnding]));
2633end;
2634
2635{ TGDBMIDebuggerCommandExecuteBase }
2636
2637function TGDBMIDebuggerCommandExecuteBase.ProcessRunning(out AStoppedParams: String; out
2638  AResult: TGDBMIExecResult; ATimeOut: Integer): Boolean;
2639var
2640  InLogWarning, ForceStop: Boolean;
2641
2642  function DoExecAsync(var Line: String): Boolean;
2643  var
2644    S: String;
2645    i: Integer;
2646    ct: TThreads;
2647    t: TThreadEntry;
2648  begin
2649    Result := False;
2650    S := GetPart('*', ',', Line);
2651    case StringCase(S, ['stopped', 'started', 'disappeared', 'running']) of
2652      0: begin // stopped
2653          AStoppedParams := Line;
2654          FGotStopped := True;
2655        end;
2656      1: ; // Known, but undocumented classes
2657      2: FGotStopped := True;
2658      3: begin // running,thread-id="1"  // running,thread-id="all"
2659          if (FTheDebugger.Threads.CurrentThreads <> nil)
2660          then begin
2661            ct := FTheDebugger.Threads.CurrentThreads;
2662            S := GetPart('thread-id="', '"', Line);
2663            if s = 'all' then begin
2664              for i := 0 to  ct.Count - 1 do
2665                ct[i].ThreadState := 'running'; // TODO enum?
2666            end
2667            else begin
2668              S := S + ',';
2669              while s <> '' do begin
2670                i := StrToIntDef(GetPart('', ',', s), -1);
2671                if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
2672                else begin
2673                  debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
2674                  break
2675                end;
2676                if i < 0 then Continue;
2677                t := ct.EntryById[i];
2678                if t <> nil then
2679                  t.ThreadState := 'running'; // TODO enum?
2680              end;
2681            end;
2682            FTheDebugger.Threads.Changed;
2683          end;
2684        end;
2685    else
2686      // Assume targetoutput, strip char and continue
2687      DebugLn(DBG_VERBOSE, '[DBGTGT] *');
2688      Line := S + Line;
2689      Result := True;
2690    end;
2691  end;
2692
2693  procedure DoMsgAsync(var Line: String);
2694  begin
2695     FTheDebugger.DoNotifyAsync(Line);
2696  end;
2697
2698  procedure DoStatusAsync(const Line: String);
2699  begin
2700    DebugLn(DBG_VERBOSE, '[Debugger] Status output: ', Line);
2701  end;
2702
2703  procedure DoResultRecord(Line: String);
2704  var
2705    ResultClass: String;
2706  begin
2707    DebugLn(DBG_WARNINGS, '[WARNING] Debugger: unexpected result-record: ', Line);
2708
2709    ResultClass := GetPart('^', ',', Line);
2710    if Line = ''
2711    then begin
2712      if AResult.Values <> ''
2713      then Include(AResult.Flags, rfNoMI);
2714    end
2715    else begin
2716      AResult.Values := Line;
2717    end;
2718
2719    //Result := True;
2720    case StringCase(ResultClass, ['done', 'running', 'exit', 'error']) of
2721      0: begin // done
2722        AResult.State := dsIdle; // just indicate a ressult <> dsNone
2723      end;
2724      1: begin // running
2725        AResult.State := dsRun;
2726      end;
2727      2: begin // exit
2728        AResult.State := dsIdle;
2729      end;
2730      3: begin // error
2731        DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessRunning Error: ', Line);
2732        // todo: implement with values
2733        if  (pos('msg=', Line) > 0)
2734        and (pos('not being run', Line) > 0)
2735        then AResult.State := dsStop
2736        else AResult.State := dsError;
2737      end;
2738    else
2739      //TODO: should that better be dsError ?
2740      //Result := False;
2741      AResult.State := dsIdle; // just indicate a ressult <> dsNone
2742      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
2743    end;
2744  end;
2745
2746  procedure DoConsoleStream(const Line: String);
2747  begin
2748    DebugLn(DBG_VERBOSE, '[Debugger] Console output: ', Line);
2749  end;
2750
2751  procedure DoTargetStream(const Line: String);
2752  begin
2753    DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
2754  end;
2755
2756  procedure DoLogStream(const Line: String);
2757  const
2758    LogWarning = 'warning:';
2759  var
2760    Warning: String;
2761  begin
2762    DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
2763    Warning := Line;
2764    if Copy(Warning, 1, 2) = '&"' then
2765      Delete(Warning, 1, 2);
2766    if Copy(Warning, Length(Warning) - 2, 3) = '\n"' then
2767      Delete(Warning, Length(Warning) - 2, 3);
2768    if LowerCase(Copy(Warning, 1, Length(LogWarning))) = LogWarning then
2769    begin
2770      InLogWarning := True;
2771      Delete(Warning, 1, Length(LogWarning));
2772      Warning := MakePrintable(UnEscapeBackslashed(Trim(Warning), [uefOctal, uefTab, uefNewLine]));
2773      DoDbgEvent(ecOutput, etOutputDebugString, Format(gdbmiEventLogDebugOutput, [Warning]));
2774    end;
2775    if InLogWarning then
2776      FLogWarnings := FLogWarnings + Warning + LineEnding;
2777    if Line = '&"\n"' then
2778      InLogWarning := False;
2779
2780    if FTheDebugger.CheckForInternalError(Line, '') then begin
2781      AResult.State := dsStop;
2782      ForceStop := True;
2783    end;
2784(*
2785<< TCmdLineDebugger.ReadLn "&"Warning:\n""
2786  << TCmdLineDebugger.ReadLn "&"Cannot insert breakpoint 11.\n""
2787  << TCmdLineDebugger.ReadLn "&"Error accessing memory address 0x760: Input/output error.\n""
2788  << TCmdLineDebugger.ReadLn "&"\n""
2789
2790
2791  << TCmdLineDebugger.ReadLn "&"warning: Bad debug information detected: Attempt to read 592 bytes from registers.\n""
2792  << TCmdLineDebugger.ReadLn "^done,stack-args=[frame={level="5",args=[{name="ADDR",value="131"},{name="FUNC",value="']A'#0#131#0#0#0'l'#248#202#7#156#248#202#7#132#245#202#7#140#245#202#7'2kA'#0#6#2#0#0#27#0#0#0'#'#0#0#0'#'#0#0#0" ..(493).. ",{name="PTEXT",value="<value optimized out>"}]},frame={level="8",args=[]},frame={level="9",args=[]}]"
2793
2794*)
2795  end;
2796
2797var
2798  S: String;
2799  idx: Integer;
2800  {$IFDEF DBG_ASYNC_WAIT}
2801  GotPrompt: integer;
2802  {$ENDIF}
2803begin
2804  {$IFDEF DBG_ASYNC_WAIT}
2805  GotPrompt := 0;
2806  {$ENDIF}
2807  Result := True;
2808  ForceStop := False;
2809  AResult.State := dsNone;
2810  InLogWarning := False;
2811  FGotStopped := False;
2812  FLogWarnings := '';
2813  AStoppedParams := '';
2814  while FTheDebugger.DebugProcessRunning and not(FTheDebugger.State in [dsError, dsDestroying]) do
2815  begin
2816    if ATimeOut > 0 then begin
2817      S := FTheDebugger.ReadLine(ATimeOut);
2818      if FTheDebugger.ReadLineTimedOut then begin
2819        {$IFDEF DBG_ASYNC_WAIT}
2820        if GotPrompt = 0 then begin
2821        {$ENDIF}
2822        FProcessResultTimedOut := True;
2823        break;
2824        {$IFDEF DBG_ASYNC_WAIT}
2825        end;
2826        {$ENDIF}
2827      end;
2828    end
2829    else
2830      S := FTheDebugger.ReadLine(50);
2831
2832    {$IFDEF DBG_ASYNC_WAIT}
2833    if GotPrompt > 0 then begin
2834      inc(GotPrompt);
2835      if (GotPrompt > 15) or FGotStopped or FDidKillNow then break;
2836      if (GotPrompt > 5) and (S = '') then break;
2837    end;
2838    {$ENDIF}
2839
2840    if (S = '(gdb) ') or
2841       ( (S = '') and FDidKillNow )
2842    then
2843      {$IFDEF DBG_ASYNC_WAIT}
2844      begin
2845        if (not FGotStopped) and (not FDidKillNow) and (GotPrompt = 0) then
2846          GotPrompt := 1
2847        else
2848          break;
2849      end;
2850      {$ELSE}
2851      Break;
2852      {$ENDIF}
2853
2854    while S <> '' do
2855    begin
2856      if S[1] <> '&' then
2857        InLogWarning := False;
2858      case S[1] of
2859        '^': DoResultRecord(S);
2860        '~': DoConsoleStream(S);
2861        '@': DoTargetStream(S);
2862        '&': DoLogStream(S);
2863        '*': if DoExecAsync(S) then Continue;
2864        '+': DoStatusAsync(S);
2865        '=': DoMsgAsync(S);
2866      else
2867        // since target output isn't prefixed (yet?)
2868        // one of our known commands could be part of it.
2869        idx := Pos('*stopped', S);
2870        if idx  > 0
2871        then begin
2872          DebugLn(DBG_VERBOSE, '[DBGTGT] ', Copy(S, 1, idx - 1));
2873          Delete(S, 1, idx - 1);
2874          FGotStopped := True;
2875          Continue;
2876        end
2877        else begin
2878          // normal target output
2879          DebugLn(DBG_VERBOSE, '[DBGTGT] ', S);
2880        end;
2881      end;
2882      Break;
2883    end;
2884
2885    if ForceStop or (FTheDebugger.FAsyncModeEnabled and FGotStopped) then begin
2886      // There should not be a "(gdb) ",
2887      // but some versions print it, as they run none async, after accepting "run &"
2888      S := FTheDebugger.ReadLine(True, 50);
2889      if FTheDebugger.ReadLineTimedOut then break;
2890      if (S = '(gdb) ') then begin
2891        FTheDebugger.ReadLine(50); // read the extra "(gdb) "
2892        break;
2893      end;
2894      // since no command was sent, we can loop
2895    end;
2896
2897  end;
2898end;
2899
2900function TGDBMIDebuggerCommandExecuteBase.ParseBreakInsertError(var AText: String; out
2901  AnId: Integer): Boolean;
2902const
2903  BreaKErrMsg = 'not insert breakpoint ';
2904  WatchErrMsg = 'not insert hardware watchpoint ';
2905var
2906  i, i2, j: Integer;
2907begin
2908  Result := False;
2909  AnId := -1;
2910
2911  i := pos(BreaKErrMsg, AText);
2912  if i > 0
2913  then j := i + length(BreaKErrMsg);
2914  i2 := pos(WatchErrMsg, AText);
2915  if (i2 > 0) and ( (i2 < i) or (i < 1) )
2916  then begin
2917    i := i2;
2918    j := i + length(WatchErrMsg);
2919  end;
2920
2921  if i <= 0 then exit;
2922
2923  i2 := j;
2924  while (i2 <= length(AText)) and (AText[i2] in ['0'..'9']) do inc(i2);
2925  if i2 > j then
2926    AnId := StrToIntDef(copy(AText, j, i2-j), -1);
2927
2928  Delete(AText, i, i2 - i);
2929  Result := True;
2930end;
2931
2932function TGDBMIDebuggerCommandExecuteBase.ProcessStopped(const AParams: String;
2933  const AIgnoreSigIntState: Boolean): Boolean;
2934begin
2935  Result := False;
2936end;
2937
2938constructor TGDBMIDebuggerCommandExecuteBase.Create(AOwner: TGDBMIDebugger);
2939begin
2940  FCanKillNow := False;
2941  inherited Create(AOwner);
2942end;
2943
2944function TGDBMIDebuggerCommandExecuteBase.KillNow: Boolean;
2945var
2946  StoppedParams: String;
2947  R: TGDBMIExecResult;
2948begin
2949  Result := False;
2950  if not FCanKillNow then exit;
2951  // only here, if we are in ProcessRunning
2952  FDidKillNow := True; // interrupt current ProcessRunning
2953  FCanKillNow := False; // Do not allow to re-enter
2954
2955  FTheDebugger.GDBPause(True);
2956  FTheDebugger.CancelAllQueued; // before ProcessStopped
2957  FDidKillNow := False; // allow  ProcessRunning
2958  Result := ProcessRunning(StoppedParams, R, 1500);
2959  if ProcessResultTimedOut then begin
2960    // the outer Processrunning should stop, due to process no longer running
2961    FDidKillNow := True;
2962    FTheDebugger.TerminateGDB;
2963    FTheDebugger.FNeedReset:= True;
2964    SetDebuggerState(dsStop);
2965    //FTheDebugger.CancelAllQueued;  // stop queued new cmd
2966    Result := True;
2967    exit;
2968  end;
2969  FDidKillNow := True;
2970  if StoppedParams <> ''
2971  then ProcessStopped(StoppedParams, FTheDebugger.PauseWaitState = pwsInternal);
2972  FTheDebugger.FPauseWaitState := pwsNone;
2973
2974  ExecuteCommand('kill', [cfNoThreadContext], 1500);
2975  FTheDebugger.FCurrentStackFrameValid := False;
2976  FTheDebugger.FCurrentThreadIdValid   := False;
2977  Result := ExecuteCommand('info program', R, [cfNoThreadContext], 1500);
2978  Result := Result and (Pos('not being run', R.Values) > 0);
2979  if Result
2980  then SetDebuggerState(dsStop);
2981
2982  // Now give the ProcessRunning in the current DoExecute something
2983  //FTheDebugger.SendCmdLn('print 1');
2984end;
2985
2986
2987function TGDBMIDebugger.ConvertToGDBPath(APath: string; ConvType: TConvertToGDBPathType = cgptNone): string;
2988// GDB wants forward slashes in its filenames, even on win32.
2989var
2990  esc: TGDBMIDebuggerFilenameEncoding;
2991begin
2992  Result := UTF8ToWinCP(APath);
2993  // no need to process empty filename
2994  if Result = '' then exit;
2995
2996  case ConvType of
2997    cgptNone: esc := gdfeNone;
2998    cgptCurDir:
2999      begin
3000        esc := TGDBMIDebuggerPropertiesBase(GetProperties).FEncodeCurrentDirPath;
3001        //TODO: check FGDBOS
3002        //Unix/Windows can use gdfeEscSpace, but work without too;
3003        {$IFDEF darwin}
3004        if esc = gdfeDefault then
3005        if (FGDBVersionMajor >= 7) and (FGDBVersionMinor >= 0)
3006        then esc := gdfeNone
3007        else esc := gdfeQuote;
3008        {$ELSE}
3009        if esc = gdfeDefault then esc := gdfeNone;
3010        {$ENDIF}
3011      end;
3012    cgptExeName:
3013      begin
3014        esc := TGDBMIDebuggerPropertiesBase(GetProperties).FEncodeExeFileName;
3015        //Unix/Windows can use gdfeEscSpace, but work without too;
3016        {$IFDEF darwin}
3017        if esc = gdfeDefault then
3018        if (FGDBVersionMajor >= 7) and (FGDBVersionMinor >= 0)
3019        then esc := gdfeNone
3020        else esc := gdfeEscSpace;
3021        {$ELSE}
3022        if esc = gdfeDefault then esc := gdfeNone;
3023        {$ENDIF}
3024      end;
3025  end;
3026
3027  {$WARNINGS off}
3028  if DirectorySeparator <> '/' then
3029    Result := StringReplace(Result, DirectorySeparator, '/', [rfReplaceAll]);
3030  {$WARNINGS on}
3031  if esc = gdfeEscSpace
3032  then Result := StringReplace(Result, ' ', '\ ', [rfReplaceAll]);
3033  if esc = gdfeQuote
3034  then Result := '\"' + Result + '\"';
3035  Result := '"' + Result + '"';
3036end;
3037
3038{ TGDBMIDebuggerCommandChangeFilename }
3039
3040function TGDBMIDebuggerCommandChangeFilename.DoExecute: Boolean;
3041begin
3042  Result := True;
3043  FSuccess := DoChangeFilename;
3044end;
3045
3046constructor TGDBMIDebuggerCommandChangeFilename.Create(AOwner: TGDBMIDebugger;
3047  AFileName: String);
3048begin
3049  FFileName := AFileName;
3050  inherited Create(AOwner);
3051end;
3052
3053{ TGDBMIDebuggerCommandInitDebugger }
3054
3055function TGDBMIDebuggerCommandInitDebugger.DoSetInternalError: Boolean;
3056begin
3057  if (FTheDebugger.FGDBVersionMajor < 7) then
3058    exit(false);
3059  // available from GDB 7.0
3060  // On w32, it has no effect until GDB 7.7
3061  ExecuteCommand('maint set internal-error quit no', [], []);
3062  ExecuteCommand('maint set internal-error corefile no', [], []);
3063  ExecuteCommand('maint set internal-warning quit no', [], []);
3064  ExecuteCommand('maint set internal-warning corefile no', [], []);
3065  // available from GDB 7.9
3066  ExecuteCommand('maint set demangler-warning quit no', [], []);
3067  ExecuteCommand('maint set demangler-warning corefile no', [], []);
3068  Result:=true;
3069end;
3070
3071function TGDBMIDebuggerCommandInitDebugger.DoExecute: Boolean;
3072  function StoreGdbVersionAsNumber: Boolean;
3073  var
3074    i: Integer;
3075    s: String;
3076  begin
3077    FTheDebugger.FGDBVersionMajor := -1;
3078    FTheDebugger.FGDBVersionMinor := -1;
3079    FTheDebugger.FGDBVersionRev := -1;
3080    s := FTheDebugger.FGDBVersion;
3081    Result := False;
3082    // remove none leading digits
3083    i := 1;
3084    while (i <= Length(s)) and not (s[i] in ['0'..'9']) do inc(i);
3085    Delete(s,1,i-1);
3086    if s = '' then exit;
3087    FTheDebugger.FGDBVersion := s;
3088    // Major
3089    i := 1;
3090    while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
3091    if (i = 1) or (i > Length(s)) or (s[i] <> '.') then exit;
3092    FTheDebugger.FGDBVersionMajor := StrToIntDef(copy(s,1,i-1), -1);
3093    if i < 0 then exit;
3094    Delete(s,1,i);
3095    // Minor
3096    i := 1;
3097    while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
3098    if (i = 1) then exit;
3099    FTheDebugger.FGDBVersionMinor := StrToIntDef(copy(s,1,i-1), -1);
3100    Result := True;
3101    if (i > Length(s)) or (s[i] <> '.') then exit;
3102    Delete(s,1,i);
3103    // Rev
3104    i := 1;
3105    while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
3106    if (i = 1) then exit;
3107    FTheDebugger.FGDBVersionRev := StrToIntDef(copy(s,1,i-1), -1);
3108  end;
3109
3110  function ParseGDBVersionMI: Boolean;
3111  var
3112    R: TGDBMIExecResult;
3113    S: String;
3114    List: TGDBMINameValueList;
3115  begin
3116    Result := ExecuteCommand('-gdb-version', R);
3117    Result := Result and (R.Values <> '');
3118    if (not Result) then exit;
3119
3120    List := TGDBMINameValueList.Create(R);
3121
3122    FTheDebugger.FGDBVersion := List.Values['version'];
3123    S := List.Values['target'];
3124
3125    FTheDebugger.FGDBCPU := GetPart('', '-', S);
3126    GetPart('-', '-', S); // strip vendor
3127    FTheDebugger.FGDBOS := GetPart(['-'], ['-', ''], S);
3128
3129    List.Free;
3130
3131    if StoreGdbVersionAsNumber
3132    then exit;
3133
3134    // maybe a none MI result
3135    S := GetPart(['configured as \"'], ['\"'], R.Values, False, False);
3136    if Pos('--target=', S) <> 0 then
3137      S := GetPart('--target=', '', S);
3138    FTheDebugger.FGDBCPU := GetPart('', '-', S);
3139    GetPart('-', '-', S); // strip vendor
3140    FTheDebugger.FGDBOS := GetPart('-', '-', S);
3141
3142    FTheDebugger.FGDBVersion := GetPart(['('], [')'], R.Values, False, False);
3143    if StoreGdbVersionAsNumber then Exit;
3144
3145    FTheDebugger.FGDBVersion := GetPart(['gdb '], [#10, #13], R.Values, True, False);
3146    if StoreGdbVersionAsNumber then Exit;
3147
3148    // Retry, but do not check for format (old behaviour)
3149    FTheDebugger.FGDBVersion := GetPart(['('], [')'], R.Values, False, False);
3150    StoreGdbVersionAsNumber;
3151    if FTheDebugger.FGDBVersion <> '' then Exit;
3152
3153    FTheDebugger.FGDBVersion := GetPart(['gdb '], [#10, #13], R.Values, True, False);
3154    StoreGdbVersionAsNumber;
3155
3156    Result := False;
3157  end;
3158
3159var
3160  R: TGDBMIExecResult;
3161begin
3162  Result := True;
3163  FContext.ThreadContext := ccNotRequired;
3164  FContext.StackContext := ccNotRequired;
3165
3166  FSuccess := ExecuteCommand('-gdb-set confirm off', R);
3167  FSuccess := FSuccess and (r.State <> dsError);
3168  if (not FSuccess) then exit;
3169  // for win32, turn off a new console otherwise breaking gdb will fail
3170  // ignore the error on other platforms
3171  FSuccess := ExecuteCommand('-gdb-set new-console off', R);
3172  if (not FSuccess) then exit;
3173
3174  // set the output width to a great value to avoid unexpected
3175  // new lines like in large functions or procedures
3176  ExecuteCommand('set width 50000', []);
3177
3178  ParseGDBVersionMI;
3179  DoSetInternalError;
3180
3181  FTheDebugger.FAsyncModeEnabled := False;
3182  if TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).UseAsyncCommandMode then begin
3183    if ExecuteCommand('set target-async on', R, []) and (R.State <> dsError) then begin
3184      ExecuteCommand('show target-async', R, []);
3185      FTheDebugger.FAsyncModeEnabled := (R.State <> dsError) and
3186        (pos('mode is on', LowerCase(R.Values)) > 0);
3187    end;
3188    if not FTheDebugger.FAsyncModeEnabled then
3189      ExecuteCommand('set target-async off', R, []);
3190  end;
3191
3192end;
3193
3194procedure TGDBMIDebuggerCommandStack.DoCallstackFreed(Sender: TObject);
3195begin
3196  debugln(DBGMI_QUEUE_DEBUG, ['DoCallstackFreed: ', DebugText]);
3197  FCallstack := nil;
3198  Cancel;
3199end;
3200
3201procedure TGDBMIDebuggerCommandStack.DoLockQueueExecute;
3202begin
3203  //
3204end;
3205
3206procedure TGDBMIDebuggerCommandStack.DoUnLockQueueExecute;
3207begin
3208  //
3209end;
3210
3211procedure TGDBMIDebuggerCommandStack.DoLockQueueExecuteForInstr;
3212begin
3213  ///
3214end;
3215
3216procedure TGDBMIDebuggerCommandStack.DoUnLockQueueExecuteForInstr;
3217begin
3218  //
3219end;
3220
3221constructor TGDBMIDebuggerCommandStack.Create(AOwner: TGDBMIDebugger;
3222  ACallstack: TCallStackBase);
3223begin
3224  inherited Create(AOwner);
3225  FCallstack := ACallstack;
3226  FCallstack.AddFreeNotification(@DoCallstackFreed);
3227end;
3228
3229destructor TGDBMIDebuggerCommandStack.Destroy;
3230begin
3231  if FCallstack <> nil
3232  then FCallstack.RemoveFreeNotification(@DoCallstackFreed);
3233  inherited Destroy;
3234end;
3235
3236{ TGDBMIBreakPoints }
3237
3238function TGDBMIBreakPoints.FindById(AnId: Integer): TGDBMIBreakPoint;
3239var
3240  n: Integer;
3241begin
3242  for n := 0 to Count - 1 do
3243  begin
3244    Result := TGDBMIBreakPoint(Items[n]);
3245    if  (Result.FBreakID = AnId)
3246    then Exit;
3247  end;
3248  Result := nil;
3249end;
3250
3251{ TGDBMIDebuggerCommandKill }
3252
3253function TGDBMIDebuggerCommandKill.DoExecute: Boolean;
3254var
3255  R: TGDBMIExecResult;
3256  CmdRes: Boolean;
3257begin
3258  Result := True;
3259  FContext.ThreadContext := ccNotRequired;
3260  FContext.StackContext := ccNotRequired;
3261
3262  // not supported yet
3263  // ExecuteCommand('-exec-abort');
3264  CmdRes := ExecuteCommand('kill', [], [], 1500); // Hardcoded timeout
3265  FTheDebugger.FCurrentStackFrameValid := False;
3266  FTheDebugger.FCurrentThreadIdValid   := False;
3267  if CmdRes
3268  then CmdRes := ExecuteCommand('info program', R, [cfNoThreadContext], 1500); // Hardcoded timeout
3269  if (not CmdRes)
3270  or (Pos('not being run', R.Values) <= 0)
3271  then begin
3272    FTheDebugger.TerminateGDB;
3273    SetDebuggerState(dsError); // failed to stop
3274    exit;
3275  end;
3276  SetDebuggerState(dsStop);
3277end;
3278
3279{ TGDBMIThreads }
3280
3281procedure TGDBMIThreads.DoThreadsDestroyed(Sender: TObject);
3282begin
3283  if FGetThreadsCmdObj = Sender
3284  then FGetThreadsCmdObj:= nil;
3285end;
3286
3287procedure TGDBMIThreads.DoThreadsFinished(Sender: TObject);
3288var
3289  Cmd: TGDBMIDebuggerCommandThreads;
3290  i: Integer;
3291begin
3292  if Monitor = nil then exit;
3293  Cmd := TGDBMIDebuggerCommandThreads(Sender);
3294  if CurrentThreads = nil then exit;
3295
3296  if not Cmd.Success then begin
3297    CurrentThreads.SetValidity(ddsInvalid);
3298    CurrentThreads.CurrentThreadId := Debugger.FCurrentThreadId;
3299    exit;
3300  end;
3301
3302  CurrentThreads.Clear;
3303  for i := 0 to Cmd.Count - 1 do
3304    CurrentThreads.Add(Cmd.Threads[i]);
3305
3306  CurrentThreads.CurrentThreadId := Cmd.CurrentThreadId;
3307  CurrentThreads.SetValidity(ddsValid);
3308  Debugger.FCurrentThreadId := CurrentThreads.CurrentThreadId;
3309  Debugger.FCurrentThreadIdValid := True;
3310end;
3311
3312function TGDBMIThreads.GetDebugger: TGDBMIDebugger;
3313begin
3314  Result := TGDBMIDebugger(inherited Debugger);
3315end;
3316
3317procedure TGDBMIThreads.ThreadsNeeded;
3318var
3319  ForceQueue: Boolean;
3320begin
3321  if Debugger = nil then Exit;
3322
3323  if (Debugger.State in [dsPause, dsInternalPause])
3324  then begin
3325    FGetThreadsCmdObj := TGDBMIDebuggerCommandThreads.Create(Debugger);
3326    FGetThreadsCmdObj.OnExecuted  := @DoThreadsFinished;
3327    FGetThreadsCmdObj.OnDestroy    := @DoThreadsDestroyed;
3328    FGetThreadsCmdObj.Properties := [dcpCancelOnRun];
3329    FGetThreadsCmdObj.Priority := GDCMD_PRIOR_THREAD;
3330    FGetThreadsCmdObj.CurrentThreads := CurrentThreads;
3331    // If a ExecCmd is running, then defer exec until the exec cmd is done
3332    ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
3333              and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
3334              and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
3335              and (Debugger.State <> dsInternalPause);
3336    TGDBMIDebugger(Debugger).QueueCommand(FGetThreadsCmdObj, ForceQueue);
3337    (* DoEvaluationFinished may be called immediately at this point *)
3338  end;
3339end;
3340
3341procedure TGDBMIThreads.CancelEvaluation;
3342begin
3343  if FGetThreadsCmdObj <> nil
3344  then begin
3345    FGetThreadsCmdObj.OnExecuted := nil;
3346    FGetThreadsCmdObj.OnDestroy := nil;
3347    FGetThreadsCmdObj.Cancel;
3348  end;
3349  FGetThreadsCmdObj := nil;
3350end;
3351
3352destructor TGDBMIThreads.Destroy;
3353begin
3354  CancelEvaluation;
3355  inherited Destroy;
3356end;
3357
3358procedure TGDBMIThreads.RequestMasterData;
3359begin
3360  ThreadsNeeded;
3361end;
3362
3363procedure TGDBMIThreads.ChangeCurrentThread(ANewId: Integer);
3364begin
3365  if Debugger = nil then Exit;
3366  if not(Debugger.State in [dsPause, dsInternalPause]) then exit;
3367
3368  Debugger.FCurrentThreadId := ANewId;
3369  Debugger.FCurrentThreadIdValid := True;
3370
3371  Debugger.DoThreadChanged;
3372  if CurrentThreads <> nil
3373  then CurrentThreads.CurrentThreadId := ANewId;
3374
3375  DebugLn(DBG_THREAD_AND_FRAME, ['TGDBMIThreads THREAD wanted ', Debugger.FCurrentThreadId]);
3376end;
3377
3378procedure TGDBMIThreads.DoCleanAfterPause;
3379begin
3380  if (Debugger.State <> dsRun) or (Monitor = nil) then begin
3381    inherited DoCleanAfterPause;
3382    exit;
3383  end;
3384
3385  //for i := 0 to  Monitor.CurrentThreads.Count - 1 do
3386  //  Monitor.CurrentThreads[i].ClearLocation; // TODO enum?
3387end;
3388
3389{ TGDBMIDebuggerCommandThreads }
3390
3391function TGDBMIDebuggerCommandThreads.GetThread(AnIndex: Integer): TThreadEntry;
3392begin
3393  Result := FThreads[AnIndex];
3394end;
3395
3396function TGDBMIDebuggerCommandThreads.DoExecute: Boolean;
3397var
3398  R: TGDBMIExecResult;
3399  List, EList, ArgList: TGDBMINameValueList;
3400  i, j: Integer;
3401  line, ThrId: Integer;
3402  func, filename, fullname: String;
3403  ThrName, ThrState: string;
3404  addr: TDBGPtr;
3405  Arguments: TStringList;
3406begin
3407(* TODO: none MI command
3408<info threads>
3409&"info threads\n"
3410~"  5 thread 4928.0x1f50  0x77755ca4 in ntdll!LdrAccessResource () from C:\\Windows\\system32\\ntdll.dll\n"
3411~"  4 thread 4928.0x12c8  0x77755ca4 in ntdll!LdrAccessResource () from C:\\Windows\\system32\\ntdll.dll\n"
3412~"* 1 thread 4928.0x1d18  TFORM1__BUTTON1CLICK (SENDER=0x209ef0, this=0x209a20) at unit1.pas:65\n"
3413^done
3414(gdb)
3415
3416*)
3417
3418  Result := True;
3419  FContext.ThreadContext := ccNotRequired;
3420  FContext.StackContext := ccNotRequired;
3421
3422  if not ExecuteCommand('-thread-info', R)
3423  then exit;
3424  if r.State = dsError then exit;;
3425  List := TGDBMINameValueList.Create(R);
3426  EList := TGDBMINameValueList.Create;
3427  ArgList := TGDBMINameValueList.Create;
3428  try
3429    FCurrentThreadId := StrToIntDef(List.Values['current-thread-id'], -1);
3430    if FCurrentThreadId < 0 then exit;
3431    FSuccess := True;
3432
3433    // update queue if needed // clear current stackframe
3434    if FTheDebugger.FInstructionQueue.CurrentThreadId <> FCurrentThreadId then
3435      FTheDebugger.FInstructionQueue.SetKnownThread(FCurrentThreadId);
3436
3437
3438    List.SetPath('threads');
3439    SetLength(FThreads, List.Count);
3440    for i := 0 to List.Count - 1 do begin
3441      EList.Init(List.Items[i]^.Name);
3442      ThrId    := StrToIntDef(EList.Values['id'], -2);
3443      ThrName  := EList.Values['target-id'];
3444      ThrState := EList.Values['state'];
3445      EList.SetPath('frame');
3446      addr := StrToQWordDef(EList.Values['addr'], 0);
3447      func := EList.Values['func'];
3448      filename := ConvertGdbPathAndFile(EList.Values['file']);
3449      fullname := ConvertGdbPathAndFile(EList.Values['fullname']);
3450      line := StrToIntDef(EList.Values['line'], 0);
3451
3452      EList.SetPath('args');
3453      Arguments := TStringList.Create;
3454      for j := 0 to EList.Count - 1 do begin
3455        ArgList.Init(EList.Items[j]^.Name);
3456        Arguments.Add(ArgList.Values['name'] + '=' + DeleteEscapeChars(ArgList.Values['value']));
3457      end;
3458
3459
3460      FThreads[i] := CurrentThreads.CreateEntry(
3461        addr,
3462        Arguments,
3463        func,
3464        filename, fullname,
3465        line,
3466        ThrId,ThrName, ThrState
3467      );
3468
3469      Arguments.Free;
3470    end;
3471
3472  finally
3473    FreeAndNil(ArgList);
3474    FreeAndNil(EList);
3475    FreeAndNil(List);
3476  end;
3477end;
3478
3479constructor TGDBMIDebuggerCommandThreads.Create(AOwner: TGDBMIDebugger);
3480begin
3481  inherited;
3482  FSuccess := False;
3483end;
3484
3485destructor TGDBMIDebuggerCommandThreads.Destroy;
3486var
3487  i: Integer;
3488begin
3489  for i := 0 to length(FThreads) - 1 do FreeAndNil(FThreads[i]);
3490  FThreads := nil;
3491  inherited Destroy;
3492end;
3493
3494function TGDBMIDebuggerCommandThreads.Count: Integer;
3495begin
3496  Result := length(FThreads);
3497end;
3498
3499{ TGDBMINameValueBasedList }
3500
3501constructor TGDBMINameValueBasedList.Create;
3502begin
3503  FNameValueList := TGDBMINameValueList.Create;
3504end;
3505
3506constructor TGDBMINameValueBasedList.Create(const AResultValues: String);
3507begin
3508  FNameValueList := TGDBMINameValueList.Create(AResultValues);
3509  PreParse;
3510end;
3511
3512constructor TGDBMINameValueBasedList.Create(AResult: TGDBMIExecResult);
3513begin
3514  Create(AResult.Values);
3515end;
3516
3517destructor TGDBMINameValueBasedList.Destroy;
3518begin
3519  inherited Destroy;
3520  FreeAndNil(FNameValueList);
3521end;
3522
3523procedure TGDBMINameValueBasedList.Init(AResultValues: string);
3524begin
3525  FNameValueList.Init(AResultValues);
3526  PreParse;
3527end;
3528
3529procedure TGDBMINameValueBasedList.Init(AResult: TGDBMIExecResult);
3530begin
3531  Init(AResult.Values);
3532end;
3533
3534{ TGDBMIDisassembleResultList }
3535
3536procedure TGDBMIDisassembleResultList.PreParse;
3537const
3538  SrcAndAsm = 'src_and_asm_line';
3539  SrcAndAsmLen = length(SrcAndAsm);
3540var
3541  Itm: PGDBMINameValue;
3542  SrcList: TGDBMINameValueList;
3543  i, j: Integer;
3544  SFile, SLine: TPCharWithLen;
3545begin
3546  // The "^done" is stripped already
3547  if (FNameValueList.Count <> 1) or(FNameValueList.IndexOf('asm_insns') < 0)
3548  then debugln(DBG_DISASSEMBLER, ['WARNING: TGDBMIDisassembleResultList: Unexpected Entries']);
3549  HasItemPointerList := False;
3550  FNameValueList.SetPath('asm_insns');
3551  FCount := 0;
3552  SetLength(FItems, FNameValueList.Count * 4);
3553  FHasSourceInfo := False;
3554  SrcList := nil;
3555  for i := 0 to FNameValueList.Count - 1 do begin
3556    Itm := FNameValueList.Items[i];
3557    if (Itm^.Name.Len = SrcAndAsmLen)
3558    and (strlcomp(Itm^.Name.Ptr, PChar(SrcAndAsm), SrcAndAsmLen) = 0)
3559    then begin
3560      // Source and asm
3561      FHasSourceInfo := True;
3562      if SrcList = nil
3563      then SrcList := TGDBMINameValueList.Create(Itm^.Value)
3564      else SrcList.Init(Itm^.Value);
3565      SFile := SrcList.ValuesPtr['file'];
3566      SLine := SrcList.ValuesPtr['line'];
3567      SrcList.SetPath('line_asm_insn');
3568
3569      if FCount + SrcList.Count >= length(FItems)
3570      then SetLength(FItems, FCount + SrcList.Count + 20);
3571      for j := 0 to SrcList.Count - 1 do begin
3572        FItems[FCount].AsmEntry   := SrcList.Items[j]^.Name;
3573        FItems[FCount].SrcFile    := SFile;
3574        FItems[FCount].SrcLine    := SLine;
3575        FItems[FCount].ParsedInfo.SrcStatementIndex := j;
3576        FItems[FCount].ParsedInfo.SrcStatementCount := SrcList.Count;
3577        inc(FCount);
3578      end;
3579    end
3580    else
3581    if (Itm^.Name.Len > 1)
3582    and (Itm^.Name.Ptr[0] = '{')
3583    and (Itm^.Value.Len = 0)
3584    then begin
3585      // Asm only
3586      if FCount + 1 >= length(FItems)
3587      then SetLength(FItems, FCount + 20);
3588      FItems[FCount].AsmEntry    := Itm^.Name;
3589      FItems[FCount].SrcFile.Ptr := nil;
3590      FItems[FCount].SrcFile.Len := 0;
3591      FItems[FCount].SrcLine.Ptr := nil;
3592      FItems[FCount].SrcLine.Len := 0;
3593      FItems[FCount].ParsedInfo.SrcStatementIndex := 0;
3594      FItems[FCount].ParsedInfo.SrcStatementCount := 0;
3595      inc(FCount);
3596    end
3597    else
3598    begin
3599      // unknown
3600      debugln(['WARNING: TGDBMIDisassembleResultList.Parse: unknown disass entry',
3601              DbgsPCLen(Itm^.Name),': ',DbgsPCLen(Itm^.Value)]);
3602    end;
3603  end;
3604  FreeAndNil(SrcList);
3605end;
3606
3607function TGDBMIDisassembleResultList.GetLastItem: PDisassemblerEntry;
3608begin
3609  if HasItemPointerList
3610  then begin
3611    Result := ItemPointerList[Count - 1];
3612    exit;
3613  end;
3614  ParseItem(Count - 1);
3615  Result := @FItems[Count - 1].ParsedInfo;
3616end;
3617
3618function TGDBMIDisassembleResultList.SortByAddress: Boolean;
3619var
3620  i, j: Integer;
3621  Itm1: PDisassemblerEntry;
3622begin
3623  Result := True;
3624  SetLength(ItemPointerList, FCount);
3625  for i := 0 to Count - 1 do begin
3626    Itm1 := Item[i];
3627    j := i - 1;
3628    while j >= 0 do begin
3629      if ItemPointerList[j]^.Addr > Itm1^.Addr
3630      then ItemPointerList[j+1] := ItemPointerList[j]
3631      else break;
3632      dec(j);
3633    end;
3634    ItemPointerList[j+1] := Itm1;
3635  end;
3636  HasItemPointerList := True;
3637end;
3638
3639constructor TGDBMIDisassembleResultList.CreateSubList(ASource: TGDBMIDisassembleResultList;
3640  AStartIdx, ACount: Integer);
3641begin
3642  Create;
3643  InitSubList(ASource, AStartIdx, ACount);
3644end;
3645
3646procedure TGDBMIDisassembleResultList.InitSubList(ASource: TGDBMIDisassembleResultList;
3647  AStartIdx, ACount: Integer);
3648var
3649  i: Integer;
3650begin
3651  SetLength(ItemPointerList, ACount);
3652  FCount := ACount;
3653  for i := 0 to ACount - 1 do
3654    ItemPointerList[i] := ASource.Item[AStartIdx + i];
3655  HasItemPointerList := True;
3656end;
3657
3658function TGDBMIDisassembleResultList.GetItem(Index: Integer): PDisassemblerEntry;
3659begin
3660  if HasItemPointerList
3661  then begin
3662    Result := ItemPointerList[Index];
3663    exit;
3664  end;
3665  ParseItem(Index);
3666  Result := @FItems[Index].ParsedInfo;
3667end;
3668
3669procedure TGDBMIDisassembleResultList.ParseItem(Index: Integer);
3670var
3671  AsmList: TGDBMINameValueList;
3672begin
3673  if FItems[Index].AsmEntry.Ptr = nil
3674  then exit;
3675  AsmList := TGDBMINameValueList.Create(FItems[Index].AsmEntry);
3676
3677  FItems[Index].ParsedInfo.SrcFileName := ConvertGdbPathAndFile(PCLenToString(FItems[Index].SrcFile, True));
3678  FItems[Index].ParsedInfo.SrcFileLine := PCLenToInt(FItems[Index].SrcLine, 0);
3679  // SrcStatementIndex, SrcStatementCount are already set
3680
3681  FItems[Index].ParsedInfo.Addr      := PCLenToQWord(AsmList.ValuesPtr['address'], 0);
3682  FItems[Index].ParsedInfo.Statement :=
3683    UnEscapeBackslashed(PCLenToString(AsmList.ValuesPtr['inst'], True), [uefTab], 16);
3684  FItems[Index].ParsedInfo.FuncName  := PCLenToString(AsmList.ValuesPtr['func-name'], True);
3685  FItems[Index].ParsedInfo.Offset    := PCLenToInt(AsmList.ValuesPtr['offset'], 0);
3686
3687  FItems[Index].AsmEntry.Ptr := nil;
3688  FreeAndNil(AsmList);
3689end;
3690
3691procedure TGDBMIDisassembleResultList.SetCount(const AValue: Integer);
3692begin
3693  if FCount = AValue then exit;
3694  if FCount > length(FItems)
3695  then raise Exception.Create('Invalid Count');
3696  FCount := AValue;
3697end;
3698
3699procedure TGDBMIDisassembleResultList.SetItem(Index: Integer;
3700  const AValue: PDisassemblerEntry);
3701begin
3702  if HasItemPointerList
3703  then begin
3704    ItemPointerList[Index]^ := AValue^;
3705    exit;
3706  end;
3707  FItems[Index].ParsedInfo := AValue^;
3708  FItems[Index].AsmEntry.Ptr := nil;
3709end;
3710
3711procedure TGDBMIDisassembleResultList.SetLastItem(const AValue: PDisassemblerEntry);
3712begin
3713  if HasItemPointerList
3714  then begin
3715    ItemPointerList[Count - 1]^ := AValue^;
3716    exit;
3717  end;
3718  FItems[Count - 1].ParsedInfo := AValue^;
3719  FItems[Count - 1].AsmEntry.Ptr := nil;
3720end;
3721
3722{ TGDBMIDisassembleResultFunctionIterator }
3723
3724constructor TGDBMIDisassembleResultFunctionIterator.Create(AList: TGDBMIDisassembleResultList;
3725  AStartIdx: Integer; ALastSubListEndAddr: TDBGPtr;
3726  AnAddressToLocate, AnAddForLineAfterCounter: TDBGPtr);
3727begin
3728  FList := AList;
3729  FStartedAtIndex := AStartIdx;
3730  FStartIdx := AStartIdx;
3731  FLastSubListEndAddr := ALastSubListEndAddr;
3732  FAddressToLocate := AnAddressToLocate;
3733  FAddForLineAfterCounter := AnAddForLineAfterCounter;
3734  FMaxIdx := FList.Count - 1;
3735  if FStartIdx > FMaxIdx
3736  then raise Exception.Create('internal error');
3737  FIndexOfLocateAddress := 1;
3738  FOffsetOfLocateAddress := -1;
3739  FIndexOfCounterAddress := -1;
3740  FSublistNumber := -1;
3741end;
3742
3743function TGDBMIDisassembleResultFunctionIterator.EOL: Boolean;
3744begin
3745  Result := FStartIdx > FMaxIdx ;
3746end;
3747
3748function TGDBMIDisassembleResultFunctionIterator.NextSubList
3749  (var AResultList: TGDBMIDisassembleResultList): Boolean;
3750var
3751  WasBeforeStart: Boolean;
3752  HasPrcName: Boolean;
3753  PrcBaseAddr: TDBGPtr;
3754  Itm: PDisassemblerEntry;
3755  NextIdx: Integer;
3756  HasLocate: Boolean;
3757begin
3758  FCurIdx := FStartIdx;
3759  if FStartIdx > FMaxIdx
3760  then raise Exception.Create('internal error');
3761  inc(FSublistNumber);
3762
3763  (* The name may change in the middle of a function. Check for either:
3764     - change between no-name and has-name
3765     - change of the base-address (addr-offset), if the offset is valid (if has-name)
3766  *)
3767  HasPrcName := FList.Item[FStartIdx]^.FuncName <> ''; // can use offsets
3768  {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$ENDIF} // Overflow is allowed to occur
3769  PrcBaseAddr := FList.Item[FStartIdx]^.Addr - FList.Item[FStartIdx]^.Offset;
3770  {$POP}
3771
3772  WasBeforeStart := FList.Item[FStartIdx]^.Addr < FAddressToLocate;
3773  HasLocate := False;
3774
3775  NextIdx :=  FStartIdx + 1;
3776  while NextIdx <= FMaxIdx do
3777  begin
3778    Itm := FList.Item[NextIdx];
3779    {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$ENDIF} // Overflow is allowed to occur
3780    // Also check the next statement after PrcName.
3781    // If it has FOffsetOfLocateAddress > 0, then FAddressToLocate is in current block, but not matched
3782    if (Itm^.Addr = FAddressToLocate)
3783    then begin
3784      FIndexOfLocateAddress := NextIdx;
3785      FOffsetOfLocateAddress := 0;
3786      WasBeforeStart := False;
3787      HasLocate := True;
3788    end
3789    else if WasBeforeStart and (Itm^.Addr > FAddressToLocate)
3790    then begin
3791      FIndexOfLocateAddress := NextIdx - 1;
3792      FOffsetOfLocateAddress := FAddressToLocate - FList.Item[NextIdx-1]^.Addr;
3793      WasBeforeStart := False;
3794      HasLocate := True;
3795    end;
3796    if (FAddForLineAfterCounter > 0)
3797    and (  (Itm^.Addr = FAddForLineAfterCounter)
3798        or ((Itm^.Addr > FAddForLineAfterCounter) and (FIndexOfCounterAddress < 0)) )
3799    then FIndexOfCounterAddress := NextIdx;
3800
3801    if (HasPrcName <> (Itm^.FuncName <> ''))
3802    or (HasPrcName and (PrcBaseAddr <> Itm^.Addr - Itm^.Offset))
3803    then break;
3804    {$POP}
3805
3806    inc(NextIdx);
3807  end;
3808
3809  if AResultList = nil
3810  then AResultList := TGDBMIDisassembleResultList.CreateSubList(FList, FStartIdx, NextIdx - FStartIdx)
3811  else AResultList.InitSubList(FList, FStartIdx, NextIdx - FStartIdx);
3812  FStartIdx := NextIdx;
3813
3814  // Does the next address look good?
3815  // And is AStartAddrHit ok
3816  //Result := ((NextIdx > FMaxIdx) or (FList.Item[NextIdx]^.Offset = 0))
3817  //      and
3818  Result := ( (not HasLocate) or ((FIndexOfLocateAddress < 0) or (FOffsetOfLocateAddress = 0)) );
3819end;
3820
3821function TGDBMIDisassembleResultFunctionIterator.IsFirstSubList: Boolean;
3822begin
3823  Result := FSublistNumber = 0;
3824end;
3825
3826function TGDBMIDisassembleResultFunctionIterator.CountLinesAfterCounterAddr: Integer;
3827begin
3828  Result := -1;
3829  if FIndexOfCounterAddress >= 0 then
3830  Result := CurrentIndex - IndexOfCounterAddress - 1;
3831end;
3832
3833function TGDBMIDisassembleResultFunctionIterator.CurrentFixedAddr(AOffsLimit: Integer): TDBGPtr;
3834begin
3835  Result := FList.Item[CurrentIndex]^.Addr - Min(FList.Item[CurrentIndex]^.Offset, AOffsLimit);
3836  // Offset may increase to a point BEFORE the previous address (e.g. neseted proc, maybe inline?)
3837  if CurrentIndex > 0 then
3838    if Result <= FList.Item[CurrentIndex-1]^.Addr then
3839      Result := FList.Item[CurrentIndex]^.Addr;
3840end;
3841
3842function TGDBMIDisassembleResultFunctionIterator.NextStartAddr: TDBGPtr;
3843begin
3844  if NextIndex <= FMaxIdx
3845  then begin
3846    Result := FList.Item[NextIndex]^.Addr - FList.Item[NextIndex]^.Offset;
3847    // Offset may increase to a point BEFORE the previous address (e.g. neseted proc, maybe inline?)
3848    if NextIndex > 0 then
3849      if Result <= FList.Item[NextIndex-1]^.Addr then
3850        Result := FList.Item[NextIndex]^.Addr;
3851  end
3852  else
3853    Result := FLastSubListEndAddr;
3854end;
3855
3856function TGDBMIDisassembleResultFunctionIterator.NextStartOffs: Integer;
3857begin
3858  if NextIndex <= FMaxIdx
3859  then Result := FList.Item[NextIndex]^.Offset
3860  else Result := 0;
3861end;
3862
3863{ TGDBMIMemoryDumpResultList }
3864
3865function TGDBMIMemoryDumpResultList.GetItemNum(Index: Integer): Integer;
3866begin
3867  Result := PCLenToInt(FNameValueList.Items[Index]^.Name, 0);
3868end;
3869
3870function TGDBMIMemoryDumpResultList.GetItem(Index: Integer): TPCharWithLen;
3871begin
3872  Result := FNameValueList.Items[Index]^.Name;
3873end;
3874
3875function TGDBMIMemoryDumpResultList.GetItemTxt(Index: Integer): string;
3876var
3877  itm: PGDBMINameValue;
3878begin
3879  itm := FNameValueList.Items[Index];
3880  if itm <> nil
3881  then Result := PCLenToString(itm^.Name, True)
3882  else Result := '';
3883end;
3884
3885procedure TGDBMIMemoryDumpResultList.PreParse;
3886begin
3887  FNameValueList.SetPath('memory');
3888  if FNameValueList.Count = 0 then exit;
3889  FNameValueList.Init(FNameValueList.Items[0]^.Name);
3890  FAddr := PCLenToQWord(FNameValueList.ValuesPtr['addr'], 0);
3891  FNameValueList.SetPath('data');
3892end;
3893
3894function TGDBMIMemoryDumpResultList.Count: Integer;
3895begin
3896  Result := FNameValueList.Count;
3897end;
3898
3899function TGDBMIMemoryDumpResultList.AsText(AStartOffs, ACount: Integer;
3900  AAddrWidth: Integer): string;
3901var
3902  i: LongInt;
3903begin
3904  if AAddrWidth > 0
3905  then Result := IntToHex(addr + AStartOffs, AAddrWidth) + ':'
3906  else Result := '';
3907  for i := AStartOffs to AStartOffs + ACount do begin
3908    if i >= ACount then exit;
3909    Result := Result + ' ' + PCLenPartToString(Item[i], 3, 2);
3910  end;
3911end;
3912
3913{ TGDBMIDisassembler }
3914
3915procedure TGDBMIDisassembler.DoDisassembleDestroyed(Sender: TObject);
3916begin
3917  if FDisassembleEvalCmdObj = Sender
3918  then FDisassembleEvalCmdObj := nil;
3919end;
3920
3921procedure TGDBMIDisassembler.DoDisassembleProgress(Sender: TObject);
3922begin
3923  Changed;
3924end;
3925
3926procedure TGDBMIDisassembler.DoDisassembleExecuted(Sender: TObject);
3927begin
3928  // Results were added from inside the TGDBMIDebuggerCommandDisassemble object
3929  FLastExecAddr := TGDBMIDebuggerCommandDisassemble(Sender).StartAddr;
3930  if dcsCanceled in TGDBMIDebuggerCommandDisassemble(Sender).SeenStates then begin
3931    // TODO: fill a block of data with "canceled" info
3932    FIsCancelled := True;
3933    FCancelledAddr := TGDBMIDebuggerCommandDisassemble(Sender).StartAddr;
3934  end;
3935  FDisassembleEvalCmdObj := nil;
3936  Changed;
3937end;
3938
3939function TGDBMIDisassembler.PrepareEntries(AnAddr: TDbgPtr; ALinesBefore,
3940  ALinesAfter: Integer): Boolean;
3941var
3942  ForceQueue: Boolean;
3943begin
3944  Result := False;
3945  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
3946  then exit;
3947  if FIsCancelled and (FCancelledAddr = AnAddr) then
3948    exit;
3949
3950
3951  if (FDisassembleEvalCmdObj <> nil)
3952  then begin
3953    if FDisassembleEvalCmdObj.State <> dcsQueued
3954    then exit; // the request will be done again, after the next "Changed" (which should be the edn of the current command)
3955
3956    if (AnAddr < FDisassembleEvalCmdObj.StartAddr)
3957    and (AnAddr >= FDisassembleEvalCmdObj.StartAddr
3958        - (ALinesAfter + FDisassembleEvalCmdObj.LinesBefore) * DAssBytesPerCommandAvg)
3959    then begin
3960      // merge before
3961      debugln(DBG_DISASSEMBLER, ['INFO: TGDBMIDisassembler.PrepareEntries  MERGE request at START: NewStartAddr=', AnAddr,
3962               ' NewLinesBefore=', Max(ALinesBefore, FDisassembleEvalCmdObj.LinesBefore), ' OldStartAddr=', FDisassembleEvalCmdObj.StartAddr,
3963               '  OldLinesBefore=', FDisassembleEvalCmdObj.LinesBefore ]);
3964      FDisassembleEvalCmdObj.StartAddr := AnAddr;
3965      FDisassembleEvalCmdObj.LinesBefore := Max(ALinesBefore, FDisassembleEvalCmdObj.LinesBefore);
3966      exit;
3967    end;
3968
3969    if (AnAddr > FDisassembleEvalCmdObj.EndAddr)
3970    and (AnAddr <= FDisassembleEvalCmdObj.EndAddr
3971        + (ALinesBefore + FDisassembleEvalCmdObj.LinesAfter) * DAssBytesPerCommandAvg)
3972    then begin
3973      // merge after
3974      debugln(DBG_DISASSEMBLER, ['INFO: TGDBMIDisassembler.PrepareEntries  MERGE request at END: NewEndAddr=', AnAddr,
3975               ' NewLinesAfter=', Max(ALinesAfter, FDisassembleEvalCmdObj.LinesAfter), ' OldEndAddr=', FDisassembleEvalCmdObj.EndAddr,
3976               '  OldLinesAfter=', FDisassembleEvalCmdObj.LinesAfter ]);
3977      FDisassembleEvalCmdObj.EndAddr := AnAddr;
3978      FDisassembleEvalCmdObj.LinesAfter := Max(ALinesAfter, FDisassembleEvalCmdObj.LinesAfter);
3979      exit;
3980    end;
3981
3982    exit;
3983  end;
3984
3985  FDisassembleEvalCmdObj := TGDBMIDebuggerCommandDisassemble.Create
3986    (TGDBMIDebugger(Debugger), EntryRanges, AnAddr, AnAddr, ALinesBefore, ALinesAfter);
3987  FDisassembleEvalCmdObj.OnExecuted := @DoDisassembleExecuted;
3988  FDisassembleEvalCmdObj.OnProgress  := @DoDisassembleProgress;
3989  FDisassembleEvalCmdObj.OnDestroy  := @DoDisassembleDestroyed;
3990  FDisassembleEvalCmdObj.Priority := GDCMD_PRIOR_DISASS;
3991  FDisassembleEvalCmdObj.Properties := [dcpCancelOnRun];
3992  ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
3993            and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
3994            and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
3995            and (Debugger.State <> dsInternalPause);
3996  TGDBMIDebugger(Debugger).QueueCommand(FDisassembleEvalCmdObj, ForceQueue);
3997  (* DoDepthCommandExecuted may be called immediately at this point *)
3998  Result := FDisassembleEvalCmdObj = nil; // already executed
3999end;
4000
4001function TGDBMIDisassembler.HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;
4002  AnAddr: TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean;
4003var
4004  i, c: Integer;
4005begin
4006  if AnAddr = FLastExecAddr
4007  then begin
4008    i := 0;
4009    c := ARange.Count;
4010    while i < c do
4011    begin
4012      if ARange.EntriesPtr[i]^.Addr > AnAddr
4013      then break;
4014      inc(i);
4015    end;
4016    if i > 0
4017    then dec(i);
4018    ALinesBefore := i;
4019    ALinesAfter := ARange.Count - 1 - i;
4020    Result := True;
4021    exit;
4022  end;
4023  Result := inherited HandleRangeWithInvalidAddr(ARange, AnAddr, ALinesBefore, ALinesAfter);
4024end;
4025
4026procedure TGDBMIDisassembler.Clear;
4027begin
4028  FIsCancelled := False;
4029  inherited Clear;
4030  if FDisassembleEvalCmdObj <> nil
4031  then begin
4032    FDisassembleEvalCmdObj.OnExecuted := nil;
4033    FDisassembleEvalCmdObj.OnDestroy := nil;
4034    FDisassembleEvalCmdObj.Cancel;
4035  end;
4036  FDisassembleEvalCmdObj := nil;
4037end;
4038
4039function TGDBMIDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore,
4040  ALinesAfter: Integer): Boolean;
4041begin
4042  if AnAddr <> FLastExecAddr
4043  then FLastExecAddr := 0;
4044  Result := inherited PrepareRange(AnAddr, ALinesBefore, ALinesAfter);
4045end;
4046
4047{ TGDBMIDebuggerCommandDisassembe }
4048
4049procedure TGDBMIDebuggerCommandDisassemble.DoProgress;
4050begin
4051  if assigned(FOnProgress)
4052  then FOnProgress(Self);
4053end;
4054
4055{$ifdef disassemblernestedproc}
4056function TGDBMIDebuggerCommandDisassemble.DoExecute: Boolean;
4057{$endif}
4058  const
4059    TrustedValidity = [avFoundFunction, avFoundRange, avFoundStatement];
4060
4061  procedure PadAddress(var AnAddr: TDisassemblerAddress; APad: Integer);
4062  begin
4063    {$PUSH}{$Q-}{$R-}// APad can be negative, but will be expanded to TDbgPtr (QWord)
4064    AnAddr.Value    := AnAddr.Value + APad;
4065    {$POP}
4066    AnAddr.Validity := avPadded;
4067    AnAddr.Offset   := -1;
4068  end;
4069
4070  function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}ExecDisassmble(AStartAddr, AnEndAddr: TDbgPtr; WithSrc: Boolean;
4071    AResultList: TGDBMIDisassembleResultList = nil;
4072    ACutBeforeEndAddr: Boolean = False): TGDBMIDisassembleResultList;
4073  var
4074    WS: Integer;
4075    R: TGDBMIExecResult;
4076  begin
4077    WS := 0;
4078    if WithSrc
4079    then WS := 1;;
4080    Result := AResultList;
4081    ExecuteCommand('-data-disassemble -s %u -e %u -- %d', [AStartAddr, AnEndAddr, WS], R);
4082    if Result <> nil
4083    then Result.Init(R)
4084    else Result := TGDBMIDisassembleResultList.Create(R);
4085    if ACutBeforeEndAddr and Result.HasSourceInfo
4086    then Result.SortByAddress;
4087    while ACutBeforeEndAddr and (Result.Count > 0) and (Result.LastItem^.Addr >= AnEndAddr)
4088    do Result.Count :=  Result.Count - 1;
4089  end;
4090
4091  // Set Value, based on GuessedValue
4092  function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}AdjustToKnowFunctionStart(var AStartAddr: TDisassemblerAddress): Boolean;
4093  var
4094    DisAssList: TGDBMIDisassembleResultList;
4095    DisAssItm: PDisassemblerEntry;
4096    s: TDBGPtr;
4097  begin
4098    Result := False;
4099    // TODO: maybe try "info symbol <addr>
4100    s := (AStartAddr.GuessedValue -1) div 4 * 4;  // 4 byte boundary
4101    DisAssList := ExecDisassmble(s, s+1, False);
4102    if DisAssList.Count > 0 then begin
4103      DisAssItm := DisAssList.Item[0];
4104      if (DisAssItm^.FuncName <> '') and (DisAssItm^.Addr <> 0) and (DisAssItm^.Offset >= 0)
4105      then begin
4106        AStartAddr.Value := DisAssItm^.Addr - DisAssItm^.Offset;       // This should always be good
4107        AStartAddr.Offset := 0;
4108        AStartAddr.Validity := avFoundFunction;
4109        Result := True;
4110      end;
4111    end;
4112    FreeAndNil(DisAssList);
4113  end;
4114
4115  procedure AdjustLastEntryEndAddr(const ARange: TDBGDisassemblerEntryRange;
4116    const ADisAssList: TGDBMIDisassembleResultList);
4117  var
4118    i: Integer;
4119    TmpAddr: TDBGPtr;
4120  begin
4121    if ARange.Count = 0 then exit;
4122    TmpAddr := ARange.LastAddr;
4123    i := 0;
4124    while (i < ADisAssList.Count) and (ADisAssList.Item[i]^.Addr <= TmpAddr) do inc(i);
4125    if i < ADisAssList.Count
4126    then ARange.LastEntryEndAddr := ADisAssList.Item[i]^.Addr
4127    else if ARange.LastEntryEndAddr <= ARange.RangeEndAddr
4128    then ARange.LastEntryEndAddr := ARange.RangeEndAddr + 1;
4129  end;
4130
4131  procedure CopyToRange(const ADisAssList: TGDBMIDisassembleResultList;
4132    const ADestRange: TDBGDisassemblerEntryRange; AFromIndex, ACount: Integer;
4133    ASrcInfoDisAssList: TGDBMIDisassembleResultList = nil);
4134  var
4135    i, j, MinInSrc, MaxInSrc: Integer;
4136    ItmPtr, ItmPtr2, LastItem: PDisassemblerEntry;
4137  begin
4138    if ASrcInfoDisAssList = ADisAssList
4139    then ASrcInfoDisAssList := nil;
4140    if ADisAssList.Count = 0 then
4141      exit;
4142    // Clean end of range
4143    ItmPtr := ADisAssList.Item[AFromIndex];
4144    i := ADestRange.Count;
4145    while (i > 0) and (ADestRange.EntriesPtr[i-1]^.Addr >= ItmPtr^.Addr) do dec(i);
4146    if ADestRange.Count <> i then debugln(DBG_DISASSEMBLER, ['NOTICE, CopyToRange: Removing ',i,' entries from the end of Range. AFromIndex=',AFromIndex, ' ACount=', ACount, ' Range=',dbgs(ADestRange)]);
4147    ADestRange.Count := i;
4148    if  i > 0 then begin
4149      ItmPtr2 := ADestRange.EntriesPtr[i-1];
4150      if ItmPtr2^.Dump <> '' then begin
4151        {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur
4152        j := (ItmPtr^.Addr - ItmPtr2^.Addr) * 2;
4153        {$POP}
4154        if length(ItmPtr2^.Dump) > j then debugln(DBG_DISASSEMBLER, ['NOTICE, CopyToRange: Shortening Dump at the end of Range. AFromIndex=',AFromIndex, ' ACount=', ACount, ' Range=',dbgs(ADestRange)]);
4155        if length(ItmPtr2^.Dump) > j then ItmPtr2^.Dump := copy(ItmPtr2^.Dump, 1, j);
4156      end;
4157    end;
4158
4159    if ADestRange.Count = 0
4160    then ADestRange.RangeStartAddr := ADisAssList.Item[AFromIndex]^.Addr;
4161
4162    if ADestRange.RangeEndAddr < ADisAssList.Item[AFromIndex+ACount-1]^.Addr
4163    then ADestRange.RangeEndAddr := ADisAssList.Item[AFromIndex+ACount-1]^.Addr;
4164
4165    if ADisAssList.Count > AFromIndex + ACount
4166    then begin
4167      if ADestRange.LastEntryEndAddr < ADisAssList.Item[AFromIndex+ACount]^.Addr
4168      then ADestRange.LastEntryEndAddr := ADisAssList.Item[AFromIndex+ACount]^.Addr;
4169    end
4170    else
4171      if ADestRange.LastEntryEndAddr <= ADestRange.RangeEndAddr
4172      then ADestRange.LastEntryEndAddr := ADestRange.RangeEndAddr + 1;
4173
4174
4175    // Append new items
4176    LastItem := nil;
4177    MinInSrc := 0;
4178    if ASrcInfoDisAssList <> nil
4179    then MaxInSrc := ASrcInfoDisAssList.Count - 1;
4180    for i := AFromIndex to AFromIndex + ACount - 1 do begin
4181      ItmPtr := ADisAssList.Item[i];
4182      ItmPtr2 := nil;
4183      if ASrcInfoDisAssList <> nil
4184      then begin
4185        j := MinInSrc;
4186        while j <= MaxInSrc do begin
4187          ItmPtr2 := ASrcInfoDisAssList.Item[j];
4188          if ItmPtr2^.Addr = itmPtr^.Addr
4189          then break;
4190          inc(j);
4191        end;
4192        if j <= MaxInSrc
4193        then begin
4194          ItmPtr2^.Dump := ItmPtr^.Dump;
4195          ItmPtr := ItmPtr2;
4196        end
4197        else ItmPtr2 := nil;
4198      end;
4199      if (LastItem <> nil) then begin
4200        // unify strings, to keep only one instance
4201        if (ItmPtr^.SrcFileName = LastItem^.SrcFileName)
4202        then ItmPtr^.SrcFileName := LastItem^.SrcFileName;
4203        if (ItmPtr^.FuncName = LastItem^.FuncName)
4204        then ItmPtr^.FuncName:= LastItem^.FuncName;
4205      end;
4206      ADestRange.Append(ItmPtr);
4207      // now we can move the data, pointed to by ItmPtr // reduce search range
4208      if ItmPtr2 <> nil
4209      then begin
4210        // j is valid
4211        if j = MaxInSrc
4212        then dec(MaxInSrc)
4213        else if j = MinInSrc
4214        then inc(MinInSrc)
4215        else begin
4216          ASrcInfoDisAssList.Item[j] := ASrcInfoDisAssList.Item[MaxInSrc];
4217          dec(MaxInSrc);
4218        end;
4219      end;;
4220      LastItem := ItmPtr;
4221    end;
4222    // Src list may be reused for other addresses, so discard used entries
4223    if ASrcInfoDisAssList <> nil
4224    then begin
4225      for i := 0 to Min(MinInSrc - 1, MaxInSrc - MinInSrc) do
4226        ASrcInfoDisAssList.Item[i] := ASrcInfoDisAssList.Item[i + MinInSrc];
4227      ASrcInfoDisAssList.Count := MaxInSrc + 1 - MinInSrc;
4228    end;
4229  end;
4230
4231  procedure AddMemDumpToRange(const ARange: TDBGDisassemblerEntryRange;
4232    AMemDump: TGDBMIMemoryDumpResultList; AFirstAddr, ALastAddr: TDBGPtr);
4233  var
4234    i, Cnt, FromIndex: Integer;
4235    Itm, NextItm: PDisassemblerEntry;
4236    Addr, Offs, Len: TDBGPtr;
4237    s: String;
4238  begin
4239    Cnt := ARange.Count;
4240    if ARange.FirstAddr > AFirstAddr
4241    then FromIndex := -1
4242    else FromIndex := ARange.IndexOfAddrWithOffs(AFirstAddr)-1;
4243    if FromIndex < -1
4244    then exit;
4245
4246    NextItm := ARange.EntriesPtr[FromIndex + 1];
4247    while NextItm <> nil do
4248    begin
4249      inc(FromIndex);
4250      Itm := NextItm;
4251      if Itm^.Addr > ALastAddr
4252      then break;
4253
4254      if FromIndex < Cnt - 1
4255      then NextItm := ARange.EntriesPtr[FromIndex + 1]
4256      else NextItm := nil;
4257
4258      if (Itm^.Dump <> '')
4259      then Continue;
4260      Itm^.Dump := ' ';
4261
4262      {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur
4263      Addr := Itm^.Addr;
4264      Offs := TDBGPtr(Addr - AMemDump.Addr);
4265      if (Offs >= AMemDump.Count)
4266      then Continue;
4267
4268      if (NextItm <> nil) //and (NextItm^.Addr > Addr)
4269      then Len := NextItm^.Addr - Addr
4270      else Len := AMemDump.Count - 1 - Offs;
4271      if Offs + Len >= AMemDump.Count
4272      then Len := AMemDump.Count - 1 - Offs;
4273      if Len = 0
4274      then Continue;
4275      if Len > 32
4276      then Len := 32;
4277      {$POP}
4278      s := '';
4279      for i := Offs to Offs + Len - 1 do
4280        s := s + Copy(AMemDump.ItemTxt[i],3,2);
4281      Itm^.Dump := s;
4282    end;
4283  end;
4284
4285  (* Known issues with GDB's disassembler results:
4286    ** "-data-disassemble -s ### -e ### -- 1" with source
4287       * Result may not be sorted by addresses
4288       =>
4289       * Result may be empty, even where "-- 0" (no src info) does return data
4290       => Remedy: disassemble those secions without src-info
4291         If function-offset is available, this can be done per function
4292       * Result may be missing src-info, even if src-info is available for parts of the result
4293         This seems to be the case, if no src info is available for the start address,
4294         then src-info for later addresses will be ignored.
4295       => Remedy: if function offset is available, disassembl;e per function
4296       * Contains address gaps, as it does not show fillbytes, between functions
4297    ** "-data-disassemble -s ### -e ### -- 0" without source (probably both (with/without src)
4298       * "func-name" may change, while "offset" keeps increasing
4299         This was seen after the end of a procedure, with 0x00 bytes filling up to the next proc
4300       => Remedy: None, can be ignored
4301       * In contineous disassemble a function may not be started at offset=0.
4302         This seems to happen after 0x00 fill bytes.
4303         The func-name changes and the offset restarts at a lower value (but not 0)
4304       => Remedy: discard data, and re-disassemble
4305  *)
4306  // Returns   True: If some data was added
4307  //           False: if failed to add anything
4308  function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}DoDisassembleRange(AnEntryRanges: TDBGDisassemblerEntryMap;AFirstAddr,
4309    ALastAddr: TDisassemblerAddress; StopAfterAddress: TDBGPtr;
4310    StopAfterNumLines: Integer): Boolean;
4311
4312    procedure AddRangetoMemDumpsNeeded(NewRange: TDBGDisassemblerEntryRange);
4313    var
4314      i: Integer;
4315    begin
4316      i := length(FMemDumpsNeeded);
4317      if (i > 0)
4318      then begin
4319        if  (NewRange.RangeStartAddr <= FMemDumpsNeeded[0].FirstAddr)
4320        and (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[0].FirstAddr)
4321        then FMemDumpsNeeded[0].FirstAddr := NewRange.RangeStartAddr
4322        else
4323        if  (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[0].LastAddr)
4324        and (NewRange.RangeStartAddr <= FMemDumpsNeeded[0].LastAddr)
4325        then FMemDumpsNeeded[0].LastAddr := NewRange.LastEntryEndAddr + 1
4326        else
4327        if  (NewRange.RangeStartAddr <= FMemDumpsNeeded[i-1].FirstAddr)
4328        and (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[i-1].FirstAddr)
4329        then FMemDumpsNeeded[i-1].FirstAddr := NewRange.RangeStartAddr
4330        else
4331        if  (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[i-1].LastAddr)
4332        and (NewRange.RangeStartAddr <= FMemDumpsNeeded[i-1].LastAddr)
4333        then FMemDumpsNeeded[i-1].LastAddr := NewRange.LastEntryEndAddr + 1
4334        else begin
4335          SetLength(FMemDumpsNeeded, i + 1);
4336          FMemDumpsNeeded[i].FirstAddr := NewRange.RangeStartAddr;
4337          FMemDumpsNeeded[i].LastAddr := NewRange.LastEntryEndAddr + 1;
4338        end;
4339      end
4340      else begin
4341        SetLength(FMemDumpsNeeded, i + 1);
4342        FMemDumpsNeeded[i].FirstAddr := NewRange.RangeStartAddr;
4343        FMemDumpsNeeded[i].LastAddr := NewRange.LastEntryEndAddr + 1;
4344      end;
4345    end;
4346
4347    procedure DoDisassembleSourceless(ASubFirstAddr, ASubLastAddr: TDBGPtr;
4348      ARange: TDBGDisassemblerEntryRange; SkipFirstAddresses: Boolean = False);
4349    var
4350      DisAssList, DisAssListCurrentSub: TGDBMIDisassembleResultList;
4351      DisAssIterator: TGDBMIDisassembleResultFunctionIterator;
4352      i: Integer;
4353    begin
4354      DisAssListCurrentSub := nil;
4355      DisAssList := ExecDisassmble(ASubFirstAddr, ASubLastAddr, False, nil, True);
4356      if DisAssList.Count > 0 then begin
4357        i := 0;
4358        if SkipFirstAddresses
4359        then i := 1; // skip the instruction exactly at ASubFirstAddr;
4360        DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
4361          (DisAssList, i, ASubLastAddr, FStartAddr, 0);
4362        ARange.Capacity := Max(ARange.Capacity, ARange.Count  + DisAssList.Count);
4363        // add without source
4364        while not DisAssIterator.EOL
4365        do begin
4366          DisAssIterator.NextSubList(DisAssListCurrentSub);
4367          // ignore StopAfterNumLines, until we have at least the source;
4368
4369          if (not DisAssIterator.IsFirstSubList) and (DisAssListCurrentSub.Item[0]^.Offset <> 0)
4370          then begin
4371            // Current block starts with offset. Adjust and disassemble again
4372            debugln(DBG_DISASSEMBLER, ['WARNING: Sublist not at offset 0 (filling gap in/before Src-Info): FromIdx=', DisAssIterator.CurrentIndex, ' NextIdx=', DisAssIterator.NextIndex,
4373                     ' SequenceNo=', DisAssIterator.SublistNumber, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
4374            DisAssListCurrentSub := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
4375              DisAssIterator.NextStartAddr, False, DisAssListCurrentSub, True);
4376          end;
4377
4378          CopyToRange(DisAssListCurrentSub, ARange, 0, DisAssListCurrentSub.Count);
4379        end;
4380
4381        FreeAndNil(DisAssIterator);
4382      end;
4383      FreeAndNil(DisAssList);
4384      FreeAndNil(DisAssListCurrentSub);
4385    end;
4386
4387  var
4388    DisAssIterator: TGDBMIDisassembleResultFunctionIterator;
4389    DisAssList, DisAssListCurrentSub, DisAssListWithSrc: TGDBMIDisassembleResultList;
4390    i, Cnt, DisAssStartIdx: Integer;
4391    NewRange: TDBGDisassemblerEntryRange;
4392    OrigLastAddress, OrigFirstAddress: TDisassemblerAddress;
4393    TmpAddr: TDBGPtr;
4394    BlockOk, SkipDisAssInFirstLoop, ContinueAfterSource: Boolean;
4395    Itm: TDisassemblerEntry;
4396  begin
4397    Result := False;
4398    DisAssList := nil;
4399    DisAssListCurrentSub := nil;
4400    DisAssListWithSrc := nil;
4401    DisAssIterator := nil;
4402    OrigFirstAddress := AFirstAddr;
4403    OrigLastAddress := ALastAddr;
4404    SkipDisAssInFirstLoop := False;
4405
4406    NewRange := TDBGDisassemblerEntryRange.Create;
4407    // set some values, wil be adjusted later (in CopyToRange
4408    NewRange.RangeStartAddr := AFirstAddr.Value;
4409    NewRange.RangeEndAddr   := ALastAddr.Value;
4410    NewRange.LastEntryEndAddr := ALastAddr.Value;
4411
4412    // No nice startingpoint found, just start to disassemble aprox 5 instructions before it
4413    // and hope that when we started in the middle of an instruction it get sorted out.
4414    // If so, the 4st for lines from the result must be discarded
4415    if not (AFirstAddr.Validity in TrustedValidity)
4416    then PadAddress(AFirstAddr, - 5 * DAssBytesPerCommandMax);
4417
4418    // Adjust ALastAddr
4419    if ALastAddr.Value <= AFirstAddr.Value
4420    then begin
4421      ALastAddr.Value := AFirstAddr.Value;
4422      PadAddress(ALastAddr, 2 * DAssBytesPerCommandMax);
4423    end
4424    else
4425    if not (ALastAddr.Validity in TrustedValidity)
4426    then PadAddress(ALastAddr, 2 * DAssBytesPerCommandMax);
4427
4428    DebugLnEnter(DBG_DISASSEMBLER, ['INFO: DoDisassembleRange for AFirstAddr =', Dbgs(AFirstAddr),
4429    ' ALastAddr=', Dbgs(ALastAddr), ' OrigFirst=', Dbgs(OrigFirstAddress), ' OrigLastAddress=', Dbgs(OrigLastAddress),
4430    '  StopAffterAddr=', StopAfterAddress, ' StopAfterLines=',  StopAfterNumLines ]);
4431    try  // only needed for debugln DBG_DISASSEMBLER,
4432
4433    // check if we have an overall source-info
4434    // we can only do that, if we know the offset of firstaddr (limit to DAssRangeOverFuncTreshold avg lines, should be enough)
4435    // TODO: limit offset ONLY, if previous range known (already have disass)
4436    if (AFirstAddr.Offset >= 0)
4437    then begin
4438      TmpAddr := AFirstAddr.Value - Min(AFirstAddr.Offset, DAssRangeOverFuncTreshold * DAssBytesPerCommandAvg);
4439      DisAssListWithSrc := ExecDisassmble(TmpAddr, ALastAddr.Value, True);
4440    end;
4441
4442    if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0) and DisAssListWithSrc.HasSourceInfo
4443    then begin
4444      DisAssListWithSrc.SortByAddress;
4445      // gdb may return data far out of range.
4446      if (DisAssListWithSrc.LastItem^.Addr < TmpAddr) and
4447         (TmpAddr - DisAssListWithSrc.LastItem^.Addr > DAssMaxRangeSize)
4448      then FreeAndNil(DisAssListWithSrc);
4449    end;
4450
4451    if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0) and DisAssListWithSrc.HasSourceInfo
4452    then begin
4453      (* ***
4454         *** Add the full source info
4455         ***
4456      *)
4457      Result := True;
4458      //DisAssListWithSrc.SortByAddress;
4459      if DisAssListWithSrc.Item[0]^.Addr > AFirstAddr.Value
4460      then begin
4461        // fill in gap at start
4462        DoDisassembleSourceless(AFirstAddr.Value, DisAssListWithSrc.Item[0]^.Addr, NewRange);
4463      end;
4464
4465      // Find out what comes after the disassembled source (need at least one statemnet, to determine end-add of last src-stmnt)
4466      TmpAddr := DisAssListWithSrc.LastItem^.Addr;
4467      ContinueAfterSource := OrigLastAddress.Value > TmpAddr;
4468      if ContinueAfterSource
4469      then TmpAddr := ALastAddr.Value;
4470      DisAssList := ExecDisassmble(DisAssListWithSrc.LastItem^.Addr,
4471                                   TmpAddr + 2 * DAssBytesPerCommandAlign, False);
4472
4473      // Add the known source list
4474      if DisAssList.Count < 2
4475      then TmpAddr := ALastAddr.Value
4476      else TmpAddr := DisAssList.Item[1]^.Addr;
4477
4478      DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
4479        (DisAssListWithSrc, 0, TmpAddr , FStartAddr, StopAfterAddress);
4480      NewRange.Capacity := Max(NewRange.Capacity, NewRange.Count  + DisAssListWithSrc.Count);
4481      while not DisAssIterator.EOL
4482      do begin
4483        if (dcsCanceled in SeenStates) then break;
4484        DisAssIterator.NextSubList(DisAssListCurrentSub);
4485        CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count); // Do not add the Sourcelist as last param, or it will get re-sorted
4486
4487        // check for gap
4488        if DisAssListCurrentSub.LastItem^.Addr < DisAssIterator.NextStartAddr - DAssBytesPerCommandAlign
4489        then begin
4490          debugln(DBG_DISASSEMBLER, ['Info: Filling GAP in the middle of Source: Src-FromIdx=', DisAssIterator.CurrentIndex, ' Src-NextIdx=', DisAssIterator.NextIndex,
4491                   ' Src-SequenceNo=', DisAssIterator.SublistNumber, '  Last Address in Src-Block=', DisAssListCurrentSub.LastItem^.Addr ]);
4492          DoDisassembleSourceless(DisAssListCurrentSub.LastItem^.Addr, DisAssIterator.NextStartAddr, NewRange, True);
4493        end;
4494      end;
4495      i := DisAssIterator.CountLinesAfterCounterAddr;
4496
4497      FreeAndNil(DisAssIterator);
4498      FreeAndNil(DisAssListWithSrc);
4499      FreeAndNil(DisAssListCurrentSub);
4500      // Source Completly Added
4501
4502      if not ContinueAfterSource
4503      then begin
4504        AdjustLastEntryEndAddr(NewRange, DisAssList);
4505        AddRangetoMemDumpsNeeded(NewRange);
4506        AnEntryRanges.AddRange(NewRange);  // NewRange is now owned by AnEntryRanges
4507        NewRange := nil;
4508        FreeAndNil(DisAssList);
4509        exit;
4510      end;
4511
4512      // continue with the DisAsslist for the remainder
4513      AFirstAddr.Validity := avFoundFunction; //  if we got source, then start is ok (original start is kept)
4514      DisAssStartIdx := 1;
4515      SkipDisAssInFirstLoop := True;
4516      if i > 0
4517      then StopAfterNumLines := StopAfterNumLines - i;
4518      (* ***
4519         *** Finished adding the full source info
4520         ***
4521      *)
4522    end
4523    else begin
4524      (* ***
4525         *** Full Source was not available
4526         ***
4527      *)
4528      if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0)
4529      then begin
4530        DisAssList := DisAssListWithSrc; // got data already
4531        DisAssListWithSrc := nil;
4532      end
4533      else begin
4534        DisAssList := ExecDisassmble(AFirstAddr.Value, ALastAddr.Value, False);
4535      end;
4536
4537      if DisAssList.Count < 2
4538      then begin
4539        debugln('Error failed to get enough data for dsassemble');
4540        // create a dummy range, so we will not retry
4541        NewRange.Capacity := 1;
4542        NewRange.RangeStartAddr   := AFirstAddr.Value;
4543        if OrigLastAddress.Value > AFirstAddr.Value+1
4544        then NewRange.RangeEndAddr     := OrigLastAddress.Value
4545        else NewRange.RangeEndAddr     := AFirstAddr.Value+1;
4546        NewRange.LastEntryEndAddr := AFirstAddr.Value+1;
4547        Itm.Addr := AFirstAddr.Value;
4548        Itm.Dump := ' ';
4549        Itm.SrcFileLine := 0;
4550        Itm.Offset := 0;
4551        itm.Statement := '<error>';
4552        NewRange.Append(@Itm);
4553        AnEntryRanges.AddRange(NewRange);  // NewRange is now owned by AnEntryRanges
4554        NewRange := nil;
4555        FreeAndNil(DisAssList);
4556        exit;
4557      end;
4558
4559      DisAssStartIdx := 0;
4560    end;
4561
4562    // we may have gotten more lines than ask, and the last line we don't know the length
4563    Cnt := DisAssList.Count;
4564    if (ALastAddr.Validity = avPadded) or (DisAssList.LastItem^.Addr >= ALastAddr.Value)
4565    then begin
4566      ALastAddr.Value := DisAssList.LastItem^.Addr;
4567      ALastAddr.Validity := avFoundStatement;
4568      dec(Cnt);
4569      DisAssList.Count := Cnt;
4570    end;
4571    // ALastAddr.Value is now the address after the last statement;
4572
4573    if (AFirstAddr.Validity = avPadded) // always False, if we had source-info
4574    then begin
4575      // drop up to 4 entries, if possible
4576      while (DisAssStartIdx < 4) and (DisAssStartIdx + 1 < Cnt) and (DisAssList.Item[DisAssStartIdx+1]^.Addr <= OrigFirstAddress.Value)
4577      do inc(DisAssStartIdx);
4578      AFirstAddr.Value := DisAssList.Item[DisAssStartIdx]^.Addr;
4579      AFirstAddr.Validity := avFoundStatement;
4580    end;
4581
4582
4583    NewRange.Capacity := Max(NewRange.Capacity, NewRange.Count  + Cnt);
4584
4585    DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
4586      (DisAssList, DisAssStartIdx, ALastAddr.Value, FStartAddr, StopAfterAddress);
4587
4588    while not DisAssIterator.EOL
4589    do begin
4590      if (dcsCanceled in SeenStates) then break;
4591      BlockOk := DisAssIterator.NextSubList(DisAssListCurrentSub);
4592
4593      // Do we have enough lines (without the current block)?
4594      if (DisAssIterator.CountLinesAfterCounterAddr > StopAfterNumLines)
4595      then begin
4596        DebugLn(DBG_DISASSEMBLER, ['INFO: Got enough line in Iteration: CurrentIndex=', DisAssIterator.CurrentIndex]);
4597        NewRange.LastEntryEndAddr := DisAssIterator.NextStartAddr;
4598        //AdjustLastEntryEndAddr(NewRange, DisAssList);
4599        break;
4600      end;
4601
4602      if (not DisAssIterator.IsFirstSubList) and (DisAssListCurrentSub.Item[0]^.Offset <> 0)
4603      then begin
4604        // Got List with Offset at start
4605        debugln(DBG_DISASSEMBLER, ['WARNING: Sublist not at offset 0 (offs=',DisAssListCurrentSub.Item[0]^.Offset,'): FromIdx=', DisAssIterator.CurrentIndex, ' NextIdx=', DisAssIterator.NextIndex,
4606                 ' SequenceNo=', DisAssIterator.SublistNumber, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
4607        // Current block starts with offset. Adjust and disassemble again
4608        // Try with source first, in case it returns dat without source
4609        DisAssListWithSrc := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
4610          DisAssIterator.NextStartAddr, True, DisAssListWithSrc, True);
4611        if (DisAssListWithSrc.Count > 0)
4612        then begin
4613          if DisAssListWithSrc.HasSourceInfo
4614          then DisAssListWithSrc.SortByAddress;
4615          if (not DisAssListWithSrc.HasSourceInfo)
4616          or (DisAssListWithSrc.LastItem^.Addr > DisAssIterator.NextStartAddr - DAssBytesPerCommandAlign)
4617          then begin
4618            // no source avail, but got data
4619            // OR source and no gap
4620            CopyToRange(DisAssListWithSrc, NewRange, 0, DisAssListWithSrc.Count);
4621            Result := True;
4622            continue;
4623          end;
4624        end;
4625
4626        //get the source-less code as reference
4627        DisAssListCurrentSub := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
4628          DisAssIterator.NextStartAddr, False, DisAssListCurrentSub, True);
4629        CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count, DisAssListWithSrc);
4630        Result := Result or (DisAssListCurrentSub.Count > 0);
4631        continue;
4632      end;
4633
4634      // Todo: Check for wrong start stmnt offset
4635      if BlockOk
4636      then begin
4637        // Got a good block
4638        if (DisAssListCurrentSub.Item[0]^.FuncName <> '')
4639        then begin
4640          // Try to get source-info (up to DisAssIterator.NextStartAddr)
4641          // Subtract offset from StartAddress, in case this is the first block
4642          //   (we may continue existing data, but src info must be retrieved in full, or may be incomplete)
4643          if  not( DisAssIterator.IsFirstSubList and SkipDisAssInFirstLoop )
4644          then begin
4645            DisAssListWithSrc := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
4646                DisAssIterator.NextStartAddr, True, DisAssListWithSrc, True);
4647            // We may have less lines with source, as we stripped padding at the end
4648            if (DisAssListWithSrc <> nil) and DisAssListWithSrc.HasSourceInfo
4649            then begin
4650              CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count, DisAssListWithSrc);
4651              Result := Result or (DisAssListCurrentSub.Count > 0);
4652              continue;
4653            end;
4654          end;
4655        end;
4656        CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count);
4657        Result := Result or (DisAssListCurrentSub.Count > 0);
4658        continue;
4659      end;
4660
4661      // Got a problematic block
4662      debugln(DBG_DISASSEMBLER, ['WARNING: FindProcEnd reported an issue FromIdx=', DisAssIterator.CurrentIndex,' NextIdx=',
4663      DisAssIterator.NextIndex, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
4664      //if DisAssIterator.IsFirstSubList and (not(AFirstAddr.Validity in TrustedValidity))
4665      //and (DisAssIterator.IndexOfLocateAddress >= DisAssIterator.CurrentIndex) // in current list
4666      //and (DisAssIterator.OffsetOfLocateAddress <> 0)
4667      //then begin
4668      //  // FStartAddr is in the middle of a statement. Maybe move the Range?
4669      //end;
4670
4671      CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count);
4672      Result := Result or (DisAssListCurrentSub.Count > 0);
4673    end;
4674
4675    if NewRange.LastEntryEndAddr > NewRange.RangeEndAddr
4676    then NewRange.RangeEndAddr := NewRange.LastEntryEndAddr;
4677
4678    AddRangetoMemDumpsNeeded(NewRange);
4679    AnEntryRanges.AddRange(NewRange);  // NewRange is now owned by AnEntryRanges
4680    NewRange := nil;
4681
4682    FreeAndNil(DisAssIterator);
4683    FreeAndNil(DisAssList);
4684    FreeAndNil(DisAssListCurrentSub);
4685    FreeAndNil(DisAssListWithSrc);
4686    finally
4687      DebugLnExit(DBG_DISASSEMBLER, ['INFO: DoDisassembleRange finished' ]);
4688    end;
4689  end;
4690
4691  function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}OnCheckCancel: boolean;
4692  begin
4693    result := dcsCanceled in SeenStates;
4694  end;
4695
4696{$ifndef disassemblernestedproc}
4697function TGDBMIDebuggerCommandDisassemble.DoExecute: Boolean;
4698{$endif disassemblernestedproc}
4699
4700  function ExecMemDump(AStartAddr: TDbgPtr; ACount: Cardinal;
4701    AResultList: TGDBMIMemoryDumpResultList = nil): TGDBMIMemoryDumpResultList;
4702  var
4703    R: TGDBMIExecResult;
4704  begin
4705    Result := AResultList;
4706    ExecuteCommand('-data-read-memory %u x 1 1 %u', [AStartAddr, ACount], R);
4707    if Result <> nil
4708    then Result.Init(R)
4709    else Result := TGDBMIMemoryDumpResultList.Create(R);
4710  end;
4711
4712  procedure AddMemDumps;
4713  var
4714    i: Integer;
4715    MemDump: TGDBMIMemoryDumpResultList;
4716    Rng: TDBGDisassemblerEntryRange;
4717    FirstAddr: TDBGPtr;
4718  begin
4719    MemDump := nil;
4720    for i := 0 to length(FMemDumpsNeeded) - 1 do
4721    begin
4722      if (dcsCanceled in SeenStates) then break;
4723      FirstAddr := FMemDumpsNeeded[i].FirstAddr;
4724      Rng := FRangeIterator.GetRangeForAddr(FirstAddr, True);
4725      if rng <> nil
4726      then MemDump := ExecMemDump(FirstAddr, FMemDumpsNeeded[i].LastAddr - FirstAddr, MemDump);
4727      if DebuggerState <> dsError
4728      then begin
4729        while (Rng <> nil) and (Rng.FirstAddr <= FMemDumpsNeeded[i].LastAddr) do
4730        begin
4731          AddMemDumpToRange(Rng, MemDump, FMemDumpsNeeded[i].FirstAddr, FMemDumpsNeeded[i].LastAddr);
4732          Rng := FRangeIterator.NextRange;
4733        end;
4734      end;
4735    end;
4736    FreeAndNil(MemDump);
4737  end;
4738
4739var
4740  DisassembleRangeExtender: TDBGDisassemblerRangeExtender;
4741begin
4742  FContext.ThreadContext := ccNotRequired;
4743  FContext.StackContext := ccNotRequired;
4744
4745  if FEndAddr < FStartAddr
4746  then FEndAddr := FStartAddr;
4747
4748  DisassembleRangeExtender := TDBGDisassemblerRangeExtender.Create(FKnownRanges);
4749  try
4750    DisassembleRangeExtender.OnDoDisassembleRange:=@DoDisassembleRange;
4751    DisassembleRangeExtender.OnCheckCancel:=@OnCheckCancel;
4752    DisassembleRangeExtender.OnAdjustToKnowFunctionStart:=@AdjustToKnowFunctionStart;
4753    result := DisassembleRangeExtender.DisassembleRange(FLinesBefore, FLinesAfter, FStartAddr, FStartAddr);
4754  finally
4755    DisassembleRangeExtender.Free;
4756  end;
4757
4758  DoProgress;
4759  AddMemDumps;
4760  DoProgress;
4761end;
4762
4763constructor TGDBMIDebuggerCommandDisassemble.Create(AOwner: TGDBMIDebugger;
4764  AKnownRanges: TDBGDisassemblerEntryMap; AStartAddr, AEndAddr: TDbgPtr; ALinesBefore,
4765  ALinesAfter: Integer);
4766begin
4767  inherited Create(AOwner);
4768  FKnownRanges := AKnownRanges;
4769  FRangeIterator:= TDBGDisassemblerEntryMapIterator.Create(FKnownRanges);
4770  FStartAddr := AStartAddr;
4771  FEndAddr := AEndAddr;
4772  FLinesBefore := ALinesBefore;
4773  FLinesAfter := ALinesAfter;
4774end;
4775
4776destructor TGDBMIDebuggerCommandDisassemble.Destroy;
4777begin
4778  FreeAndNil(FRangeIterator);
4779  inherited Destroy;
4780end;
4781
4782function TGDBMIDebuggerCommandDisassemble.DebugText: String;
4783begin
4784  Result := Format('%s: FromAddr=%u ToAddr=%u LinesBefore=%d LinesAfter=%d',
4785                   [ClassName, FStartAddr, FEndAddr, FLinesBefore, FLinesAfter]);
4786end;
4787
4788{ TGDBMIDebuggerCommandStartDebugging }
4789
4790function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
4791
4792  {$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
4793  procedure InitConsole;
4794  var
4795    R: TGDBMIExecResult;
4796    s: String;
4797    h: THandle;
4798    isConsole: Boolean;
4799  begin
4800      isConsole := False;
4801      // Make sure consule output will ot be mixed with gbd output
4802      {$IFDEF DBG_ENABLE_TERMINAL}
4803        {$IFDEF UNIX}
4804          (* DBG_ENABLE_TERMINAL and UNIX *)
4805          s := DebuggerProperties.ConsoleTty;
4806          if s = '' then begin
4807            FTheDebugger.FPseudoTerminal.Open;
4808            s := FTheDebugger.FPseudoTerminal.Devicename;
4809            isConsole := True;
4810          end;
4811        {$ELSE}
4812          (* only DBG_ENABLE_TERMINAL *)
4813          FTheDebugger.FPseudoTerminal.Open;
4814          s := FTheDebugger.FPseudoTerminal.Devicename;
4815          isConsole := True;
4816        {$ENDIF}
4817      {$ELSE}
4818          (* only UNIX *)
4819          s := DebuggerProperties.ConsoleTty;
4820          if s = '' then s := '/dev/null';
4821      {$ENDIF}
4822
4823      if not isConsole then begin
4824        h := fileopen(S, fmOpenWrite);
4825        isConsole := IsATTY(h) = 1;
4826        FileClose(h);
4827      end;
4828
4829      if isConsole then
4830        isConsole := ExecuteCommand('set inferior-tty %s', [s], R) and (r.State <> dsError);
4831      if not isConsole then
4832        ExecuteCommand('set inferior-tty /dev/null', []);
4833  end;
4834  {$ENDIF}
4835
4836  var
4837    FndOffsFile, FndOffsLine: String;
4838    StoppedFile, StoppedLine: String;
4839    StoppedAddr: TDBGPtr;
4840    StoppedAtEntryPoint: Boolean;
4841  const
4842    MIN_RELOC_ADDRESS = $4000;
4843
4844  procedure RunToMain(EntryPoint: String);
4845  type
4846    TRunToMainType = (mtMain, mtMainAddr, mtEntry, mtAddZero);
4847  var
4848    EntryPointNum: TDBGPtr;
4849
4850    function SetMainBrk: boolean;
4851      procedure MaybeAddMainBrk(AType: TRunToMainType; AnSkipIfCntGreater: Integer;
4852        ACheckEntryPoinReloc: Boolean = false);
4853      begin
4854        // Check if the Entrypoint looks promising (if it looks like it matches the relocated address)
4855        if ACheckEntryPoinReloc and not(EntryPointNum > MIN_RELOC_ADDRESS) then
4856          exit;
4857        // Check amount of already set breakpoints
4858        if (AnSkipIfCntGreater >= 0) and (FTheDebugger.FMainAddrBreak.BreakSetCount > AnSkipIfCntGreater) then
4859          exit;
4860        case AType of
4861          mtMain:     FTheDebugger.FMainAddrBreak.SetByName(Self);
4862          mtMainAddr: FTheDebugger.FMainAddrBreak.SetByAddr(Self);
4863          mtEntry:    FTheDebugger.FMainAddrBreak.SetAtCustomAddr(Self, StrToQWordDef(EntryPoint, 0));
4864          mtAddZero:  FTheDebugger.FMainAddrBreak.SetAtLineOffs(Self, 0);
4865        end;
4866
4867        if (AType = mtAddZero) and (FndOffsFile = '') then begin
4868          FndOffsLine := FTheDebugger.FMainAddrBreak.BreakLine[iblAddOffset];
4869          if (FndOffsLine <> '') then
4870            FndOffsFile := FTheDebugger.FMainAddrBreak.BreakFile[iblAddOffset];
4871        end;
4872      end;
4873    var
4874      bcnt: Integer;
4875    begin
4876      Result := False;
4877      bcnt := FTheDebugger.FMainAddrBreak.BreakSetCount;
4878      case DebuggerProperties.InternalStartBreak of
4879        gdsbEntry:    begin
4880            MaybeAddMainBrk(mtEntry,     -1, true);
4881            if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
4882              MaybeAddMainBrk(mtEntry,     -1, false);
4883              MaybeAddMainBrk(mtAddZero,   -1);
4884              // set only, if no other is set (e.g. 2nd attempt)
4885              MaybeAddMainBrk(mtMainAddr,   0);
4886              MaybeAddMainBrk(mtMain,       0);
4887            end;
4888          end;
4889        gdsbMainAddr: begin
4890            MaybeAddMainBrk(mtMainAddr,  -1);
4891            // set only, if no other is set (e.g. 2nd attempt)
4892            if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
4893              MaybeAddMainBrk(mtEntry,      0, true);
4894              MaybeAddMainBrk(mtAddZero,    1);
4895              MaybeAddMainBrk(mtEntry,      0, false);
4896              MaybeAddMainBrk(mtMain,       0);
4897            end;
4898          end;
4899        gdsbMain:     begin
4900            MaybeAddMainBrk(mtMain,      -1);
4901            // set only, if no other is set (e.g. 2nd attempt)
4902            MaybeAddMainBrk(mtAddZero,    0);
4903            MaybeAddMainBrk(mtMainAddr,   0);
4904            MaybeAddMainBrk(mtEntry,      0, false);
4905          end;
4906        gdsbAddZero:  begin
4907            MaybeAddMainBrk(mtAddZero,    -1);
4908            // set only, if no other is set (e.g. 2nd attempt)
4909            MaybeAddMainBrk(mtEntry,      0, true);
4910            MaybeAddMainBrk(mtMain,       0);
4911            MaybeAddMainBrk(mtEntry,      0, false);
4912            MaybeAddMainBrk(mtMainAddr,   0);
4913          end;
4914        else begin // gdsbDefault
4915            // SetByName: "main", this is the best aproach, unless any library also exports main.
4916            MaybeAddMainBrk(mtMain,      -1);
4917            MaybeAddMainBrk(mtEntry,     -1, true); // Previous versions used "+0" as 2nd in the list
4918            MaybeAddMainBrk(mtAddZero,   -1);
4919            MaybeAddMainBrk(mtMainAddr,   2); // set only, if less than 2 are set
4920            // set only, if no other is set (e.g. 2nd attempt)
4921            MaybeAddMainBrk(mtEntry,     0, false);
4922          end;
4923      end;
4924      Result := bcnt < FTheDebugger.FMainAddrBreak.BreakSetCount; // added new breaks
4925    end;
4926
4927  function ParseLogForPid(ALogTxt: String): Integer;
4928  var
4929    s: String;
4930  begin
4931    s := GetPart(['=thread-group-started,'], [LineEnding], ALogTxt, True, False);
4932    if s <> '' then
4933      s := GetPart(['pid="'], ['"'], s, True, False);
4934    if s <> '' then begin
4935      Result := StrToIntDef(s, 0);
4936      if Result <> 0 then exit;
4937    end;
4938
4939    s := GetPart(['process '], [' local', ']'], ALogTxt, True);
4940    Result := StrToIntDef(s, 0);
4941  end;
4942
4943  function ParseStopped(AParam: String): Integer;
4944  var
4945    List: TGDBMINameValueList;
4946    Reason: String;
4947  begin
4948    Result := -1; // no id found
4949    List := nil;
4950    try
4951      List := TGDBMINameValueList.Create(AParam);
4952      Reason := List.Values['reason'];
4953      if (Reason = 'exited-normally') or (Reason = 'exited') or
4954         (Reason = 'exited-signalled')
4955      then
4956        Result := -2;
4957      // if Reason = 'signal-received' // Pause ?
4958      if Reason = 'breakpoint-hit' then begin
4959        Result := StrToIntDef(List.Values['bkptno'], -1);
4960        StoppedAtEntryPoint := Result = FTheDebugger.FMainAddrBreak.BreakId[iblCustomAddr];
4961        List.SetPath('frame');
4962        StoppedAddr := StrToInt64Def(List.Values['addr'], -1);
4963        StoppedFile := List.Values['fullname'];
4964        if StoppedFile = '' then
4965          StoppedFile := List.Values['file'];
4966        StoppedLine := List.Values['line'];
4967      end;
4968    except
4969    end;
4970    List.Free;
4971  end;
4972
4973  var
4974    R: TGDBMIExecResult;
4975    Cmd, s, s2, rval: String;
4976    i, j, LoopCnt: integer;
4977    //List: TGDBMINameValueList;
4978    BrkErr: Boolean;
4979  begin
4980    EntryPointNum := StrToQWordDef(EntryPoint, 0);
4981    TargetInfo^.TargetPID := 0;
4982    FDidKillNow := False;
4983
4984    // TODO: async
4985    Cmd := GdbRunCommand;// '-exec-run';
4986    rval := '';
4987    R.State := dsError;
4988    FTheDebugger.FMainAddrBreak.Clear(Self);
4989    LoopCnt := 6; // max iterations
4990    while (LoopCnt > 0) and not(DebuggerState = dsError) do begin
4991      dec(LoopCnt);
4992      SetMainBrk;
4993      if not FTheDebugger.FMainAddrBreak.IsBreakSet
4994      then begin
4995        (* TODO:
4996           If no main break can be set, it may still be possible (desirable) to run
4997           the app, without debug-capacbilities
4998           Or maybe even try to set all breakpoints.
4999        *)
5000        SetDebuggerErrorState(Format(gdbmiCommandStartMainBreakError, [LineEnding]),
5001                              ErrorStateInfo);
5002        exit; // failed to find a main breakpoint
5003      end;
5004
5005      // RUN
5006      DefaultTimeOut := 0;
5007      if not ExecuteCommand(Cmd, R, [cfTryAsync])
5008      then begin
5009        SetDebuggerErrorState(Format(gdbmiCommandStartMainRunError, [LineEnding]),
5010                              ErrorStateInfo);
5011        exit;
5012      end;
5013      s := r.Values + FLogWarnings;
5014      if TargetInfo^.TargetPID = 0 then
5015        TargetInfo^.TargetPID := ParseLogForPid(s);
5016
5017      s2 := '';
5018      if R.State = dsRun
5019      then begin
5020        if not (rfAsyncFailed in R.Flags) then begin
5021          FCanKillNow := True;
5022          FTheDebugger.FCurrentCmdIsAsync := True;
5023        end;
5024        if (TargetInfo^.TargetPID <> 0) then
5025          FCanKillNow := True;
5026        ProcessRunning(s2, R);
5027        FCanKillNow := False;
5028        FTheDebugger.FCurrentCmdIsAsync := False;
5029        j := ParseStopped(s2);
5030        if (j = -2) or (pos('reason="exited-normally"', s2) > 0) or FDidKillNow then begin
5031          // app has already run
5032          R.State := dsStop;
5033          break;
5034        end;
5035        R.State := dsRun; // restore cmd state
5036        s := s + s2 + R.Values;
5037        Cmd := '-exec-continue'; // until we hit one of the breakpoints
5038      end;
5039
5040      rval := rval + s;
5041
5042      DefaultTimeOut := DebuggerProperties.TimeoutForEval;   // Getting address for breakpoints may need timeout
5043      BrkErr := ParseBreakInsertError(s, i);
5044      if not BrkErr
5045      then break;
5046
5047      j := FTheDebugger.FMainAddrBreak.BreakSetCount;
5048      while BrkErr and not(DebuggerState = dsError) do begin
5049        if not FTheDebugger.FMainAddrBreak.ClearAndBlockId(Self, i)
5050        then begin
5051          DebugLn(DBG_WARNINGS, ['TGDBMIDebugger.RunToMain: An unknown breakpoint id was reported as failing: ', i]);
5052          if not ExecuteCommand('-break-delete %d', [i], [cfCheckError]) // wil set error state if it fails
5053          then break;
5054          inc(j);
5055        end;
5056        BrkErr := ParseBreakInsertError(s, i)
5057      end;
5058      // Break, if no breakpoint was removed
5059      if j = FTheDebugger.FMainAddrBreak.BreakSetCount
5060      then break;
5061    end;
5062
5063    if DebuggerState = dsError then
5064      exit;
5065
5066    if FDidKillNow then
5067      exit;
5068    if R.State = dsStop
5069    then begin
5070      debugln(DBG_WARNINGS, 'Debugger INIT failed. App has already run');
5071      SetDebuggerErrorState(Format(gdbmiCommandStartMainRunToStopError, [LineEnding]),
5072                            ErrorStateInfo);
5073      exit;
5074    end;
5075
5076    if not(R.State = dsRun)
5077    then begin
5078      SetDebuggerErrorState(Format(gdbmiCommandStartMainRunError, [LineEnding]),
5079                            ErrorStateInfo);
5080      exit;
5081    end;
5082
5083    FTheDebugger.FMainAddrBreak.Clear(Self);
5084
5085    SetDebuggerState(dsRun); // TODO: should not be needed here
5086
5087    // and we should ave hit a breakpoint
5088    //List := TGDBMINameValueList.Create(R.Values);
5089    //Reason := List.Values['reason'];
5090    //if Reason = 'breakpoint-hit'
5091
5092
5093    (* *** Find the PID *** *)
5094
5095    (* Try GDB output. Some of output after the -exec-run.
5096
5097       Mac GDB 6.3.5
5098         ~"[Switching to process 12345 local thread 0x0123]\n"
5099
5100       FreeBSD 9.0 GDB 6.1 (modified ?, supplied by FreeBSD)
5101       PID is not equal to LWP.
5102         [New LWP 100229]
5103         [New Thread 807407400 (LWP 100229/project1)]
5104         [Switching to Thread 807407400 (LWP 100229/project1)]
5105
5106       Somme linux, GDB 7.1
5107       Win GDB 7.0
5108         =thread-group-created,id="2125"
5109         =thread-created,id="1",group-id="2125"
5110         ~"[New Thread 9280.0x24e4]\n"                     // This line is Win only (or gdb 7.0?)
5111         ^running
5112         *running,thread-id="all"
5113         (gdb)
5114
5115
5116       Win GDB 7.4
5117       FreeBSD 9.0 GDB 7.3 (from ports)
5118         =thread-group-started,id="i1",pid="8876"
5119         =thread-created,id="1",group-id="i1"
5120         ~"[New Thread 8876.0x21c0]\n"                     // This line is Win only (or gdb 7.0?)
5121         ^running
5122         *running,thread-id="all"
5123         (gdb)
5124
5125       FreeBSD 9.0 GDB 7.3 (from ports) CONTINUED (LWP is not useable
5126         =thread-created,id="1",group-id="i1"
5127         ~"[New LWP 100073]\n"
5128         *running,thread-id="1"
5129         =thread-created,id="2",group-id="i1"
5130         ~"[New Thread 807407400 (LWP 100073)]\n"
5131         =thread-exited,id="1",group-id="i1"
5132         ~"[Switching to Thread 807407400 (LWP 100073)]\n"
5133
5134    *)
5135    if TargetInfo^.TargetPID <> 0 then
5136      exit;
5137
5138    TargetInfo^.TargetPID := ParseLogForPid(rval);
5139    if TargetInfo^.TargetPID <> 0 then
5140      exit;
5141
5142    DetectTargetPid; // will set dsError
5143  end;
5144
5145var
5146  R: TGDBMIExecResult;
5147  FileType, EntryPoint: String;
5148  List: TGDBMINameValueList;
5149  CanContinue: Boolean;
5150  StateStopped: Boolean;
5151begin
5152  Result := True;
5153  FSuccess := False;
5154  StateStopped := False;
5155
5156  try
5157    if not (DebuggerState in [dsStop])
5158    then begin
5159      Result := True;
5160      Exit;
5161    end;
5162
5163    if not DoChangeFilename then begin
5164      SetDebuggerErrorState(synfFailedToLoadApplicationExecutable, FErrorMsg);
5165      exit;
5166    end;
5167
5168    if not DoTargetDownload then begin
5169      SetDebuggerErrorState(synfFailedToDownloadApplicationExecutable, FErrorMsg);
5170      exit;
5171    end;
5172
5173    if not DoSetPascal then begin
5174      SetDebuggerErrorState(synfFailedToInitializeTheDebuggerSetPascalFailed,
5175        FLastExecResult.Values);
5176      exit;
5177    end;
5178
5179    DebugLn(['TGDBMIDebugger.StartDebugging WorkingDir="', FTheDebugger.WorkingDir,'"']);
5180    if FTheDebugger.WorkingDir <> ''
5181    then begin
5182      // to workaround a possible bug in gdb, first set the workingdir to .
5183      // otherwise on second run within the same gdb session the workingdir
5184      // is set to c:\windows
5185      ExecuteCommand('-environment-cd %s', ['.'], []);
5186      ExecuteCommand('-environment-cd %s', [FTheDebugger.ConvertToGDBPath(FTheDebugger.WorkingDir, cgptCurDir)], [cfCheckError]);
5187    end;
5188
5189    TargetInfo^.TargetFlags := [tfHasSymbols]; // Set until proven otherwise
5190
5191    // check if the exe is compiled with FPC >= 1.9.2
5192    // then the rtl is compiled with regcalls
5193    RetrieveRegCall;
5194
5195    // also call execute -exec-arguments if there are no arguments in this run
5196    // so the possible arguments of a previous run are cleared
5197    ExecuteCommand('-exec-arguments %s', [UTF8ToWinCP(FTheDebugger.Arguments)], [cfCheckState]);
5198
5199    {$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
5200    InitConsole;
5201    {$ENDIF}
5202
5203    DoSetDisableStartupShell();
5204    DoSetCaseSensitivity();
5205    DoSetMaxValueMemLimit();
5206    DoSetAssemblerStyle();
5207
5208    CheckAvailableTypes;
5209    CommonInit;
5210
5211    TargetInfo^.TargetCPU := '';
5212    TargetInfo^.TargetOS := osUnknown;
5213
5214    // try to retrieve the filetype and program entry point
5215    FileType := '';
5216    EntryPoint := '';
5217    if ExecuteCommand('info file', R)
5218    then begin
5219      if rfNoMI in R.Flags
5220      then begin
5221        FileType := GetPart('file type ', '.', R.Values);
5222        EntryPoint := GetPart(['Entry point: '], [#10, #13, '\t'], R.Values);
5223      end
5224      else begin
5225        // OS X gdb has mi output here
5226        List := TGDBMINameValueList.Create(R, ['section-info']);
5227        FileType := List.Values['filetype'];
5228        EntryPoint := List.Values['entry-point'];
5229        List.Free;
5230      end;
5231      DebugLn(DBG_VERBOSE, '[Debugger] File type: ', FileType);
5232      DebugLn(DBG_VERBOSE, '[Debugger] Entry point: ', EntryPoint);
5233    end;
5234    SetTargetInfo(FileType);
5235
5236    DefaultTimeOut := DebuggerProperties.TimeoutForEval;   // Getting address for breakpoints may need timeout
5237
5238    DetectForceableBreaks;
5239
5240    (* We need a breakpoint at entry-point or main, to continue initialization
5241       "main" could map to more than one location, so we try entry point first
5242    *)
5243    RunToMain(EntryPoint);
5244    DefaultTimeOut := DebuggerProperties.TimeoutForEval;   // Getting address for breakpoints may need timeout
5245
5246    if DebuggerState = dsStop
5247    then begin
5248      Result := False;
5249      FSuccess := False;
5250      Exit;
5251    end;
5252
5253    if DebuggerState = dsError
5254    then begin
5255      Result := False;
5256      FSuccess := False;
5257      Exit;
5258    end;
5259
5260    DebugLn(DBG_VERBOSE, '[Debugger] Target PID: %u', [TargetInfo^.TargetPID]);
5261
5262    Exclude(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
5263    Exclude(FTheDebugger.FDebuggerFlags, dfSetBreakPending);
5264    // they may still exist from prev run, addr will be checked
5265    // TODO: defered setting of below beakpoint / e.g. if debugging a library
5266{$IFdef WITH_GDB_FORCE_EXCEPTBREAK}
5267    FTheDebugger.FExceptionBreak.SetByAddr(Self, True);
5268    FTheDebugger.FBreakErrorBreak.SetByAddr(Self, True);
5269    FTheDebugger.FRunErrorBreak.SetByAddr(Self, True);
5270{$Else}
5271    FTheDebugger.FExceptionBreak.SetByAddr(Self);
5272    FTheDebugger.FBreakErrorBreak.SetByAddr(Self);
5273    FTheDebugger.FRunErrorBreak.SetByAddr(Self);
5274{$ENDIF}
5275    if (not (FTheDebugger.FExceptionBreak.IsBreakSet and
5276            FTheDebugger.FBreakErrorBreak.IsBreakSet and
5277            FTheDebugger.FRunErrorBreak.IsBreakSet)) and
5278       (DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwExceptionsAndRunError])
5279    then
5280      Include(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
5281
5282    SetDebuggerState(dsInit); // triggers all breakpoints to be set.
5283    FTheDebugger.RunQueue;  // run all the breakpoints
5284    Application.ProcessMessages; // workaround, allow source-editor to queue line info request (Async call)
5285
5286    if FTheDebugger.FBreakAtMain <> nil
5287    then begin
5288      CanContinue := False;
5289      TGDBMIBreakPoint(FTheDebugger.FBreakAtMain).Hit(CanContinue);
5290    end
5291    else CanContinue := True;
5292
5293    //if FTheDebugger.DebuggerFlags * [dfSetBreakFailed, dfSetBreakPending] <> [] then begin
5294    //  if FTheDebugger.OnFeedback
5295    //     (self, Format(synfTheDebuggerWasUnableToSetAllBreakpointsDuringIniti,
5296    //          [LineEnding]), '', ftWarning, [frOk, frStop]) = frStop
5297    //  then begin
5298    //    StateStopped := True;
5299    //    SetDebuggerState(dsStop);
5300    //    exit;
5301    //  end;
5302    //end;
5303
5304    if StoppedAtEntryPoint and CanContinue and (FContinueCommand = nil) then begin
5305      // try to step to pascal code
5306      if (FndOffsFile <> '') and (FndOffsLine <> '') and
5307         ( (FndOffsFile <> StoppedFile) or (FndOffsLine <> StoppedLine)  )
5308      then begin
5309        FTheDebugger.FMainAddrBreak.SetAtFileLine(Self, FndOffsFile, FndOffsLine);
5310        if (FTheDebugger.FMainAddrBreak.BreakAddr[iblFileLine] < MIN_RELOC_ADDRESS) or
5311           (FTheDebugger.FMainAddrBreak.BreakAddr[iblFileLine] = StoppedAddr)
5312        then
5313          FTheDebugger.FMainAddrBreak.Clear(Self, iblFileLine);
5314      end;
5315
5316      FTheDebugger.FMainAddrBreak.SetByName(Self);
5317      if (FTheDebugger.FMainAddrBreak.BreakAddr[iblNamed] < MIN_RELOC_ADDRESS) or
5318         (FTheDebugger.FMainAddrBreak.BreakAddr[iblNamed] = StoppedAddr) or
5319         (FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = '') or
5320         (FTheDebugger.FMainAddrBreak.BreakLine[iblNamed] = '') or
5321         ( (FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = StoppedFile) and
5322           (FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = StoppedLine) )
5323      then
5324        FTheDebugger.FMainAddrBreak.Clear(Self, iblNamed);
5325
5326      if FTheDebugger.FMainAddrBreak.IsBreakSet then begin
5327        FContinueCommand := TGDBMIDebuggerCommandExecute.Create(FTheDebugger, ectContinue);
5328      end;
5329    end;
5330
5331    if CanContinue and (FContinueCommand <> nil)
5332    then begin
5333      FTheDebugger.QueueCommand(FContinueCommand);
5334      FContinueCommand := nil;
5335    end
5336    else begin
5337      SetDebuggerState(dsPause);
5338    end;
5339
5340    if DebuggerState = dsPause
5341    then ProcessFrame;
5342  finally
5343    ReleaseRefAndNil(FContinueCommand);
5344    if not(StateStopped or (DebuggerState in [dsInit, dsRun, dsPause])) then
5345      SetDebuggerErrorState(synfFailedToInitializeDebugger);
5346  end;
5347
5348  FSuccess := True;
5349end;
5350
5351function TGDBMIDebuggerCommandStartDebugging.GdbRunCommand: String;
5352begin
5353  Result := '-exec-run';
5354end;
5355
5356function TGDBMIDebuggerCommandStartDebugging.DoTargetDownload: boolean;
5357begin
5358  result := true;
5359end;
5360
5361constructor TGDBMIDebuggerCommandStartDebugging.Create(AOwner: TGDBMIDebugger;
5362  AContinueCommand: TGDBMIDebuggerCommand);
5363begin
5364  inherited Create(AOwner);
5365  // AContinueCommand, takes over the current reference.
5366  // Caller will never Release it. So TGDBMIDebuggerCommandStartDebugging must do this
5367  FContinueCommand := AContinueCommand;
5368  FSuccess := False;
5369  FContext.ThreadContext := ccNotRequired;
5370  FContext.StackContext := ccNotRequired;
5371end;
5372
5373destructor TGDBMIDebuggerCommandStartDebugging.Destroy;
5374begin
5375  ReleaseRefAndNil(FContinueCommand);
5376  inherited Destroy;
5377end;
5378
5379function TGDBMIDebuggerCommandStartDebugging.DebugText: String;
5380var
5381  s: String;
5382begin
5383  s := '<none>';
5384  if FContinueCommand <> nil
5385  then s := FContinueCommand.DebugText;
5386  Result := Format('%s: ContinueCommand= %s', [ClassName, s]);
5387end;
5388
5389{ TGDBMIDebuggerCommandAttach }
5390
5391function TGDBMIDebuggerCommandAttach.DoExecute: Boolean;
5392var
5393  R: TGDBMIExecResult;
5394  StoppedParams, FileType, CmdResp, s: String;
5395  List: TGDBMINameValueList;
5396  NewPID: Integer;
5397begin
5398  Result := True;
5399  FSuccess := False;
5400
5401  if not ExecuteCommand('-file-exec-and-symbols %s',
5402                        [FTheDebugger.ConvertToGDBPath('', cgptExeName)], R)
5403  then
5404    R.State := dsError;
5405  if R.State = dsError then begin
5406    SetDebuggerErrorState('Attach failed');
5407    exit;
5408  end;
5409
5410  DefaultTimeOut := DebuggerProperties.TimeoutForEval;
5411
5412  // Tnit (StartDebugging)
5413  TargetInfo^.TargetFlags := [tfHasSymbols]; // Set until proven otherwise
5414  ExecuteCommand('-gdb-set language pascal', [cfCheckError]); // TODO: Maybe remove, must be done after attach
5415
5416  //{$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
5417  //InitConsole;
5418  //{$ENDIF}
5419
5420  SetDebuggerState(dsInit); // triggers all breakpoints to be set.
5421  Application.ProcessMessages; // workaround, allow source-editor to queue line info request (Async call)
5422
5423
5424  // Attach
5425  if not ExecuteCommand('attach %s', [FProcessID], R) then
5426    R.State := dsError;
5427  if R.State = dsError then begin
5428    ExecuteCommand('detach', [], R);
5429    SetDebuggerErrorState('Attach failed');
5430    exit;
5431  end;
5432  CmdResp := FFullCmdReply;
5433
5434  if (R.State <> dsNone)
5435  then SetDebuggerState(R.State);
5436
5437  if R.State = dsRun then begin
5438    ProcessRunning(StoppedParams, R);;
5439    if (R.State = dsError) then begin
5440      ExecuteCommand('detach', [], R);
5441      SetDebuggerErrorState('Attach failed');
5442      exit;
5443    end;
5444  end;
5445  CmdResp := CmdResp + StoppedParams + R.Values;
5446
5447  // Get PID
5448  NewPID := 0;
5449
5450  s := GetPart(['Attaching to process '], [LineEnding, '.'], CmdResp, True, False);
5451  if s <> '' then
5452    NewPID := StrToIntDef(s, 0);
5453
5454  if NewPID = 0 then begin
5455    s := GetPart(['=thread-group-started,'], [LineEnding], CmdResp, True, False);
5456    if s <> '' then
5457      s := GetPart(['pid="'], ['"'], s, True, False);
5458    if s <> '' then
5459      NewPID := StrToIntDef(s, 0);
5460  end;
5461
5462  if NewPID = 0 then begin
5463    NewPID := StrToIntDef(FProcessID, 0);
5464  end;
5465
5466  TargetInfo^.TargetPID := NewPID;
5467
5468  DetectTargetPid(True);
5469  if TargetInfo^.TargetPID = 0 then begin
5470    ExecuteCommand('detach', [], R);
5471    SetDebuggerErrorState(Format(gdbmiCommandStartMainRunNoPIDError, [LineEnding]));
5472    exit;
5473  end;
5474
5475  DoSetPascal;
5476  DoSetCaseSensitivity();
5477  DoSetMaxValueMemLimit();
5478  DoSetAssemblerStyle();
5479
5480  if (FTheDebugger.FileName <> '') and (pos('READING SYMBOLS FROM', UpperCase(CmdResp)) < 1) then begin
5481    ExecuteCommand('ptype TObject', [], R);
5482    if pos('NO SYMBOL TABLE IS LOADED', UpperCase(FFullCmdReply)) > 0 then begin
5483      ExecuteCommand('-file-exec-and-symbols %s',
5484                     [FTheDebugger.ConvertToGDBPath(FTheDebugger.FileName, cgptExeName)], R);
5485      DoSetPascal; // TODO: check with ALL versions of gdb, if that value needs to be refreshed or not.
5486      DoSetCaseSensitivity();
5487    end;
5488  end;
5489
5490
5491  // Tnit (StartDebugging)
5492  //   check if the exe is compiled with FPC >= 1.9.2
5493  //   then the rtl is compiled with regcalls
5494  RetrieveRegCall;
5495  CheckAvailableTypes;
5496  CommonInit;
5497  DetectForceableBreaks;
5498
5499  FileType := '';
5500  if ExecuteCommand('info file', R)
5501  then begin
5502    if rfNoMI in R.Flags
5503    then begin
5504      FileType := GetPart('file type ', '.', R.Values);
5505    end
5506    else begin
5507      // OS X gdb has mi output here
5508      List := TGDBMINameValueList.Create(R, ['section-info']);
5509      FileType := List.Values['filetype'];
5510      List.Free;
5511    end;
5512    DebugLn(DBG_VERBOSE, '[Debugger] File type: ', FileType);
5513  end;
5514  SetTargetInfo(FileType);
5515
5516  FTheDebugger.FExceptionBreak.SetByAddr(Self);
5517  FTheDebugger.FBreakErrorBreak.SetByAddr(Self);
5518  FTheDebugger.FRunErrorBreak.SetByAddr(Self);
5519
5520  if not(DebuggerState in [dsPause]) then
5521    SetDebuggerState(dsPause);
5522  ProcessFrame; // Includes DoLocation
5523  FSuccess := True;
5524end;
5525
5526constructor TGDBMIDebuggerCommandAttach.Create(AOwner: TGDBMIDebugger;
5527  AProcessID: String);
5528begin
5529  inherited Create(AOwner);
5530  FSuccess := False;
5531  FProcessID := AProcessID;
5532  FContext.ThreadContext := ccNotRequired;
5533  FContext.StackContext := ccNotRequired;
5534end;
5535
5536function TGDBMIDebuggerCommandAttach.DebugText: String;
5537begin
5538  Result := Format('%s: ProcessID= %s', [ClassName, FProcessID]);
5539end;
5540
5541{ TGDBMIDebuggerCommandDetach }
5542
5543function TGDBMIDebuggerCommandDetach.DoExecute: Boolean;
5544var
5545  R: TGDBMIExecResult;
5546begin
5547  Result := True;
5548  FContext.ThreadContext := ccNotRequired;
5549  FContext.StackContext := ccNotRequired;
5550
5551  if not ExecuteCommand('detach', R) then
5552    R.State := dsError;
5553  if R.State = dsError then begin
5554    SetDebuggerErrorState('Detach failed');
5555    exit;
5556  end;
5557
5558  SetDebuggerState(dsStop);
5559end;
5560
5561{ TGDBMIDebuggerCommandExecute }
5562
5563procedure TGDBMIDebuggerCommandExecute.DoLockQueueExecute;
5564begin
5565  // prevent lock
5566end;
5567
5568procedure TGDBMIDebuggerCommandExecute.DoUnLockQueueExecute;
5569begin
5570  // prevent lock
5571end;
5572
5573function TGDBMIDebuggerCommandExecute.ProcessStopped(const AParams: String;
5574  const AIgnoreSigIntState: Boolean): Boolean;
5575
5576  function GetLocation: TDBGLocationRec; // update current location
5577  var
5578    R: TGDBMIExecResult;
5579    S: String;
5580    FP: TDBGPtr;
5581    i, cnt: longint;
5582    Frame: TGDBMINameValueList;
5583  begin
5584    FTheDebugger.QueueExecuteLock;
5585    try
5586      Result.SrcLine := -1;
5587      Result.SrcFile := '';
5588      Result.FuncName := '';
5589      // Get the frame and addr info from the call-params
5590      if tfRTLUsesRegCall in TargetInfo^.TargetFlags
5591      then begin
5592        Result.Address := GetPtrValue(TargetInfo^.TargetRegisters[1], []);
5593        FP := GetPtrValue(TargetInfo^.TargetRegisters[2], []);
5594      end else begin
5595        Result.Address := GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 3]);
5596        FP := GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 4]);
5597      end;
5598
5599      if FP <> 0 then begin
5600        // try finding the stackframe
5601        cnt := GetStackDepth(33);  // do not search more than 32 deep, takes a lot of time
5602        i := FindStackFrame(Fp, 0, cnt);
5603        if i >= 0 then begin
5604          FTheDebugger.FCurrentStackFrame := i;
5605          DebugLn(DBG_THREAD_AND_FRAME, ['ProcessStopped GetLocation found fp Stack(Internal) = ', FTheDebugger.FCurrentStackFrame]);
5606        end;
5607
5608        if (FTheDebugger.FCurrentStackFrame > 3) and // must be 2 below fpc_assert, and that again must be below raise_except
5609           TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).FixStackFrameForFpcAssert then begin
5610          s := GetFrame(FTheDebugger.FCurrentStackFrame - 2);
5611          if s <> '' then begin
5612            Frame := TGDBMINameValueList.Create(S);
5613            if Frame.Values['func'] = 'fpc_assert' then
5614              FTheDebugger.FCurrentStackFrame := FTheDebugger.FCurrentStackFrame - 1;
5615            Frame.Free;
5616          end;
5617        end;
5618
5619        if FTheDebugger.FCurrentStackFrame <> 0
5620        then begin
5621          // This frame should have all the info we need
5622          s := GetFrame(FTheDebugger.FCurrentStackFrame);
5623          if s <> '' then
5624            FTheDebugger.FCurrentLocation := FrameToLocation(S);
5625          Result.SrcFile     := FTheDebugger.FCurrentLocation.SrcFile;
5626          Result.SrcFullName := FTheDebugger.FCurrentLocation.SrcFullName;
5627          Result.FuncName    := FTheDebugger.FCurrentLocation.FuncName;
5628          Result.SrcLine     := FTheDebugger.FCurrentLocation.SrcLine;
5629        end;
5630      end;
5631
5632      if (Result.SrcLine = -1) or (Result.SrcFile = '') then begin
5633        Str(Result.Address, S);
5634        if ExecuteCommand('info line *%s', [S], R)
5635        then begin
5636            Result.SrcLine := StrToIntDef(GetPart('Line ', ' of', R.Values), -1);
5637            Result.SrcFile := ConvertGdbPathAndFile(GetPart('\"', '\"', R.Values));
5638        end;
5639      end;
5640
5641      FTheDebugger.FCurrentLocation := Result;
5642    finally
5643      FTheDebugger.QueueExecuteUnlock;
5644    end;
5645  end;
5646
5647  function GetExceptionInfo: TGDBMIExceptionInfo;
5648  begin
5649    FTheDebugger.QueueExecuteLock;
5650    try
5651      if tfRTLUsesRegCall in TargetInfo^.TargetFlags
5652      then  Result.ObjAddr := TargetInfo^.TargetRegisters[0]
5653      else begin
5654        if dfImplicidTypes in FTheDebugger.DebuggerFlags
5655        then Result.ObjAddr := Format('^%s($fp+%d)^', [PointerTypeCast, TargetInfo^.TargetPtrSize * 2])
5656        else Str(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]), Result.ObjAddr);
5657      end;
5658      Result.Name := GetInstanceClassName(Result.ObjAddr, []);
5659      if Result.Name = ''
5660      then Result.Name := 'Unknown';
5661    finally
5662      FTheDebugger.QueueExecuteUnlock;
5663    end;
5664  end;
5665
5666  procedure ProcessException;
5667  var
5668    ExceptionMessage: String;
5669    CanContinue: Boolean;
5670    Location: TDBGLocationRec;
5671    ExceptInfo: TGDBMIExceptionInfo;
5672    ExceptItem: TBaseException;
5673  begin
5674    FTheDebugger.FStoppedReason := srRaiseExcept;
5675    if (FTheDebugger.Exceptions = nil) or FTheDebugger.Exceptions.IgnoreAll
5676    then begin
5677      Result := True; //ExecuteCommand('-exec-continue')
5678      exit;
5679    end;
5680
5681    ExceptInfo := GetExceptionInfo;
5682    // check if we should ignore this exception
5683    ExceptItem := FTheDebugger.Exceptions.Find(ExceptInfo.Name);
5684    if (ExceptItem <> nil) and (ExceptItem.Enabled)
5685    then begin
5686      Result := True; //ExecuteCommand('-exec-continue')
5687      exit;
5688    end;
5689
5690    FTheDebugger.QueueExecuteLock;
5691    try
5692      if (dfImplicidTypes in FTheDebugger.DebuggerFlags)
5693      then begin
5694        if (tfFlagHasTypeException in TargetInfo^.TargetFlags) then begin
5695          if tfExceptionIsPointer in TargetInfo^.TargetFlags
5696          then ExceptionMessage := GetText('Exception(%s).FMessage', [ExceptInfo.ObjAddr])
5697          else ExceptionMessage := GetText('^Exception(%s)^.FMessage', [ExceptInfo.ObjAddr]);
5698          if FLastExecResult.State = dsError then begin
5699            if tfExceptionIsPointer in TargetInfo^.TargetFlags then begin
5700              ExceptionMessage := GetText('^Exception(%s).FMessage', [ExceptInfo.ObjAddr]);
5701              if FLastExecResult.State <> dsError then
5702                Exclude(TargetInfo^.TargetFlags, tfExceptionIsPointer);
5703            end;
5704            if FLastExecResult.State = dsError then
5705              ExceptionMessage := GetText('^^char(^%s(%s)+1)^', [PointerTypeCast, ExceptInfo.ObjAddr]);
5706          end;
5707          //ExceptionMessage := GetText('^^Exception($fp+8)^^.FMessage', []);
5708        end else begin
5709          // Only works if Exception class is not changed. FMessage must be first member
5710          ExceptionMessage := GetText('^^char(^%s(%s)+1)^', [PointerTypeCast, ExceptInfo.ObjAddr]);
5711        end;
5712      end
5713      else ExceptionMessage := '### Not supported on GDB < 5.3 ###';
5714
5715      Location := GetLocation;
5716    finally
5717      FTheDebugger.QueueExecuteUnlock;
5718    end;
5719
5720    FTheDebugger.DoException(deInternal, ExceptInfo.Name, Location, ExceptionMessage, CanContinue);
5721    if CanContinue
5722    then begin
5723      //ExecuteCommand('-exec-continue')
5724      Result := True; // outer funciton result
5725      exit;
5726    end;
5727
5728    SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
5729    FTheDebugger.DoCurrent(Location);
5730  end;
5731
5732  procedure ProcessBreak;
5733  var
5734    ErrorNo: Integer;
5735    CanContinue: Boolean;
5736    Location: TDBGLocationRec;
5737    ExceptName: String;
5738    ExceptItem: TBaseException;
5739  begin
5740    FTheDebugger.QueueExecuteLock;
5741    try
5742      if tfRTLUsesRegCall in TargetInfo^.TargetFlags
5743      then ErrorNo := GetIntValue(TargetInfo^.TargetRegisters[0], [])
5744      else ErrorNo := Integer(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]));
5745      ErrorNo := ErrorNo and $FFFF;
5746
5747      Location := GetLocation;
5748    finally
5749      FTheDebugger.QueueExecuteUnlock;
5750    end;
5751
5752    ExceptName := Format('RunError(%d)', [ErrorNo]);
5753    ExceptItem := FTheDebugger.Exceptions.Find(ExceptName);
5754    if (ExceptItem <> nil) and (ExceptItem.Enabled)
5755    then begin
5756      Result := True; //ExecuteCommand('-exec-continue')
5757      exit;
5758    end;
5759
5760    FTheDebugger.DoException(deRunError, ExceptName, Location, '', CanContinue);
5761    if CanContinue
5762    then begin
5763      //ExecuteCommand('-exec-continue')
5764      Result := True; // outer funciton result
5765      exit;
5766    end;
5767
5768    SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
5769    FTheDebugger.DoCurrent(Location);
5770  end;
5771
5772  procedure ProcessRunError;
5773  var
5774    ErrorNo: Integer;
5775    CanContinue: Boolean;
5776    Location: TDBGLocationRec;
5777    ExceptName: String;
5778    ExceptItem: TBaseException;
5779  begin
5780    FTheDebugger.QueueExecuteLock;
5781    try
5782      if tfRTLUsesRegCall in TargetInfo^.TargetFlags
5783      then ErrorNo := GetIntValue(TargetInfo^.TargetRegisters[0], [])
5784      else ErrorNo := Integer(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]));
5785      ErrorNo := ErrorNo and $FFFF;
5786
5787      Location := GetLocation;
5788    finally
5789      FTheDebugger.QueueExecuteUnlock;
5790    end;
5791
5792    ExceptName := Format('RunError(%d)', [ErrorNo]);
5793    ExceptItem := FTheDebugger.Exceptions.Find(ExceptName);
5794    if (ExceptItem <> nil) and (ExceptItem.Enabled)
5795    then begin
5796      Result := True; //ExecuteCommand('-exec-continue')
5797      exit;
5798    end;
5799
5800    FTheDebugger.DoException(deRunError, ExceptName, Location, '', CanContinue);
5801    if CanContinue
5802    then begin
5803      //ExecuteCommand('-exec-continue')
5804      Result := True; // outer funciton result
5805      exit;
5806    end;
5807
5808    SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
5809    ProcessFrame(GetFrame(1));
5810  end;
5811
5812  procedure ProcessSignalReceived(const AList: TGDBMINameValueList);
5813  var
5814    SigInt, CanContinue: Boolean;
5815    S, F: String;
5816    {$IFdef MSWindows}
5817    fixed: Boolean;
5818    {$ENDIF}
5819  begin
5820    // TODO: check to run (un)handled
5821
5822    S := AList.Values['signal-name'];
5823    F := AList.Values['frame'];
5824    {$IFdef MSWindows}
5825    SigInt := S = 'SIGTRAP';
5826    if FTheDebugger.FAsyncModeEnabled then
5827      SigInt := SigInt or (S = 'SIGINT');
5828    {$ELSE}
5829    SigInt := S = 'SIGINT';
5830    {$ENDIF}
5831
5832    {$IFdef MSWindows}
5833    if SigInt and (FTheDebugger.PauseWaitState = pwsNone) and
5834       (pos('DbgUiConvertStateChangeStructure', FTheDebugger.FCurrentLocation.FuncName) > 0)
5835    then begin
5836      Result := True;
5837      exit;
5838    end;
5839    {$ENDIF}
5840
5841    if not AIgnoreSigIntState  // not pwsInternal
5842    or not SigInt
5843    then begin
5844      // user-requested pause OR other signal (not sigint)
5845      // TODO: if SigInt, check that it was issued by IDE
5846      {$IFdef MSWindows}
5847      FTheDebugger.QueueExecuteLock;
5848      try
5849        fixed := FixThreadForSigTrap;
5850      finally
5851        FTheDebugger.QueueExecuteUnlock;
5852      end;
5853      // Before anything else goes => correct the thread
5854      if fixed
5855      then F := '';
5856      {$ENDIF}
5857      SetDebuggerState(dsPause);
5858    end;
5859
5860    if not SigInt
5861    then FTheDebugger.DoException(deExternal, 'External: ' + S, FTheDebugger.FCurrentLocation, '', CanContinue);
5862
5863    FTheDebugger.QueueExecuteLock;
5864    try
5865      if not AIgnoreSigIntState
5866      or not SigInt
5867      then ProcessFrame(F);
5868    finally
5869      FTheDebugger.QueueExecuteUnlock;
5870    end;
5871  end;
5872
5873  procedure CheckIncorrectStepOver;
5874    function GetCurrentFp: TDBGPtr; // TODO: this is a copy and paste from Run command
5875    var
5876      OldCtx: TGDBMICommandContext;
5877    begin
5878      OldCtx := FContext;
5879      FContext.ThreadContext := ccUseLocal;
5880      FContext.StackContext := ccUseLocal;
5881      FContext.StackFrame := 0;
5882      FContext.ThreadId := FTheDebugger.FCurrentThreadId;
5883      Result := GetPtrValue('$fp', []);
5884      FContext := OldCtx;
5885    end;
5886
5887  begin
5888    if not TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).FixIncorrectStepOver then
5889      exit;
5890    if not (FExecType = ectStepOver) then
5891      exit;
5892
5893    if FStepOverFixNeeded = sofStepAgain then begin
5894      FStepOverFixNeeded := sofStepOut;
5895      Result := True;
5896      exit;
5897    end;
5898
5899    if (FInitialFP = 0) or (GetCurrentFp >= FInitialFP) then
5900      exit;
5901
5902    DebugLn(DBG_VERBOSE, '*** FIXING gdb step over did step in');
5903    Result := True; // outer funciton result
5904
5905    FStepOverFixNeeded := sofStepAgain;
5906  end;
5907
5908  procedure ProcessBreakPoint(ABreakId: Integer; const List: TGDBMINameValueList;
5909    AReason: TGDBMIBreakpointReason; AOldVal: String = ''; ANewVal: String = '');
5910  var
5911    BreakPoint: TGDBMIBreakPoint;
5912    CanContinue: Boolean;
5913    Location: TDBGLocationRec;
5914    BrkSlave: TBaseBreakPoint;
5915  begin
5916    BreakPoint := nil;
5917    if ABreakId >= 0 then
5918      BreakPoint := TGDBMIBreakPoint(FTheDebugger.FindBreakpoint(ABreakID));
5919
5920    if (BreakPoint <> nil) and (BreakPoint.Valid = vsPending) then
5921      BreakPoint.SetPendingToValid(vsValid);
5922    if (BreakPoint <> nil) and (BreakPoint.Kind <> bpkData) and
5923       (AReason in [gbrWatchScope, gbrWatchTrigger])
5924    then BreakPoint := nil;
5925
5926    if BreakPoint <> nil
5927    then begin
5928      try
5929        (* - Breakpoint may not be destroyed, while in use
5930           - And it may not be destroyed, before state is set (otherwhise an InterruptTarget is triggered)
5931        *)
5932        BreakPoint.AddReference;
5933        BrkSlave := BreakPoint.Slave;
5934        if BrkSlave <> nil then BrkSlave.AddReference;
5935
5936        CanContinue := False;
5937        FTheDebugger.QueueExecuteLock;
5938        try
5939          Location := FrameToLocation(List.Values['frame']);
5940          FTheDebugger.FCurrentLocation := Location;
5941        finally
5942          FTheDebugger.QueueExecuteUnlock;
5943        end;
5944        FTheDebugger.DoDbgBreakpointEvent(BreakPoint, Location, AReason, AOldVal, ANewVal);
5945        // Important: The Queue must be unlocked
5946        //   BreakPoint.Hit may evaluate stack and expressions
5947        //   SetDebuggerState may evaluate data for Snapshot
5948        BreakPoint.Hit(CanContinue);
5949        if CanContinue
5950        then begin
5951          // Important trigger State => as snapshot is taken in TDebugManager.DebuggerChangeState
5952          SetDebuggerState(dsInternalPause);
5953          Result := True;
5954        end
5955        else begin
5956          SetDebuggerState(dsPause);
5957          ProcessFrame(Location);
5958          // inform the user, why we stopped
5959          // TODO: Add a dedicated callback
5960          case AReason of
5961            gbrWatchTrigger: FTheDebugger.OnFeedback
5962               (self, Format('The Watchpoint for "%1:s" was triggered.%0:s%0:sOld value: %2:s%0:sNew value: %3:s',
5963                             [LineEnding, BreakPoint.WatchData, AOldVal, ANewVal]),
5964                '', ftInformation, [frOk]);
5965            gbrWatchScope: FTheDebugger.OnFeedback
5966               (self, Format('The Watchpoint for "%s" went out of scope', [BreakPoint.WatchData]),
5967                '', ftInformation, [frOk]);
5968          end;
5969        end;
5970
5971        if AReason = gbrWatchScope
5972        then begin
5973          BreakPoint.ReleaseBreakPoint; // gdb should have released already => ignore error
5974          BreakPoint.Enabled := False;
5975          BreakPoint.FBreakID := 0; // removed by debugger, ID no longer exists
5976        end;
5977
5978      finally
5979        if BrkSlave <> nil then BrkSlave.ReleaseReference;
5980        BreakPoint.ReleaseReference;
5981      end;
5982      exit;
5983    end;
5984
5985    if (DebuggerState = dsRun)
5986    then begin
5987      debugln(['********** WARNING: breakpoint hit, but nothing known about it ABreakId=', ABreakID, ' brbtno=', List.Values['bkptno'] ]);
5988      {$IFDEF DBG_VERBOSE_BRKPOINT}
5989      debugln(['-*- List of breakpoints Cnt=', FTheDebugger.Breakpoints.Count]);
5990      for ABreakID := 0 to FTheDebugger.Breakpoints.Count - 1 do
5991        debugln(['* ',Dbgs(FTheDebugger.Breakpoints[ABreakID]), ':', DbgsName(FTheDebugger.Breakpoints[ABreakID]), ' ABreakId=',TGDBMIBreakPoint(FTheDebugger.Breakpoints[ABreakID]).FBreakID, ' Source=', FTheDebugger.Breakpoints[ABreakID].Source, ' Line=', FTheDebugger.Breakpoints[ABreakID].Line ]);
5992      debugln(['************************************************************************ ']);
5993      debugln(['************************************************************************ ']);
5994      debugln(['************************************************************************ ']);
5995      {$ENDIF}
5996
5997      case FTheDebugger.OnFeedback
5998             (self, Format(gdbmiWarningUnknowBreakPoint,
5999                           [LineEnding, GDBMIBreakPointReasonNames[AReason]]),
6000              List.Text, ftWarning, [frOk, frStop]
6001             )
6002      of
6003        frOk: begin
6004            SetDebuggerState(dsPause);
6005            ProcessFrame(List.Values['frame']); // and jump to it
6006          end;
6007        frStop: begin
6008            FTheDebugger.Stop;
6009          end;
6010      end;
6011
6012    end;
6013  end;
6014
6015var
6016  List, List2: TGDBMINameValueList;
6017  Reason: String;
6018  BreakID: Integer;
6019  CanContinue: Boolean;
6020  i: Integer;
6021  s: String;
6022begin
6023  (* The Queue is not locked / This code can be interupted
6024     Therefore all calls to ExecuteCommand (gdb cmd) must be wrapped in QueueExecuteLock
6025  *)
6026  Result := False;
6027  FTheDebugger.FInProcessStopped := True;  // paused, but maybe state run
6028  FTheDebugger.FStoppedReason := srNone;
6029
6030  List := TGDBMINameValueList.Create(AParams);
6031  List2 := nil;
6032
6033  FTheDebugger.FCurrentStackFrame :=  0;
6034  FTheDebugger.FCurrentThreadId := StrToIntDef(List.Values['thread-id'], -1);
6035  FTheDebugger.FCurrentThreadIdValid := True;
6036  FTheDebugger.FCurrentStackFrameValid := True;
6037  FTheDebugger.FInstructionQueue.SetKnownThreadAndFrame(FTheDebugger.FCurrentThreadId, 0);
6038  FContext.ThreadContext := ccUseGlobal;
6039  FContext.StackContext := ccUseGlobal;
6040
6041  FTheDebugger.FCurrentLocation.Address := 0;
6042  FTheDebugger.FCurrentLocation.SrcFile := '';
6043  FTheDebugger.FCurrentLocation.SrcFullName := '';
6044
6045
6046
6047  try
6048    Reason := List.Values['reason'];
6049    if (Reason = 'exited-normally')
6050    then begin
6051      DoDbgEvent(ecProcess, etProcessExit, gdbmiEventLogProcessExitNormally);
6052      SetDebuggerState(dsStop);
6053      Exit;
6054    end;
6055
6056    if Reason = 'exited'
6057    then begin
6058      FTheDebugger.SetExitCode(StrToIntDef(List.Values['exit-code'], 0));
6059      DoDbgEvent(ecProcess, etProcessExit, Format(gdbmiEventLogProcessExitCode, [List.Values['exi'
6060        +'t-code']]));
6061      SetDebuggerState(dsStop);
6062      Exit;
6063    end;
6064
6065    if Reason = 'exited-signalled'
6066    then begin
6067      SetDebuggerState(dsStop);
6068      FTheDebugger.DoException(deExternal, 'External: ' + List.Values['signal-name'], FTheDebugger.FCurrentLocation, '', CanContinue);
6069      // ProcessFrame(List.Values['frame']);
6070      Exit;
6071    end;
6072
6073    // not stopped? Then we should have a location
6074    FTheDebugger.FCurrentLocation := FrameToLocation(List.Values['frame']);
6075
6076    if Reason = 'signal-received'
6077    then begin
6078      ProcessSignalReceived(List);
6079      Exit;
6080    end;
6081
6082    if (Reason = 'watchpoint-trigger') or (Reason = 'access-watchpoint-trigger') or
6083       (Reason = 'read-watchpoint-trigger')
6084    then begin
6085      i := 0;
6086      List2 := nil;
6087      while i < List.Count do begin
6088        s := PCLenToString(List.Items[i]^.Name);
6089        if copy(s, Length(s) - 2, 3) = 'wpt' then
6090          List2 := TGDBMINameValueList.Create(List.Values[s]);
6091        inc(i);
6092      end;
6093      if List2 <> nil then begin
6094        BreakID := StrToIntDef(List2.Values['number'], -1);
6095        // Use List2.Values['exp'] ? It may contain globalized expression
6096        List2.Init(List.Values['value']);
6097        ProcessBreakPoint(BreakID, List, gbrWatchTrigger, List2.Values['old'], List2.Values['new']);
6098        exit;
6099      end;
6100    end;
6101
6102    if Reason = 'watchpoint-scope'
6103    then begin
6104      BreakID := StrToIntDef(List.Values['wpnum'], -1);
6105      ProcessBreakPoint(BreakID, List, gbrWatchScope);
6106      exit;
6107    end;
6108
6109    if Reason = 'breakpoint-hit'
6110    then begin
6111      BreakID := StrToIntDef(List.Values['bkptno'], -1);
6112      if BreakID = -1
6113      then begin
6114        ProcessBreakPoint(BreakID, List, gbrBreak);
6115        SetDebuggerState(dsError);
6116        Exit;
6117      end;
6118
6119      if FTheDebugger.FBreakErrorBreak.MatchId(BreakID)
6120      then begin
6121        ProcessBreak; // will set dsPause / unless CanContinue
6122        Exit;
6123      end;
6124
6125      if FTheDebugger.FRunErrorBreak.MatchId(BreakID)
6126      then begin
6127        ProcessRunError; // will set dsPause / unless CanCuntinue
6128        Exit;
6129      end;
6130
6131      if FTheDebugger.FExceptionBreak.MatchId(BreakID)
6132      then begin
6133        ProcessException; // will set dsPause / unless CanCuntinue
6134        Exit;
6135      end;
6136
6137      if FTheDebugger.FPopExceptStack.MatchId(BreakID)
6138      then begin
6139        FTheDebugger.FStoppedReason := srPopExceptStack;
6140        Result := True;
6141        Exit;
6142      end;
6143
6144      if FTheDebugger.FCatchesBreak.MatchId(BreakID)
6145      then begin
6146        FTheDebugger.FStoppedReason := srCatches;
6147        Result := True;
6148        Exit;
6149      end;
6150
6151      if FTheDebugger.FReRaiseBreak.MatchId(BreakID)
6152      then begin
6153        FTheDebugger.FStoppedReason := srReRaiseExcept;
6154        Result := True;
6155        Exit;
6156      end;
6157
6158      {$ifdef WIN64}
6159      if FTheDebugger.FRtlUnwindExBreak.MatchId(BreakID)
6160      then begin
6161        FTheDebugger.FStoppedReason := srRtlUnwind;
6162        Result := True;
6163        Exit;
6164      end;
6165
6166      if FTheDebugger.FSehRaiseBreaks.HasBreakId(BreakID)
6167      then begin
6168        FTheDebugger.FStoppedReason := srSehCatches;
6169        FTheDebugger.FSehRaiseBreaks.RemoveId(Self, BreakID);
6170        Result := True;
6171        Exit;
6172      end;
6173      {$endif}
6174
6175      if FTheDebugger.FMainAddrBreak.MatchId(BreakID)
6176      then begin
6177        FTheDebugger.FMainAddrBreak.Clear(Self); // done with launch
6178        SetDebuggerState(dsPause);
6179        ProcessFrame(FTheDebugger.FCurrentLocation );
6180        Exit;
6181      end;
6182
6183      if (FStepBreakPoint > 0) and (BreakID = FStepBreakPoint)
6184      then begin
6185        SetDebuggerState(dsPause);
6186        ProcessFrame(FTheDebugger.FCurrentLocation );
6187        exit;
6188      end;
6189
6190      ProcessBreakPoint(BreakID, List, gbrBreak);
6191      exit;
6192    end;
6193
6194    if Reason = 'function-finished'
6195    then begin
6196      SetDebuggerState(dsPause);
6197      ProcessFrame(List.Values['frame'], False);
6198      Exit;
6199    end;
6200
6201    if Reason = 'end-stepping-range'
6202    then begin
6203      CheckIncorrectStepOver;
6204      if not Result then begin
6205        SetDebuggerState(dsPause);
6206        ProcessFrame(List.Values['frame'], False);
6207      end;
6208      Exit;
6209    end;
6210
6211    if Reason = 'location-reached'
6212    then begin
6213      SetDebuggerState(dsPause);
6214      ProcessFrame(List.Values['frame'], False);
6215      Exit;
6216    end;
6217
6218    DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown stopped reason: ', Reason);
6219    SetDebuggerState(dsPause);
6220    ProcessFrame(List.Values['frame']);
6221  finally
6222    FTheDebugger.FInProcessStopped := False;
6223    List.Free;
6224    list2.Free;
6225  end;
6226end;
6227
6228{$IFDEF MSWindows}
6229function TGDBMIDebuggerCommandExecute.FixThreadForSigTrap: Boolean;
6230var
6231  R: TGDBMIExecResult;
6232  List: TGDBMINameValueList;
6233  s: string;
6234  n, ID1, ID2: Integer;
6235begin
6236  Result := False;
6237  if not ExecuteCommand('info program', R, [cfNoThreadContext])
6238  then exit;
6239  S := GetPart(['.0x'], ['.'], R.Values, True, False); // From the line "using child thread"
6240  if PtrInt(StrToQWordDef('$'+S, 0)) <> FTheDebugger.FPauseRequestInThreadID
6241  then Exit;
6242
6243
6244  if not ExecuteCommand('-thread-list-ids', R, [cfNoThreadContext])
6245  then Exit;
6246  List := TGDBMINameValueList.Create(R);
6247  try
6248    n := StrToIntDef(List.Values['number-of-threads'], 0);
6249    if n < 2 then Exit; //nothing to switch
6250    List.SetPath(['thread-ids']);
6251    if List.Count < 2 then Exit; // ???
6252    ID1 := StrToIntDef(List.Values['thread-id'], 0);
6253    List.Delete(0);
6254    ID2 := StrToIntDef(List.Values['thread-id'], 0);
6255
6256    if ID1 = ID2 then Exit;
6257  finally
6258    List.Free;
6259  end;
6260
6261  Result := True;
6262  FTheDebugger.FCurrentThreadId := ID2;
6263  FTheDebugger.FCurrentThreadIdValid := True;
6264  DebugLn(DBG_THREAD_AND_FRAME, ['FixThreadForSigTrap Thread(Internal) = ', FTheDebugger.FCurrentThreadId]);
6265end;
6266{$ENDIF}
6267
6268function TGDBMIDebuggerCommandExecute.DoExecute: Boolean;
6269var
6270  RunMode: (rmNormal, rmStepToFinally);
6271const
6272  BreaKErrMsg = 'not insert breakpoint ';
6273  WatchErrMsg = 'not insert hardware watchpoint ';
6274
6275  function HandleBreakPointError(var ARes: TGDBMIExecResult; AError: String): Boolean;
6276  var
6277    c, i: Integer;
6278    bp: Array of Integer;
6279    s, s2: string;
6280    b: TGDBMIBreakPoint;
6281  begin
6282    Result := False;
6283    s := AError;
6284    c := 0;
6285    while ParseBreakInsertError(s, i) do begin
6286      if FTheDebugger.FMainAddrBreak.ClearId(Self, i) then begin
6287        Result := True;
6288        ARes.State := dsRun;
6289        continue;
6290      end;
6291      SetLength(bp, c+1);
6292      bp[c] := i;
6293      if bp[c] >= 0 then inc(c);
6294    end;
6295
6296    if Result and not FTheDebugger.FMainAddrBreak.IsBreakSet then
6297      ARes.State := dsPause; // no break left
6298
6299    if c = 0 then exit;
6300
6301    Result := True;
6302
6303    if ARes.State = dsError
6304    then begin
6305      s := ARes.Values;
6306      if FLogWarnings <> ''
6307      then s2 := Format(gdbmiErrorOnRunCommandWithWarning, [LineEnding, FLogWarnings])
6308      else s2 := '';
6309      FLogWarnings := '';
6310    end else begin
6311      s := AError;
6312      s2 := '';
6313    end;
6314
6315    case FTheDebugger.OnFeedback(self,
6316                                 Format(gdbmiBreakPointErrorOnRunCommand, [LineEnding, s]) + s2,
6317                                 ARes.Values, ftError, [frOk, frStop]
6318         ) of
6319      frOk: begin
6320          ARes.State := dsPause;
6321          ProcessFrame;
6322          FTheDebugger.FInProcessStopped := True;  // paused, but maybe state run
6323          try
6324            for i := 0 to length(bp)-1 do begin
6325              b := TGDBMIBreakPoints(FTheDebugger.BreakPoints).FindById(bp[i]);
6326              if b <> nil
6327              then begin
6328                if b.Kind = bpkData
6329                then b.Enabled := False
6330                else b.MakeInvalid;
6331              end
6332              else ExecuteCommand('-break-delete %d', [bp[i]], [cfNoThreadContext]);
6333            end;
6334          finally
6335          FTheDebugger.FInProcessStopped := False;  // paused, but maybe state run
6336          end;
6337        end;
6338      frStop: begin
6339          FTheDebugger.Stop;
6340          ARes.State := dsStop;
6341        end;
6342    end;
6343
6344  end;
6345
6346  function HandleRunError(var ARes: TGDBMIExecResult): Boolean;
6347  var
6348    s, s2: String;
6349    List: TGDBMINameValueList;
6350  begin
6351    Result := False; // keep the error state
6352    // check known errors
6353    if (Pos('program is not being run', ARes.Values) > 0) then begin  // Should lead to dsStop
6354      SetDebuggerState(dsError);
6355      exit;
6356    end;
6357    if (Pos(BreaKErrMsg, ARes.Values) > 0) or
6358       (Pos(BreaKErrMsg, FLogWarnings) > 0) or
6359       (Pos(WatchErrMsg, ARes.Values) > 0) or
6360       (Pos(WatchErrMsg, FLogWarnings) > 0)
6361    then begin
6362      Result := HandleBreakPointError(ARes, ARes.Values + FLogWarnings);
6363      if Result then exit;
6364    end;
6365
6366    if assigned(FTheDebugger.OnFeedback) then begin
6367      List := TGDBMINameValueList.Create(ARes);
6368      s := List.Values['msg'];
6369      FreeAndNil(List);
6370      if FLogWarnings <> ''
6371      then s2 := Format(gdbmiErrorOnRunCommandWithWarning, [LineEnding, FLogWarnings])
6372      else s2 := '';
6373      FLogWarnings := '';
6374      if s <> '' then begin
6375        case FTheDebugger.OnFeedback(self,
6376                                     Format(gdbmiErrorOnRunCommand, [LineEnding, s]) + s2,
6377                                     ARes.Values, ftError, [frOk, frStop]
6378             ) of
6379          frOk: begin
6380              ARes.State := dsPause;
6381              ProcessFrame;
6382              Result := True;
6383            end;
6384          frStop: begin
6385              FTheDebugger.Stop;
6386              ARes.State := dsStop;
6387              Result := True;
6388              exit;
6389            end;
6390        end;
6391      end
6392    end;
6393  end;
6394
6395  function CheckResultForError(var ARes: TGDBMIExecResult): Boolean;
6396  begin
6397    Result := False;
6398    if (ARes.State = dsError) and (not HandleRunError(ARes)) then begin
6399      DoDbgEvent(ecDebugger, etDefault, Format(gdbmiFatalErrorOccurred, [ARes.Values]));
6400      SetDebuggerState(dsError);
6401      Result := True;
6402    end;
6403  end;
6404
6405  function FindStackWithSymbols(StartAt,
6406    MaxDepth: Integer): Integer;
6407  var
6408    R: TGDBMIExecResult;
6409    List: TGDBMINameValueList;
6410  begin
6411    // Result;
6412    // -1 : Not found
6413    // -2 : FP is outside stack
6414    Result := StartAt;
6415    List := TGDBMINameValueList.Create('');
6416    try
6417      repeat
6418        if not ExecuteCommand('-stack-list-frames %d %d', [Result, Result], R, [cfNoStackContext])
6419        or (R.State = dsError)
6420        then begin
6421          Result := -1;
6422          break;
6423        end;
6424
6425        List.Init(R.Values);
6426        List.SetPath('stack');
6427        if List.Count > 0 then List.Init(List.GetString(0));
6428        List.SetPath('frame');
6429        if List.Values['file'] <> ''
6430        then exit;
6431
6432        inc(Result);
6433      until Result > MaxDepth;
6434
6435      Result := -1;
6436    finally
6437      List.Free;
6438    end;
6439  end;
6440
6441  procedure EnablePopCatches; inline;
6442  begin
6443    FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
6444    FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
6445  end;
6446  {$ifdef WIN64}
6447  procedure EnableRtlUnwind; inline;
6448  begin
6449    if TargetInfo^.TargetOS = osWindows then
6450      FTheDebugger.FRtlUnwindExBreak.EnableOrSetByAddr(Self);
6451  end;
6452  {$endif}
6453  procedure DisablePopCatches; inline;
6454  begin
6455    FTheDebugger.FPopExceptStack.Disable(Self);
6456    FTheDebugger.FCatchesBreak.Disable(Self);
6457  end;
6458
6459var
6460  FP: TDBGPtr;
6461  CurThreadId: Integer;
6462
6463  function DoContinueStepping: Boolean;
6464    procedure DoEndStepping;
6465    begin
6466      Result := True;
6467      FCurrentExecCmd := ectNone;
6468      FCurrentExecArg := '';
6469      SetDebuggerState(dsPause);
6470      FTheDebugger.DoCurrent(FTheDebugger.FCurrentLocation);
6471    end;
6472  const
6473    MaxStackDepth = 99;
6474  var
6475    cnt, i: Integer;
6476    R: TGDBMIExecResult;
6477    {$ifdef WIN64}Address: TDBGPtr;{$endif}
6478  begin
6479    // TODO: an exception can skip the step-end breakpoint....
6480    // TODO: the "break" breakpoint can stop on the current, instead of the next instruction
6481
6482    Result := False;
6483
6484    {$ifdef WIN64}
6485    // RtlUnwind, set a breakpoint at next except handler (instead of srPopExceptStack/srCatches)
6486    if FTheDebugger.FStoppedReason = srRtlUnwind then begin
6487      Address := GetPtrValue(TargetInfo^.TargetRegisters[1], []);
6488      if Address <> 0 then
6489        FTheDebugger.FSehRaiseBreaks.AddAddr(Self, Address);
6490      FCurrentExecCmd := ectContinue;
6491      Result := True;
6492
6493      // because we can get more exceptions in finally blocks
6494      // TODO: remove if finally blocks are entered
6495      if RunMode = rmStepToFinally then
6496        FTheDebugger.FRtlUnwindExBreak.Disable(Self);
6497      exit;
6498    end;
6499    {$endif}
6500
6501    {$ifdef WIN64}
6502    // F7 or F8 was used in raise exception, stop at next finally or except handler
6503    //   ecContinue has stopped
6504    if RunMode = rmStepToFinally then begin
6505      if FTheDebugger.FStoppedReason in [srRaiseExcept, srReRaiseExcept] then begin
6506        // should not happen, but with SEH it can happen in finally blocks => continue to except handler
6507        FCurrentExecCmd := ectContinue;
6508        Result := True;
6509        exit;
6510      end;
6511      // SEH
6512      if FTheDebugger.FStoppedReason = srSehCatches then begin
6513        DoEndStepping;
6514        exit;
6515      end;
6516      // NONE SEH (if SEH falls through, it will pause as it is not an Pop/Catches)
6517      // if NOT at srPopExceptStack/srCatches then ecStepOut should have finished => dsPause
6518      Result := FTheDebugger.FStoppedReason in [srPopExceptStack, srCatches];
6519      if Result then
6520        FCurrentExecCmd := ectStepOut;
6521      exit;
6522    end;
6523    {$else}
6524    if RunMode = rmStepToFinally then begin
6525      Result := FTheDebugger.FStoppedReason in [srPopExceptStack, srCatches];
6526      if Result then
6527        FCurrentExecCmd := ectStepOut;
6528      exit;
6529    end;
6530
6531    if FTheDebugger.FStoppedReason = srReRaiseExcept then begin
6532      FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
6533      FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
6534      FCurrentExecCmd := ectContinue;
6535      Result := True;
6536      exit;
6537    end;
6538    if FTheDebugger.FStoppedReason in [srPopExceptStack, srCatches] then begin
6539      FTheDebugger.FPopExceptStack.Disable(Self);
6540      FTheDebugger.FCatchesBreak.Disable(Self);
6541      i := FindStackFrame(Fp, 0, 1);
6542      if (i in [0, 1]) or (i = -2)  // -2 already stepped out of the desired frame, enter dsPause
6543      then begin
6544        FCurrentExecCmd := ectStepOut; // ecStepOut will not offer a change to ContinueStepping
6545        Result := True;
6546        exit;
6547      end;
6548    end;
6549    {$endif}
6550
6551    {$ifdef WIN64}
6552    case FTheDebugger.FStoppedReason of
6553      // reraise is only enabled while stepping, so no need to check
6554      srReRaiseExcept: begin
6555          EnablePopCatches;
6556          EnableRtlUnwind;
6557          FCurrentExecCmd := ectContinue;
6558          Result := True;
6559          exit;
6560        end;
6561      srRaiseExcept:
6562        if (FExecType in [ectStepOver, ectStepOverInstruction, ectStepOut, ectStepInto])  // ectRunTo
6563        then begin
6564          EnablePopCatches;
6565          EnableRtlUnwind;
6566        end;
6567      // Check the stackframe, if the "current" function has been exited
6568      srSehCatches: begin
6569          i := FindStackFrame(Fp, 0, 1); // -2 already stepped out of the desired frame, enter dsPause
6570          if (i = 0) or (i = -2) then begin
6571            DoEndStepping;
6572            exit;
6573          end;
6574        end;
6575      // Check the stackframe, if the "current" function has been exited
6576      srPopExceptStack, srCatches: begin
6577          DisablePopCatches;
6578          i := FindStackFrame(Fp, 0, 1); // -2 already stepped out of the desired frame, enter dsPause
6579          if (i in [0, 1]) or (i = -2) then begin
6580            FCurrentExecCmd := ectStepOut; // ecStepOut will not offer a chance to ContinueStepping (there should be no breakpoint that can be hit before)
6581            Result := True;
6582            exit;
6583          end;
6584        end;
6585    end;
6586    {$endif}
6587
6588    case FExecType of
6589      ectContinue, ectRun:
6590        begin
6591          FCurrentExecCmd := ectContinue;
6592          FCurrentExecArg := '';
6593          Result := True;
6594        end;
6595      ectRunTo:  // check if we are at correct location
6596        begin
6597          // TODO: check, if the current function was left
6598          Result := not(
6599              ( (FTheDebugger.FCurrentLocation.SrcFile = FRunToSrc) or
6600                (FTheDebugger.FCurrentLocation.SrcFullName = FRunToSrc) ) and
6601              (FTheDebugger.FCurrentLocation.SrcLine = FRunToLine)
6602            );
6603          if not Result
6604          then DoEndStepping;  // location reached
6605          // Otherwise issue same "run-to" command again
6606        end;
6607      ectStepOver, ectStepOverInstruction, ectStepOut, ectStepInto:
6608        begin
6609          {$ifNdef WIN64}
6610          FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
6611          FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
6612          {$endif}
6613          Result := FStepBreakPoint > 0;
6614          if Result then
6615            exit;
6616          case FStepOverFixNeeded of
6617            sofStepAgain: begin
6618              FCurrentExecCmd := ectStepOver;
6619              Result := True;
6620              exit;
6621            end;
6622            sofStepOut: begin
6623              FCurrentExecCmd := ectStepOut;
6624              FStepOverFixNeeded := sofNotNeeded;
6625              Result := True;
6626              exit;
6627            end;
6628          end;
6629
6630          i := -1;
6631          if FP <> 0 then begin
6632            cnt := GetStackDepth(MaxStackDepth);
6633            if FExecType = ectStepInto
6634            then i := FindStackWithSymbols(0, cnt)  // TODO: HasSymbols(FindStackFrame(...)-1)  ???
6635            else i := FindStackFrame(Fp, 0, cnt);
6636            if (FExecType = ectStepOut) and (i >= 0)
6637            then inc(i);
6638          end;
6639
6640          if (i = 0) or (i = -2)  // -2 already stepped out of the desired frame, enter dsPause
6641          then begin
6642            DoEndStepping;
6643            exit;
6644          end;
6645
6646          if i > 0
6647          then begin
6648// TODO: move to queue
6649            // must use none gdbmi commands
6650            FContext.ThreadContext := ccUseGlobal;
6651            FTheDebugger.QueueExecuteLock; // force queue
6652            try
6653              // This messes up the Stack context of the queue.
6654              FTheDebugger.FInstructionQueue.InvalidateThredAndFrame;
6655              if (not ExecuteCommand('frame %d', [i], R, [cfNoStackContext])) or (R.State = dsError)
6656              then i := -3; // error to user
6657              if (i < 0) or (not ExecuteCommand('break', [i], R, [cfNoStackContext])) or (R.State = dsError)
6658              then i := -3; // error to user
6659            finally
6660              FTheDebugger.QueueExecuteUnlock;
6661            end;
6662
6663            FStepBreakPoint := StrToIntDef(GetPart(['Breakpoint '], [' at '], R.Values), -1);
6664            if FStepBreakPoint < 0
6665            then i := -3;
6666
6667            if i > 0 then begin
6668              Result := True;
6669              FCurrentExecCmd := ectContinue;
6670              FCurrentExecArg := '';
6671            end;
6672          end;
6673          if i < 0
6674          then begin
6675            DebugLn(['CommandExecute: exStepOver, frame not found: ', i]);
6676            DoEndStepping; // TODO: User-error feedback
6677          end;
6678        end;
6679      //ectStepOverInstruction:
6680      //  begin
6681      //  end;
6682      ectStepIntoInstruction:
6683        DoEndStepping;
6684      ectReturn:
6685        DoEndStepping;
6686    end;
6687  end;
6688
6689  function GetCurrentFp: TDBGPtr;
6690  begin
6691    FContext.ThreadContext := ccUseLocal;
6692    FContext.StackContext := ccUseLocal;
6693    FContext.StackFrame := 0;
6694    FContext.ThreadId := CurThreadId;
6695    Result := GetPtrValue('$fp', []);
6696    FContext.ThreadContext := ccNotRequired;
6697    FContext.StackContext := ccNotRequired;
6698  end;
6699
6700  function DoExecCommand(AnExecCmd:  TGDBMIExecCommandType; AnExecArg: String): Boolean;
6701  var
6702    UseMI: Boolean;
6703    AFlags: TGDBMICommandFlags;
6704    s: String;
6705  begin
6706    Result := False;
6707    if AnExecCmd in [ectStepOut, ectReturn {, ectRunTo}] then begin
6708      FContext.ThreadContext := ccUseLocal;
6709      FContext.StackContext := ccUseLocal;
6710      FContext.StackFrame := 0;
6711      FContext.ThreadId := CurThreadId;
6712    end
6713    else begin
6714      FContext.ThreadContext := ccNotRequired;
6715      FContext.StackContext := ccNotRequired;
6716    end;
6717
6718    UseMI := not FTheDebugger.FCommandNoneMiState[AnExecCmd];
6719    if UseMI then
6720      s := GDBMIExecCommandMap[AnExecCmd] + AnExecArg
6721    else
6722      s := GDBMIExecCommandMapNoneMI[AnExecCmd] + AnExecArg;
6723
6724    AFlags := [];
6725    if FTheDebugger.FAsyncModeEnabled and FTheDebugger.FCommandAsyncState[AnExecCmd] then
6726      AFlags := [cfTryAsync];
6727
6728    if (UseMI) and (cfTryAsync in AFlags) and (DebuggerProperties.UseNoneMiRunCommands = gdnmFallback)
6729    then begin
6730      if not ExecuteCommand(s + ' &', FResult, []) then // Try MI in async
6731        exit;
6732      if (FResult.State = dsError) then begin
6733        // Retry none MI
6734        FTheDebugger.FCommandNoneMiState[AnExecCmd] := True;
6735        s := GDBMIExecCommandMapNoneMI[AnExecCmd] + AnExecArg;
6736        if not ExecuteCommand(s, FResult, AFlags) then
6737          exit;
6738      end;
6739    end
6740    else begin
6741      if not ExecuteCommand(s, FResult, AFlags) then
6742        exit;
6743    end;
6744
6745    if (cfTryAsync in AFlags) and (FResult.State <> dsError) then begin
6746      if (rfAsyncFailed in FResult.Flags) then
6747        FTheDebugger.FCommandAsyncState[AnExecCmd] := False
6748      else
6749        FTheDebugger.FCurrentCmdIsAsync := True;
6750    end;
6751
6752    Result := True;
6753  end;
6754
6755var
6756  StoppedParams, RunWarnings: String;
6757  ContinueExecution, ContinueStep: Boolean;
6758  NextExecCmdObj: TGDBMIDebuggerCommandExecute;
6759  R: TGDBMIExecResult;
6760begin
6761  Result := True;
6762  FCanKillNow := False;
6763  FDidKillNow := False;
6764  FStepOverFixNeeded := sofNotNeeded;
6765  FNextExecQueued := False;
6766  FP := 0;
6767  FInitialFP := FP;
6768  CurThreadId := FTheDebugger.FCurrentThreadId;
6769  if not FTheDebugger.FCurrentThreadIdValid then CurThreadId := 1; // TODO, but we need something
6770  ContinueStep := False; // A step command was interupted, and is continued on breakpoint
6771  FStepBreakPoint := -1;
6772  RunMode := rmNormal;
6773  if (FExecType in [ectStepOver, ectStepInto, ectStepOut]) and
6774     (FTheDebugger.FStoppedReason = srRaiseExcept)
6775  then begin
6776    RunMode := rmStepToFinally;
6777    FCurrentExecCmd := ectContinue;
6778    EnablePopCatches;
6779    {$ifdef WIN64}
6780    EnableRtlUnwind;
6781    {$endif}
6782  end;
6783  if (FExecType in [ectRunTo, ectStepOver{, ectStepInto}, ectStepOut, ectStepOverInstruction {, ectStepIntoInstruction}]) then
6784    FTheDebugger.FReRaiseBreak.EnableOrSetByAddr(Self, True)
6785  else
6786    FTheDebugger.FReRaiseBreak.Disable(Self);
6787
6788  try
6789    repeat
6790      FTheDebugger.CancelBeforeRun; // TODO: see comment on top of TGDBMIDebugger.QueueCommand
6791      FTheDebugger.QueueExecuteLock; // prevent other commands from executing
6792      try
6793        if (not ContinueStep) and (not (RunMode in [rmStepToFinally])) and
6794           (FExecType in [ectStepOver, ectStepInto, ectStepOut, ectStepOverInstruction, ectStepIntoInstruction])
6795        then
6796          FP := GetCurrentFp;
6797          FInitialFP := FP;
6798
6799        FTheDebugger.FCurrentStackFrameValid := False;
6800        FTheDebugger.FCurrentThreadIdValid   := False;
6801        FTheDebugger.FCurrentCmdIsAsync := False;
6802
6803        if not DoExecCommand(FCurrentExecCmd, FCurrentExecArg) then
6804          exit;
6805
6806        if CheckResultForError(FResult)
6807        then exit;
6808        RunWarnings := FLogWarnings;
6809
6810        if (FResult.State <> dsNone)
6811        then SetDebuggerState(FResult.State);
6812
6813        // if ContinueExecution will be true, the we ignore dsError..
6814        // TODO: check for cancelled
6815        StoppedParams := '';
6816        FCanKillNow := True;
6817        R.State := dsNone;
6818        if FResult.State = dsRun
6819        then Result := ProcessRunning(StoppedParams, R);
6820      finally
6821        FCanKillNow := False;
6822        // allow other commands to execute
6823        // e.g. source-line-info, watches.. all triggered in ProcessStopped)
6824        //TODO: prevent the next exec-command from running (or the order of SetLocation in Process Stopped is wrong)
6825        FTheDebugger.QueueExecuteUnlock;
6826      end;
6827
6828      if FDidKillNow or CheckResultForError(R)
6829      then exit;
6830
6831      ContinueExecution := False;
6832      if HandleBreakPointError(FResult, RunWarnings + LineEnding + FLogWarnings) then begin
6833        if FResult.State = dsStop then exit;
6834        ContinueExecution := FResult.State = dsRun; // no user interaction => FMainAddrBreak
6835      end;
6836
6837      ContinueStep := False;
6838      if StoppedParams <> ''
6839      then ContinueExecution := ProcessStopped(StoppedParams, FTheDebugger.PauseWaitState = pwsInternal);
6840
6841      if ContinueExecution
6842      then begin
6843        ContinueStep := DoContinueStepping; // will set dsPause, if step has finished
6844
6845        if (not ContinueStep) and (FCurrentExecCmd <> ectNone) then begin
6846          // - Fall back to "old" behaviour and queue a new exec-continue
6847          // - Queue is unlocked, so nothing should be empty
6848          //   But make info available, if anything wants to queue
6849          FNextExecQueued := True;
6850          debugln(DBGMI_QUEUE_DEBUG, ['CommandExecute: Internal queuing -exec-continue (ContinueExecution = True)']);
6851          FTheDebugger.FPauseWaitState := pwsNone;
6852          NextExecCmdObj := TGDBMIDebuggerCommandExecute.Create(FTheDebugger, ectContinue);
6853          FTheDebugger.QueueExecuteLock; // force queue
6854          FTheDebugger.QueueCommand(NextExecCmdObj, DebuggerState = dsInternalPause); // TODO: ForceQueue, only until better means of queue control... (allow snapshot to run)
6855          FTheDebugger.QueueExecuteUnlock;
6856        end;
6857      end;
6858
6859    until (not ContinueStep) or (FCurrentExecCmd = ectNone);
6860
6861  finally
6862    if FStepBreakPoint > 0
6863    then ExecuteCommand('-break-delete %d', [FStepBreakPoint], [cfNoThreadContext]);
6864    FStepBreakPoint := -1;
6865    DisablePopCatches;
6866    {$ifdef WIN64}
6867    FTheDebugger.FRtlUnwindExBreak.Disable(Self);
6868    FTheDebugger.FSehRaiseBreaks.ClearAll(Self);
6869    {$endif}
6870    FTheDebugger.FMainAddrBreak.Clear(Self);
6871
6872    if (not ContinueExecution) and (DebuggerState = dsRun) and
6873       (FTheDebugger.PauseWaitState <> pwsInternal)
6874    then begin
6875      // Handle the unforeseen
6876      if (StoppedParams <> '')
6877      then debugln(['ERROR: Got stop params, but did not change FTheDebugger.state: ', StoppedParams])
6878      else debugln(['ERROR: Got NO stop params at all, but was running']);
6879      SetDebuggerState(dsPause);
6880    end;
6881  end;
6882end;
6883
6884constructor TGDBMIDebuggerCommandExecute.Create(AOwner: TGDBMIDebugger;
6885  const ExecType: TGDBMIExecCommandType);
6886begin
6887  Create(AOwner, ExecType, []);
6888end;
6889
6890constructor TGDBMIDebuggerCommandExecute.Create(AOwner: TGDBMIDebugger;
6891  const ExecType: TGDBMIExecCommandType; Args: array of const);
6892begin
6893  inherited Create(AOwner);
6894  FQueueRunLevel := 0; // Execommands are only allowed at level 0
6895  FCanKillNow := False;
6896  FDidKillNow := False;;
6897  FNextExecQueued := False;
6898  FExecType := ExecType;
6899  FCurrentExecCmd := ExecType;
6900  FCurrentExecArg := '';
6901  if FCurrentExecCmd = ectRunTo then begin
6902    FRunToSrc := AnsiString(Args[0].VAnsiString);
6903    FRunToLine := Args[1].VInteger;
6904    FCurrentExecArg := Format(' %s:%d', [FRunToSrc, FRunToLine]);
6905  end;
6906end;
6907
6908function TGDBMIDebuggerCommandExecute.DebugText: String;
6909begin
6910  Result := Format('%s: %s', [ClassName, GDBMIExecCommandMap[FCurrentExecCmd]]);
6911end;
6912
6913{ TGDBMIDebuggerCommandLineSymbolInfo }
6914
6915function TGDBMIDebuggerCommandLineSymbolInfo.DoExecute: Boolean;
6916var
6917  Src: String;
6918begin
6919  Result := True;
6920  FContext.ThreadContext := ccNotRequired;
6921  FContext.StackContext := ccNotRequired;
6922
6923  Src := StringReplace(FSource, '\', '/', [rfReplaceAll]);
6924  Src := StringReplace(Src, '"', '\"', [rfReplaceAll]);
6925  ExecuteCommand('-symbol-list-lines "%s"', [Src], FResult);
6926
6927  if (FResult.State = dsError) and not(dcsCanceled in SeenStates)
6928  then
6929    ExecuteCommand('-symbol-list-lines %s', [FSource], FResult);
6930
6931  if (FResult.State = dsError) and not(dcsCanceled in SeenStates)
6932  then begin
6933    // the second trial: gdb can return info to file w/o path
6934    Src := ExtractFileName(FSource);
6935    if Src <> FSource
6936    then ExecuteCommand('-symbol-list-lines %s', [Src], FResult);
6937  end;
6938end;
6939
6940constructor TGDBMIDebuggerCommandLineSymbolInfo.Create(AOwner: TGDBMIDebugger;
6941  Source: string);
6942begin
6943  inherited Create(AOwner);
6944  FSource := Source;
6945end;
6946
6947function TGDBMIDebuggerCommandLineSymbolInfo.DebugText: String;
6948begin
6949  Result := Format('%s: Source=%s', [ClassName, FSource]);
6950end;
6951
6952{ TGDBMIDebuggerCommandStackDepth }
6953
6954function TGDBMIDebuggerCommandStackDepth.DoExecute: Boolean;
6955var
6956  R: TGDBMIExecResult;
6957  List: TGDBMINameValueList;
6958  i, cnt: longint;
6959begin
6960  Result := True;
6961  if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
6962
6963  FContext.StackContext := ccNotRequired;
6964  FContext.ThreadContext := ccUseLocal;
6965  FContext.ThreadId := FCallstack.ThreadId;
6966
6967  FDepth := -1;
6968
6969  if FLimit > 0 then
6970    ExecuteCommand('-stack-info-depth %d', [FLimit], R)
6971  else
6972    ExecuteCommand('-stack-info-depth', R);
6973  List := TGDBMINameValueList.Create(R);
6974  cnt := StrToIntDef(List.Values['depth'], -1);
6975  FreeAndNil(List);
6976  if cnt = -1 then
6977  begin
6978    { In case of error some stackframes still can be accessed.
6979      Trying to find out how many...
6980      We try maximum 40 frames, because sometimes a corrupt stack and a bug in
6981      gdb may cooperate, so that -stack-info-depth X returns always X }
6982    FLimit := 0; // this is a final result
6983    i:=0;
6984    repeat
6985      inc(i);
6986      ExecuteCommand('-stack-info-depth %d', [i], R);
6987      List := TGDBMINameValueList.Create(R);
6988      cnt := StrToIntDef(List.Values['depth'], -1);
6989      FreeAndNil(List);
6990      if (cnt = -1) then begin
6991        // no valid stack-info-depth found, so the previous was the last valid one
6992        cnt:=i - 1;
6993      end;
6994    until (cnt < i) or (i = 40);
6995  end;
6996  FDepth := cnt;
6997end;
6998
6999constructor TGDBMIDebuggerCommandStackDepth.Create(AOwner: TGDBMIDebugger;
7000  ACallstack: TCallStackBase);
7001begin
7002  inherited Create(AOwner, ACallstack);
7003  FLimit := 0;
7004end;
7005
7006function TGDBMIDebuggerCommandStackDepth.DebugText: String;
7007begin
7008  Result := Format('%s:', [ClassName]);
7009end;
7010
7011{ TGDBMIDebuggerCommandStackFrames }
7012
7013function TGDBMIDebuggerCommandStackFrames.DoExecute: Boolean;
7014var
7015  CurStartIdx: Integer;
7016  It: TMapIterator;
7017
7018  procedure FreeList(var AList: TGDBMINameValueListArray);
7019  var
7020    i : Integer;
7021  begin
7022    for i := low(AList) to high(AList) do
7023      AList[i].Free;
7024  end;
7025
7026  procedure UpdateEntry(AnEntry: TCallStackEntry; AArgInfo, AFrameInfo : TGDBMINameValueList);
7027  var
7028    i, j, n, e, NameEnd: Integer;
7029    Arguments: TStringList;
7030    List: TGDBMINameValueList;
7031    Arg: PGDBMINameValue;
7032    addr: TDbgPtr;
7033    func, filename, fullname, line, cl, fn, fa, un: String;
7034  begin
7035    Arguments := TStringList.Create;
7036
7037    if (AArgInfo <> nil) and (AArgInfo.Count > 0)
7038    then begin
7039      List := TGDBMINameValueList.Create('');
7040      for n := 0 to AArgInfo.Count - 1 do
7041      begin
7042        Arg := AArgInfo.Items[n];
7043        List.Init(Arg^.Name);
7044        Arguments.Add(List.Values['name'] + '=' + DeleteEscapeChars(List.Values['value']));
7045      end;
7046      FreeAndNil(List);
7047    end;
7048
7049    addr := 0;
7050    func := '';
7051    filename := '';
7052    fullname := '';
7053    line := '';
7054    if AFrameInfo <> nil
7055    then begin
7056      Val(AFrameInfo.Values['addr'], addr, e);
7057      if e=0 then ;
7058      func := AFrameInfo.Values['func'];
7059      filename := ConvertGdbPathAndFile(AFrameInfo.Values['file']);
7060      fullname := ConvertGdbPathAndFile(AFrameInfo.Values['fullname']);
7061      line := AFrameInfo.Values['line'];
7062    end;
7063
7064    (*
7065func="fpc_pushexceptaddr"
7066func="_$CODETEMPLATESDLG$_Ld98"
7067func="_$CODETEMPLATESDLG$_Ld98"
7068func="??"
7069    *)
7070
7071    j := pos('$', func);
7072    if j > 1 then begin
7073      un := '';
7074      cl := '';
7075      fa := '';
7076      i := pos('_$__', func);
7077      if i > 1 then begin
7078        // CLASSES$_$TREADER_$__$$_READINTEGER$$LONGINT
7079        // SYSTEM_TOBJECT_$__DISPATCH$formal
7080        // UNIT1_TFORM1_$__FORMCLOSE$TOBJECT$TCLOSEACTION
7081        cl := copy(func, 1, i - 1); // unit and class
7082
7083        if copy(func, i + 4, 3) = '$$_' then
7084          inc(i, 3);
7085        NameEnd := PosEx('$', func, i + 4);
7086        if NameEnd <= 0
7087        then NameEnd := length(func) + 1;
7088        fn := copy(func, i + 4, NameEnd - (i + 4)); // function
7089
7090        i := pos('$_$', cl);
7091        if i > 1 then begin
7092          un := copy(cl, 1, i - 1); // unit
7093          delete(cl, 1, i + 2);     // class
7094        end
7095        else begin
7096          i := pos('_', cl);
7097          if posex('_', cl, i + 1) < 1 then begin
7098            // Only one _ => split unit and class
7099            un := copy(cl, 1, i - 1); // unit
7100            delete(cl, 1, i);     // class
7101          end;
7102        end;
7103      end
7104      else begin
7105        // SYSUTILS_COMPARETEXT$ANSISTRING$ANSISTRING$$LONGINT
7106        NameEnd := j;
7107        fn := copy(func, 1, NameEnd - 1);
7108        i := pos('_', fn);
7109        if posex('_', fn, i + 1) < 1 then begin
7110          // Only one _ => split unit and class
7111          un := copy(fn, 1, i - 1); // unit
7112          delete(fn, 1, i);     // class
7113        end;
7114      end;
7115
7116      inc(NameEnd, 1);
7117      if copy(func, NameEnd, 1) = '$' then
7118        inc(NameEnd, 1);
7119      if (length(func) >= NameEnd) and (func[NameEnd] in ['a'..'z', 'A'..'Z']) then
7120        fa := copy(func, NameEnd, MaxInt); // args
7121      fa := AnsiReplaceText(fa, '$', ',');
7122
7123      //debugln([cl,' ## ', fn]);
7124      AnEntry.Init(
7125        addr,
7126        Arguments,
7127        func,
7128        un, cl, fn, fa,
7129        StrToIntDef(line, 0)
7130      );
7131    end
7132    else begin
7133      AnEntry.Init(
7134        addr,
7135        Arguments,
7136        func,
7137        filename, fullname,
7138        StrToIntDef(line, 0)
7139      );
7140    end;
7141
7142
7143    Arguments.Free;
7144  end;
7145
7146  procedure PrepareArgs(var ADest: TGDBMINameValueListArray; AStart, AStop: Integer;
7147                        const ACmd, APath1, APath2: String);
7148  var
7149    R: TGDBMIExecResult;
7150    i, lvl : Integer;
7151    ResultList, SubList: TGDBMINameValueList;
7152  begin
7153    ExecuteCommand(ACmd, [AStart, AStop], R, [cfNoStackContext]);
7154
7155    if R.State = dsError
7156    then begin
7157      i := AStop - AStart;
7158      case i of
7159        0   : exit;
7160        1..5: begin
7161          while i >= 0 do
7162          begin
7163            PrepareArgs(ADest, AStart+i, AStart+i, ACmd, APath1, APath2);
7164            dec(i);
7165          end;
7166        end;
7167      else
7168        i := i div 2;
7169        PrepareArgs(ADest, AStart, AStart+i, ACmd, APath1, APath2);
7170        PrepareArgs(ADest, AStart+i+1, AStop, ACmd, APath1, APath2);
7171      end;
7172    end;
7173
7174    ResultList := TGDBMINameValueList.Create(R, [APath1]);
7175    for i := 0 to ResultList.Count - 1 do
7176    begin
7177      SubList := TGDBMINameValueList.Create(ResultList.GetString(i), ['frame']);
7178      lvl := StrToIntDef(SubList.Values['level'], -1);
7179      if (lvl >= AStart) and (lvl <= AStop)
7180      then begin
7181        if APath2 <> ''
7182        then SubList.SetPath(APath2);
7183        ADest[lvl-CurStartIdx] := SubList;
7184      end
7185      else SubList.Free;
7186    end;
7187    ResultList.Free;
7188  end;
7189
7190  procedure ExecForRange(AStartIdx, AEndIdx: Integer);
7191  var
7192    Args: TGDBMINameValueListArray;
7193    Frames: TGDBMINameValueListArray;
7194    e: TCallStackEntry;
7195  begin
7196    try
7197      CurStartIdx := AStartIdx;
7198      SetLength(Args, AEndIdx-AStartIdx+1);
7199      PrepareArgs(Args, AStartIdx, AEndIdx, '-stack-list-arguments 1 %d %d', 'stack-args', 'args');
7200      if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
7201
7202      SetLength(Frames, AEndIdx-AStartIdx+1);
7203      PrepareArgs(Frames, AStartIdx, AEndIdx, '-stack-list-frames %d %d', 'stack', '');
7204      if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
7205
7206      if not It.Locate(AStartIdx)
7207      then if not It.EOM
7208      then IT.Next;
7209      while it.Valid and (not It.EOM) do begin
7210        e := TCallStackEntry(It.DataPtr^);
7211        if e.Index > AEndIdx then break;
7212        UpdateEntry(e, Args[e.Index-AStartIdx], Frames[e.Index-AStartIdx]);
7213        It.Next;
7214      end;
7215
7216    finally
7217      FreeList(Args);
7218      FreeList(Frames);
7219    end;
7220  end;
7221
7222var
7223  StartIdx, EndIdx: Integer;
7224begin
7225  Result := True;
7226  if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
7227
7228  FContext.StackContext := ccNotRequired;
7229  FContext.ThreadContext := ccUseLocal;
7230  FContext.ThreadId := FCallstack.ThreadId;
7231
7232
7233  It := TMapIterator.Create(FCallstack.RawEntries);
7234  try
7235    //if It.Locate(AIndex)
7236    StartIdx := Max(FCallstack.LowestUnknown, 0);
7237    EndIdx   := FCallstack.HighestUnknown;
7238    while EndIdx >= StartIdx do begin
7239      if (FCallstack = nil) or (dcsCanceled in SeenStates) then break;
7240      debugln(DBG_VERBOSE, ['Callstack.Frames A StartIdx=',StartIdx, ' EndIdx=',EndIdx]);
7241      // search for existing blocks in the middle
7242      if not It.Locate(StartIdx)
7243      then if not It.EOM
7244      then IT.Next;
7245      StartIdx := TCallStackEntry(It.DataPtr^).Index;
7246      EndIdx := StartIdx;
7247      It.Next;
7248      while (not It.EOM) and (TCallStackEntry(It.DataPtr^).Index = EndIdx+1) do begin
7249        inc(EndIdx);
7250        if EndIdx = FCallstack.HighestUnknown then
7251          Break;
7252        It.Next;
7253      end;
7254
7255      debugln(DBG_VERBOSE, ['Callstack.Frames B StartIdx=',StartIdx, ' EndIdx=',EndIdx]);
7256      ExecForRange(StartIdx, EndIdx);
7257      if (FCallstack = nil) or (dcsCanceled in SeenStates) then break;
7258
7259      StartIdx := EndIdx + 1;
7260      EndIdx := FCallstack.HighestUnknown;
7261    end;
7262  finally
7263    IT.Free;
7264    if FCallstack <> nil
7265    then FCallstack.DoEntriesUpdated;
7266  end;
7267end;
7268
7269{ TGDBMILineInfo }
7270
7271procedure TGDBMILineInfo.DoGetLineSymbolsDestroyed(Sender: TObject);
7272begin
7273  if FGetLineSymbolsCmdObj = Sender
7274  then FGetLineSymbolsCmdObj := nil;
7275end;
7276
7277procedure TGDBMILineInfo.ClearSources;
7278var
7279  n: Integer;
7280begin
7281  for n := Low(FSourceMaps) to High(FSourceMaps) do
7282    FSourceMaps[n].Map.Free;
7283  Setlength(FSourceMaps, 0);
7284
7285  for n := 0 to FSourceIndex.Count - 1 do
7286    DoChange(FSourceIndex[n]);
7287
7288  FSourceIndex.Clear;
7289  //FRequestedSources.Clear;
7290end;
7291
7292procedure TGDBMILineInfo.AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
7293var
7294  ID: packed record
7295    Line, Column: Integer;
7296  end;
7297  Map: TMap;
7298  n, idx: Integer;
7299  LinesList, LineList: TGDBMINameValueList;
7300  Item: PGDBMINameValue;
7301  Addr: TDbgPtr;
7302begin
7303  n := FSourceIndex.IndexOf(ASource);
7304  if n = -1
7305  then begin
7306    idx := Length(FSourceMaps);
7307    SetLength(FSourceMaps, idx+1);
7308    FSourceMaps[idx].Map := nil;
7309    FSourceMaps[idx].Source := ASource;
7310    n := FSourceIndex.AddObject(ASource, TObject(PtrInt(idx)));
7311  end
7312  else idx := PtrInt(FSourceIndex.Objects[n]);
7313
7314  LinesList := TGDBMINameValueList.Create(AResult, ['lines']);
7315  if LinesList = nil then Exit;
7316
7317  Map := FSourceMaps[idx].Map;
7318  if Map = nil
7319  then begin
7320    // no map present
7321    Map := TMap.Create(its8, SizeOf(TDBGPtr));
7322    FSourceMaps[idx].Map := Map;
7323  end;
7324
7325  ID.Column := 0;
7326  LineList := TGDBMINameValueList.Create('');
7327  for n := 0 to LinesList.Count - 1 do
7328  begin
7329    Item := LinesList.Items[n];
7330    LineList.Init(Item^.Name);
7331    if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
7332    if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
7333    // one line can have more than one address
7334    if Map.HasId(ID) then Continue;
7335    Map.Add(ID, Addr);
7336  end;
7337  LineList.Free;
7338  LinesList.Free;
7339  DoChange(ASource);
7340end;
7341
7342function TGDBMILineInfo.Count: Integer;
7343begin
7344  Result := FSourceIndex.Count;
7345end;
7346
7347function TGDBMILineInfo.HasAddress(const AIndex: Integer; const ALine: Integer
7348  ): Boolean;
7349begin
7350  Result := GetAddress(AIndex, ALine) <> 0;
7351end;
7352
7353function TGDBMILineInfo.GetSource(const AIndex: integer): String;
7354begin
7355  if AIndex < Low(FSourceMaps) then Exit('');
7356  if AIndex > High(FSourceMaps) then Exit('');
7357
7358  Result := FSourceMaps[AIndex].Source;
7359end;
7360
7361function TGDBMILineInfo.GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr;
7362var
7363  ID: packed record
7364    Line, Column: Integer;
7365  end;
7366  Map: TMap;
7367begin
7368  if AIndex < Low(FSourceMaps) then Exit(0);
7369  if AIndex > High(FSourceMaps) then Exit(0);
7370
7371  Map := FSourceMaps[AIndex].Map;
7372  if Map = nil then Exit(0);
7373
7374  ID.Line := ALine;
7375  // since we do not have column info we map all on column 0
7376  // ID.Column := AColumn;
7377  ID.Column := 0;
7378  if (Map = nil) then Exit(0);
7379  if not Map.GetData(ID, Result) then
7380    Result := 0;
7381end;
7382
7383function TGDBMILineInfo.GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean;
7384begin
7385  Result := False;
7386end;
7387
7388procedure TGDBMILineInfo.DoStateChange(const AOldState: TDBGState);
7389begin
7390  if not (Debugger.State in [dsPause, dsInternalPause, dsRun]) then
7391    ClearSources;
7392end;
7393
7394function TGDBMILineInfo.IndexOf(const ASource: String): integer;
7395begin
7396  Result := FSourceIndex.IndexOf(ASource);
7397  if Result <> -1
7398  then Result := PtrInt(FSourceIndex.Objects[Result]);
7399end;
7400
7401constructor TGDBMILineInfo.Create(const ADebugger: TDebuggerIntf);
7402begin
7403  FSourceIndex := TStringList.Create;
7404  FSourceIndex.Sorted := True;
7405  FSourceIndex.Duplicates := dupError;
7406  FSourceIndex.CaseSensitive := True;
7407  FRequestedSources := TStringList.Create;
7408  FRequestedSources.Sorted := True;
7409  FRequestedSources.Duplicates := dupError;
7410  FRequestedSources.CaseSensitive := True;
7411  inherited;
7412end;
7413
7414destructor TGDBMILineInfo.Destroy;
7415begin
7416  ClearSources;
7417  FreeAndNil(FSourceIndex);
7418  FreeAndNil(FRequestedSources);
7419  inherited Destroy;
7420end;
7421
7422procedure TGDBMILineInfo.DoGetLineSymbolsFinished(Sender: TObject);
7423var
7424  Cmd: TGDBMIDebuggerCommandLineSymbolInfo;
7425  idx: LongInt;
7426begin
7427  Cmd := TGDBMIDebuggerCommandLineSymbolInfo(Sender);
7428  if Cmd.Result.State <> dsError
7429  then
7430    AddInfo(Cmd.Source, Cmd.Result);
7431
7432  idx := FRequestedSources.IndexOf(Cmd.Source);
7433  if idx >= 0
7434  then FRequestedSources.Delete(idx);
7435
7436  FGetLineSymbolsCmdObj := nil;
7437  // DoChange is calle in AddInfo
7438end;
7439
7440procedure TGDBMILineInfo.Request(const ASource: String);
7441var
7442  idx: Integer;
7443begin
7444  if (ASource = '') or (Debugger = nil) or (FRequestedSources.IndexOf(ASource) >= 0)
7445  then Exit;
7446
7447  idx := IndexOf(ASource);
7448  if (idx <> -1) and (FSourceMaps[idx].Map <> nil) then Exit; // already present
7449
7450  // add empty entry, to prevent further requests
7451  FRequestedSources.Add(ASource);
7452
7453  // Need to interupt debugger
7454  if Debugger.State = dsRun
7455  then TGDBMIDebugger(Debugger).GDBPause(True);
7456
7457  FGetLineSymbolsCmdObj := TGDBMIDebuggerCommandLineSymbolInfo.Create(TGDBMIDebugger(Debugger), ASource);
7458  FGetLineSymbolsCmdObj.OnExecuted := @DoGetLineSymbolsFinished;
7459  FGetLineSymbolsCmdObj.OnDestroy   := @DoGetLineSymbolsDestroyed;
7460  FGetLineSymbolsCmdObj.Priority := GDCMD_PRIOR_LINE_INFO;
7461  (* TGDBMIDebugger(Debugger).FCommandQueueExecLock > 0
7462     Force queue, if locked. This will set the RunLevel
7463     This can be called in AsyncCAll (TApplication), while in QueueExecuteLock (this does not run on unlock)
7464     Without ForceQueue, the queue is virtually locked until the current command finishes.
7465     But ExecCommand must be able to unlock
7466     Reproduce: Trigger Exception in app startup (lfm loading). Stack is not searched.
7467  *)
7468  TGDBMIDebugger(Debugger).QueueCommand(FGetLineSymbolsCmdObj,
7469                                        TGDBMIDebugger(Debugger).FCommandQueueExecLock > 0
7470                                       );
7471  (* DoEvaluationFinished may be called immediately at this point *)
7472end;
7473
7474procedure TGDBMILineInfo.Cancel(const ASource: String);
7475var
7476  i: Integer;
7477  q: TGDBMIDebugger;
7478begin
7479  q := TGDBMIDebugger(Debugger);
7480  i := q.FCommandQueue.Count - 1;
7481  while i >= 0 do begin
7482    if (q.FCommandQueue[i] is TGDBMIDebuggerCommandLineSymbolInfo) and
7483       (TGDBMIDebuggerCommandLineSymbolInfo(q.FCommandQueue[i]).Source = ASource)
7484    then q.FCommandQueue[i].Cancel;
7485    dec(i);
7486    if i >= q.FCommandQueue.Count
7487    then i := q.FCommandQueue.Count - 1;
7488  end;
7489end;
7490
7491
7492{ =========================================================================== }
7493{ TGDBMIDebuggerPropertiesBase }
7494{ =========================================================================== }
7495
7496procedure TGDBMIDebuggerPropertiesBase.SetTimeoutForEval(const AValue: Integer);
7497begin
7498  if FTimeoutForEval = AValue then exit;
7499  FTimeoutForEval := AValue;
7500  if (FTimeoutForEval <> -1) and (FTimeoutForEval < 50)
7501  then FTimeoutForEval := -1;
7502end;
7503
7504procedure TGDBMIDebuggerPropertiesBase.SetMaxDisplayLengthForString(AValue: Integer);
7505begin
7506  if FMaxDisplayLengthForString = AValue then Exit;
7507  if AValue < 0 then
7508    AValue := 0;
7509  FMaxDisplayLengthForString := AValue;
7510end;
7511
7512procedure TGDBMIDebuggerPropertiesBase.SetMaxDisplayLengthForStaticArray(AValue: Integer);
7513begin
7514  if FMaxDisplayLengthForStaticArray = AValue then Exit;
7515  if AValue < 0 then
7516    AValue := 0;
7517  FMaxDisplayLengthForStaticArray := AValue;
7518end;
7519
7520procedure TGDBMIDebuggerPropertiesBase.SetGdbLocalsValueMemLimit(AValue: Integer);
7521begin
7522  if FGdbLocalsValueMemLimit = AValue then Exit;
7523  if AValue < 0 then
7524    AValue := 0;
7525  FGdbLocalsValueMemLimit := AValue;
7526end;
7527
7528procedure TGDBMIDebuggerPropertiesBase.SetMaxLocalsLengthForStaticArray(AValue: Integer);
7529begin
7530  if FMaxLocalsLengthForStaticArray = AValue then Exit;
7531  if AValue < 0 then
7532    AValue := 0;
7533  FMaxLocalsLengthForStaticArray := AValue;
7534end;
7535
7536procedure TGDBMIDebuggerPropertiesBase.SetWarnOnTimeOut(const AValue: Boolean);
7537begin
7538  if FWarnOnTimeOut = AValue then exit;
7539  FWarnOnTimeOut := AValue;
7540end;
7541
7542constructor TGDBMIDebuggerPropertiesBase.Create;
7543begin
7544  {$IFDEF UNIX}
7545  FConsoleTty := '';
7546  {$ENDIF}
7547  FMaxDisplayLengthForString := 2500;
7548  FMaxDisplayLengthForStaticArray := 500;
7549  FMaxLocalsLengthForStaticArray := 25;
7550  {$IFDEF darwin}
7551  FTimeoutForEval := 250;
7552  {$ELSE darwin}
7553  FTimeoutForEval := -1;
7554  {$ENDIF}
7555  FWarnOnTimeOut := True;
7556  FWarnOnInternalError := TGDBMIDebuggerShowWarning.OncePerRun;
7557  FEncodeCurrentDirPath := gdfeDefault;
7558  FEncodeExeFileName := gdfeDefault;
7559  FInternalStartBreak := gdsbDefault;
7560  FUseAsyncCommandMode := False;
7561  FDisableLoadSymbolsForLibraries := False;
7562  FUseNoneMiRunCommands := gdnmFallback;
7563  FDisableForcedBreakpoint := False;
7564  FWarnOnSetBreakpointError := gdbwAll;
7565  FCaseSensitivity := gdcsSmartOff;
7566  FGdbValueMemLimit := $60000000;
7567  FGdbLocalsValueMemLimit := 32000;
7568  FAssemblerStyle := gdasDefault;
7569  FDisableStartupShell := False;
7570  FFixStackFrameForFpcAssert := True;
7571  FFixIncorrectStepOver := False;
7572  inherited;
7573end;
7574
7575procedure TGDBMIDebuggerPropertiesBase.Assign(Source: TPersistent);
7576begin
7577  inherited Assign(Source);
7578  FGDBOptions := TGDBMIDebuggerPropertiesBase(Source).FGDBOptions;
7579  {$IFDEF UNIX}
7580  FConsoleTty := TGDBMIDebuggerPropertiesBase(Source).FConsoleTty;
7581  {$ENDIF}
7582  FMaxDisplayLengthForString := TGDBMIDebuggerPropertiesBase(Source).FMaxDisplayLengthForString;
7583  FMaxDisplayLengthForStaticArray := TGDBMIDebuggerPropertiesBase(Source).FMaxDisplayLengthForStaticArray;
7584  FMaxLocalsLengthForStaticArray := TGDBMIDebuggerPropertiesBase(Source).FMaxLocalsLengthForStaticArray;
7585  FTimeoutForEval := TGDBMIDebuggerPropertiesBase(Source).FTimeoutForEval;
7586  FWarnOnTimeOut  := TGDBMIDebuggerPropertiesBase(Source).FWarnOnTimeOut;
7587  FWarnOnInternalError  := TGDBMIDebuggerPropertiesBase(Source).FWarnOnInternalError;
7588  FEncodeCurrentDirPath := TGDBMIDebuggerPropertiesBase(Source).FEncodeCurrentDirPath;
7589  FEncodeExeFileName := TGDBMIDebuggerPropertiesBase(Source).FEncodeExeFileName;
7590  FInternalStartBreak := TGDBMIDebuggerPropertiesBase(Source).FInternalStartBreak;
7591  FUseAsyncCommandMode := TGDBMIDebuggerPropertiesBase(Source).FUseAsyncCommandMode;
7592  FDisableLoadSymbolsForLibraries := TGDBMIDebuggerPropertiesBase(Source).FDisableLoadSymbolsForLibraries;
7593  FUseNoneMiRunCommands := TGDBMIDebuggerPropertiesBase(Source).FUseNoneMiRunCommands;
7594  FDisableForcedBreakpoint := TGDBMIDebuggerPropertiesBase(Source).FDisableForcedBreakpoint;
7595  FWarnOnSetBreakpointError := TGDBMIDebuggerPropertiesBase(Source).FWarnOnSetBreakpointError;
7596  FCaseSensitivity := TGDBMIDebuggerPropertiesBase(Source).FCaseSensitivity;
7597  FGdbValueMemLimit := TGDBMIDebuggerPropertiesBase(Source).FGdbValueMemLimit;
7598  FGdbLocalsValueMemLimit := TGDBMIDebuggerPropertiesBase(Source).FGdbLocalsValueMemLimit;
7599  FAssemblerStyle := TGDBMIDebuggerPropertiesBase(Source).FAssemblerStyle;
7600  FDisableStartupShell := TGDBMIDebuggerPropertiesBase(Source).FDisableStartupShell;
7601  FFixStackFrameForFpcAssert := TGDBMIDebuggerPropertiesBase(Source).FFixStackFrameForFpcAssert;
7602  FFixIncorrectStepOver := TGDBMIDebuggerPropertiesBase(Source).FFixIncorrectStepOver;
7603end;
7604
7605
7606{ =========================================================================== }
7607{ TGDBMIDebugger }
7608{ =========================================================================== }
7609
7610class function TGDBMIDebugger.Caption: String;
7611begin
7612  Result := 'GNU debugger (gdb)';
7613end;
7614
7615function TGDBMIDebugger.ChangeFileName: Boolean;
7616var
7617  Cmd: TGDBMIDebuggerCommandChangeFilename;
7618begin
7619  Result := False;
7620  FCurrentStackFrameValid := False; // not running => not valid
7621  FCurrentThreadIdValid   := False;
7622
7623  if State = dsIdle then begin
7624    // will do in start debugging
7625    if not (inherited ChangeFileName) then Exit;
7626    Result:=true;
7627    exit;
7628  end;
7629
7630  Cmd := TGDBMIDebuggerCommandChangeFilename.Create(Self, FileName);
7631  Cmd.AddReference;
7632  QueueCommand(Cmd);
7633  // if filename = '', then command may be queued
7634  if (FileName <> '') and (not Cmd.Success) then begin
7635    MessageDlg('Debugger', Format('Failed to load file: %s', [Cmd.ErrorMsg]), mtError, [mbOK], 0);
7636    Cmd.Cancel;
7637    Cmd.ReleaseReference;
7638    SetState(dsStop);
7639  end
7640  else begin
7641    Cmd.ReleaseReference;
7642  end;
7643
7644  if not (inherited ChangeFileName) then Exit;
7645  Result:=true;
7646end;
7647
7648constructor TGDBMIDebugger.Create(const AExternalDebugger: String);
7649begin
7650  FMainAddrBreak   := TGDBMIInternalBreakPoint.Create('main');
7651  FBreakErrorBreak := TGDBMIInternalBreakPoint.Create('FPC_BREAK_ERROR');
7652  FRunErrorBreak   := TGDBMIInternalBreakPoint.Create('FPC_RUNERROR');
7653  FExceptionBreak  := TGDBMIInternalBreakPoint.Create('FPC_RAISEEXCEPTION');
7654  FPopExceptStack  := TGDBMIInternalBreakPoint.Create('FPC_POPADDRSTACK');
7655  FCatchesBreak    := TGDBMIInternalBreakPoint.Create('FPC_CATCHES');
7656  FReRaiseBreak    := TGDBMIInternalBreakPoint.Create('FPC_RERAISE');
7657  {$ifdef WIN64}
7658  FRtlUnwindExBreak:= TGDBMIInternalBreakPoint.Create('RtlUnwindEx');
7659  FSehRaiseBreaks  := TGDBMIInternalAddrBreakPointList.Create;
7660  {$endif}
7661{$IFdef WITH_GDB_FORCE_EXCEPTBREAK}
7662  FBreakErrorBreak.UseForceFlag := True;
7663  FRunErrorBreak.UseForceFlag := True;
7664  FExceptionBreak.UseForceFlag := True;
7665{$ENDIF}
7666
7667  FInstructionQueue := TGDBMIDbgInstructionQueue.Create(Self);
7668  FCommandQueue := TGDBMIDebuggerCommandList.Create;
7669  FTargetInfo.TargetPID := 0;
7670  FTargetInfo.TargetFlags := [];
7671  FDebuggerFlags := [];
7672  FSourceNames := TStringList.Create;
7673  FSourceNames.Sorted := True;
7674  FSourceNames.Duplicates := dupError;
7675  FSourceNames.CaseSensitive := False;
7676  FCommandQueueExecLock := 0;
7677  FRunQueueOnUnlock := False;
7678  FThreadGroups := TStringList.Create;
7679  FTypeRequestCache := CreateTypeRequestCache;
7680  FMaxLineForUnitCache := TStringList.Create;
7681  FInProcessStopped := False;
7682  FNeedStateToIdle := False;
7683  FNeedReset := False;
7684  FWarnedOnInternal := False;
7685
7686
7687{$IFdef MSWindows}
7688  InitWin32;
7689{$ENDIF}
7690  {$IFDEF DBG_ENABLE_TERMINAL}
7691  FPseudoTerminal := TPseudoTerminal.Create;
7692  FPseudoTerminal.OnCanRead :=@DoPseudoTerminalRead;
7693  {$ENDIF}
7694
7695  inherited;
7696end;
7697
7698function TGDBMIDebugger.CreateBreakPoints: TDBGBreakPoints;
7699begin
7700  Result := TGDBMIBreakPoints.Create(Self, TGDBMIBreakPoint);
7701end;
7702
7703function TGDBMIDebugger.CreateCallStack: TCallStackSupplier;
7704begin
7705  Result := TGDBMICallStack.Create(Self);
7706end;
7707
7708function TGDBMIDebugger.CreateDisassembler: TDBGDisassembler;
7709begin
7710  Result := TGDBMIDisassembler.Create(Self);
7711end;
7712
7713function TGDBMIDebugger.CreateLocals: TLocalsSupplier;
7714begin
7715  Result := TGDBMILocals.Create(Self);
7716end;
7717
7718function TGDBMIDebugger.CreateLineInfo: TDBGLineInfo;
7719begin
7720  Result := TGDBMILineInfo.Create(Self);
7721end;
7722
7723class function TGDBMIDebugger.CreateProperties: TDebuggerProperties;
7724begin
7725  Result := TGDBMIDebuggerProperties.Create;
7726end;
7727
7728function TGDBMIDebugger.CreateRegisters: TRegisterSupplier;
7729begin
7730  Result := TGDBMIRegisterSupplier.Create(Self);
7731end;
7732
7733function TGDBMIDebugger.CreateWatches: TWatchesSupplier;
7734begin
7735  Result := TGDBMIWatches.Create(Self);
7736end;
7737
7738function TGDBMIDebugger.CreateThreads: TThreadsSupplier;
7739begin
7740  Result := TGDBMIThreads.Create(Self);
7741end;
7742
7743function TGDBMIDebugger.CreateCommandInit: TGDBMIDebuggerCommandInitDebugger;
7744begin
7745  Result := TGDBMIDebuggerCommandInitDebugger.Create(Self);
7746end;
7747
7748function TGDBMIDebugger.CreateCommandStartDebugging
7749  (AContinueCommand: TGDBMIDebuggerCommand): TGDBMIDebuggerCommandStartDebugging;
7750begin
7751  Result:= TGDBMIDebuggerCommandStartDebugging.Create(Self, AContinueCommand);
7752end;
7753
7754destructor TGDBMIDebugger.Destroy;
7755begin
7756  LockRelease;
7757  inherited;
7758  ClearCommandQueue;
7759  //RemoveRunQueueASync;
7760  FreeAndNil(FCommandQueue);
7761  FreeAndNil(FInstructionQueue);
7762  ClearSourceInfo;
7763  FreeAndNil(FSourceNames);
7764  FreeAndNil(FThreadGroups);
7765  {$IFDEF DBG_ENABLE_TERMINAL}
7766  FreeAndNil(FPseudoTerminal);
7767  {$ENDIF}
7768  FreeAndNil(FTypeRequestCache);
7769  FreeAndNil(FMaxLineForUnitCache);
7770  FreeAndNil(FMainAddrBreak);
7771  FreeAndNil(FBreakErrorBreak);
7772  FreeAndNil(FRunErrorBreak);
7773  FreeAndNil(FExceptionBreak);
7774  FreeAndNil(FPopExceptStack);
7775  FreeAndNil(FCatchesBreak);
7776  FreeAndNil(FReRaiseBreak);
7777  {$ifdef WIN64}
7778  FreeAndNil(FRtlUnwindExBreak);
7779  FreeAndNil(FSehRaiseBreaks);
7780  {$endif}
7781end;
7782
7783procedure TGDBMIDebugger.Done;
7784begin
7785  if State = dsDestroying
7786  then begin
7787    ClearCommandQueue;
7788    inherited Done;
7789    exit;
7790  end;
7791
7792  LockRelease;
7793  try
7794    CancelAllQueued;
7795    if (DebugProcess <> nil) and DebugProcess.Running then begin
7796      if FCurrentCommand <> Nil then
7797        FCurrentCommand.KillNow;
7798      if (State = dsRun) then GDBPause(True);
7799      // fire and forget. Donst wait on the queue.
7800      FCurrentStackFrameValid := False;
7801      FCurrentThreadIdValid   := False;
7802      SendCmdLn('kill');
7803      SendCmdLn('-gdb-exit');
7804    end;
7805    inherited Done;
7806  finally
7807    UnlockRelease;
7808  end;
7809end;
7810
7811procedure TGDBMIDebugger.BeginReset;
7812begin
7813  inherited BeginReset;
7814  FInstructionQueue.ForceTimeOutAll(500);
7815  ReadLine(True, 1);
7816end;
7817
7818function TGDBMIDebugger.GetLocation: TDBGLocationRec;
7819begin
7820  Result := FCurrentLocation;
7821end;
7822
7823function TGDBMIDebugger.GetProcessList(AList: TRunningProcessInfoList): boolean;
7824{$ifdef darwin}
7825var
7826  AResult: TGDBMIExecResult;
7827  ARunningProcessInfo: TRunningProcessInfo;
7828  pname,pid,aLine: string;
7829  s: string;
7830  i: integer;
7831{$endif}
7832begin
7833{$ifdef darwin}
7834  result := State in [dsIdle, dsStop, dsInit];
7835  if not Result then
7836    exit;
7837
7838  AResult:=GDBMIExecResultDefault;
7839  ExecuteCommand('info mach-tasks',[],[], AResult);
7840  s := AResult.Values;
7841  i := pos(sLineBreak,s);
7842  while i>0 do
7843  begin
7844    aLine := trim(copy(s,1,i-1));
7845    delete(s,1,i+1);
7846    i := pos(' is ', aLine);
7847    pid := copy(aLine,1,i-1);
7848    pname := copy(aLine,i+4,PosEx(' ',aLine,i+4)-(i+4));
7849
7850    if pid <> '' then
7851      begin
7852      ARunningProcessInfo := TRunningProcessInfo.Create(StrToIntDef(pname,-1), pid);
7853      AList.Add(ARunningProcessInfo);
7854      end;
7855    i := pos(sLineBreak,s);
7856  end;
7857
7858{$else}
7859  result := false;
7860{$endif}
7861end;
7862
7863procedure TGDBMIDebugger.LockCommandProcessing;
7864begin
7865  // Keep a different counter than QueueExecuteLock
7866  // So we can detect, if RunQueue was blocked by this
7867  inc(FCommandProcessingLock);
7868end;
7869
7870procedure TGDBMIDebugger.UnLockCommandProcessing;
7871begin
7872  dec(FCommandProcessingLock);
7873  if (FCommandProcessingLock = 0)
7874  and FRunQueueOnUnlock
7875  then begin
7876    FRunQueueOnUnlock := False;
7877    // if FCommandQueueExecLock, then queu will be run, by however has that lock
7878    if (FCommandQueueExecLock = 0) and (FCommandQueue.Count > 0)
7879    then begin
7880      DebugLnEnter(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.UnLockCommandProcessing: Execute RunQueue ']);
7881      RunQueue; // ASync
7882      DebugLnExit(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.UnLockCommandProcessing: Finished RunQueue']);
7883    end
7884  end;
7885end;
7886
7887procedure TGDBMIDebugger.DoState(const OldState: TDBGState);
7888begin
7889  FTypeRequestCache.Clear;
7890  if not (State in [dsRun, dsPause, dsInit, dsInternalPause])
7891  then FMaxLineForUnitCache.Clear;
7892
7893  if not (State in [dsPause, dsInternalPause]) then
7894    FStoppedReason := srNone;;
7895
7896  if State in [dsStop, dsError]
7897  then begin
7898    ClearSourceInfo;
7899    FPauseWaitState := pwsNone;
7900    // clear un-needed commands
7901    if State = dsError
7902    then CancelAllQueued
7903    else CancelAfterStop;
7904  end;
7905  if (State = dsError) and (DebugProcessRunning) then begin
7906    FCurrentStackFrameValid := False;
7907    FCurrentThreadIdValid   := False;
7908    FCurrentThreadId := 0;
7909    FCurrentStackFrame := 0;
7910    SendCmdLn('kill'); // try to kill the debugged process. bypass all queues.
7911    TerminateGDB;
7912  end;
7913  if (OldState in [dsPause, dsInternalPause]) and (State = dsRun)
7914  then begin
7915    FPauseWaitState := pwsNone;
7916    {$IFDEF MSWindows}
7917    FPauseRequestInThreadID := 0;
7918    {$ENDIF}
7919  end;
7920
7921  CallStack.CurrentCallStackList.EntriesForThreads[FCurrentThreadId].CurrentIndex := FCurrentStackFrame;
7922
7923  inherited DoState(OldState);
7924end;
7925
7926procedure TGDBMIDebugger.DoBeforeState(const OldState: TDBGState);
7927begin
7928  if State in [dsStop] then begin
7929    FCurrentStackFrameValid := False;
7930    FCurrentThreadIdValid   := False;
7931    FCurrentThreadId := 0;
7932    FCurrentStackFrame := 0;
7933  end;
7934  inherited DoBeforeState(OldState);
7935  Threads.CurrentThreads.CurrentThreadId := FCurrentThreadId; // TODO: Works only because CurrentThreadId is always valid
7936end;
7937
7938function TGDBMIDebugger.LineEndPos(const s: string; out LineEndLen: integer): integer;
7939var
7940  l: Integer;
7941begin
7942  Result := 1;
7943  LineEndLen := 0;
7944  l := Length(s);
7945  while (Result <= l) and not(s[Result] in [#10, #13]) do inc(Result);
7946
7947  if (Result <= l) then begin
7948    LineEndLen := 1;
7949    if (Result < l) and (s[Result + 1] in [#10, #13]) and (s[Result] <> s[Result + 1]) then
7950      LineEndLen := 2;
7951  end
7952  else
7953    Result := 0;
7954end;
7955
7956procedure TGDBMIDebugger.DoThreadChanged;
7957begin
7958  TGDBMICallstack(CallStack).DoThreadChanged;
7959  if Registers.CurrentRegistersList <> nil then
7960    Registers.CurrentRegistersList.Clear;
7961end;
7962
7963procedure TGDBMIDebugger.DoUnknownException(Sender: TObject; AnException: Exception);
7964var
7965  I: Integer;
7966  Frames: PPointer;
7967  Report, Report2: string;
7968begin
7969  try
7970    debugln(['ERROR: Exception occurred in ',Sender.ClassName+': ',
7971              AnException.ClassName, ' Msg="', AnException.Message, '" Addr=', dbgs(ExceptAddr),
7972              ' Dbg.State=', dbgs(State)]);
7973    Report :=  BackTraceStrFunc(ExceptAddr);
7974    Report2 := Report;
7975    Frames := ExceptFrames;
7976    for I := 0 to ExceptFrameCount - 1 do begin
7977      Report := Report + LineEnding + BackTraceStrFunc(Frames[I]);
7978      if i < 5
7979      then Report2 := Report;
7980    end;
7981  except
7982  end;
7983  debugln(Report);
7984
7985  if MessageDlg(gdbmiTheDebuggerExperiencedAnUnknownCondition,
7986    Format(gdbmiPressIgnoreToContinueDebuggingThisMayNOTBeSafePres,
7987    [LineEnding, AnException.ClassName, AnException.Message, Report2, Sender.ClassName, dbgs(State)]),
7988    mtWarning, [mbIgnore, mbAbort], 0, mbAbort) = mrAbort
7989  then begin
7990    try
7991      CancelAllQueued;
7992    finally
7993      Stop;
7994    end;
7995  end;
7996end;
7997
7998function TGDBMIDebugger.CheckForInternalError(ALine, ACurCommandText: String
7999  ): Boolean;
8000begin
8001  Result := (Pos('internal-error:', LowerCase(ALine)) > 0) or
8002            (Pos('internal to gdb has been detected', LowerCase(ALine)) > 0) or
8003            (Pos('further debugging may prove unreliable', LowerCase(ALine)) > 0) or
8004            (Pos('command aborted.', LowerCase(ALine)) > 0);
8005  if Result then begin
8006    FNeedReset := True;
8007    DoDbgEvent(ecDebugger, etDefault, Format(gdbmiEventLogGDBInternalError, [ALine]));
8008    if (TGDBMIDebuggerProperties(GetProperties).WarnOnInternalError = TGDBMIDebuggerShowWarning.True) or
8009       ( (TGDBMIDebuggerProperties(GetProperties).WarnOnInternalError = TGDBMIDebuggerShowWarning.OncePerRun)
8010         and not (FWarnedOnInternal))
8011    then begin
8012      FWarnedOnInternal := True;
8013      if OnFeedback(Self,
8014          Format(gdbmiGDBInternalError, [LineEnding]),
8015          Format(gdbmiGDBInternalErrorInfo, [LineEnding, ALine, ACurCommandText]),
8016          ftWarning, [frOk, frStop]
8017        ) = frStop
8018      then begin
8019        try
8020          CancelAllQueued;
8021        finally
8022          Stop;
8023        end;
8024      end;
8025    end;
8026  end;
8027end;
8028
8029procedure TGDBMIDebugger.AddThreadGroup(const S: String);
8030var
8031  List: TGDBMINameValueList;
8032begin
8033  List := TGDBMINameValueList.Create(S);
8034  FThreadGroups.Values[List.Values['id']] := List.Values['pid'];
8035  List.Free;
8036end;
8037
8038procedure TGDBMIDebugger.RemoveThreadGroup(const S: String);
8039begin
8040  // Some gdb info contains thread group which are already exited => don't remove them
8041end;
8042
8043function TGDBMIDebugger.ParseLibraryLoaded(const S: String): String;
8044const
8045  DebugInfo: array[Boolean] of String = ('No Debug Info', 'Has Debug Info');
8046var
8047  List: TGDBMINameValueList;
8048  ThreadGroup: String;
8049begin
8050  // input: =library-loaded,id="C:\\Windows\\system32\\ntdll.dll",target-name="C:\\Windows\\system32\\ntdll.dll",host-name="C:\\Windows\\system32\\ntdll.dll",symbols-loaded="0",thread-group="i1"
8051  List := TGDBMINameValueList.Create(S);
8052  ThreadGroup := List.Values['thread-group'];
8053  Result := Format('Module Load: "%s". %s. Thread Group: %s (%s)', [ConvertGdbPathAndFile(List.Values['id']), DebugInfo[List.Values['symbols-loaded'] = '1'], ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
8054  List.Free;
8055end;
8056
8057function TGDBMIDebugger.ParseLibraryUnLoaded(const S: String): String;
8058var
8059  List: TGDBMINameValueList;
8060  ThreadGroup: String;
8061begin
8062  // input: =library-unloaded,id="C:\\Windows\\system32\\advapi32.dll",target-name="C:\\Windows\\system32\\advapi32.dll",host-name="C:\\Windows\\system32\\advapi32.dll",thread-group="i1"
8063  List := TGDBMINameValueList.Create(S);
8064  ThreadGroup := List.Values['thread-group'];
8065  Result := Format('Module Unload: "%s". Thread Group: %s (%s)', [ConvertGdbPathAndFile(List.Values['id']), ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
8066  List.Free;
8067end;
8068
8069function TGDBMIDebugger.ParseThread(const S, EventText: String): String;
8070var
8071  List: TGDBMINameValueList;
8072  ThreadGroup: String;
8073begin
8074  if EventText = 'thread-created' then
8075    Result := 'Thread Start: '
8076  else
8077    Result := 'Thread Exit: ';
8078  List := TGDBMINameValueList.Create(S);
8079  ThreadGroup := List.Values['group-id'];
8080  Result := Result + Format('Thread ID: %s. Thread Group: %s (%s)', [List.Values['id'], ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
8081  List.Free;
8082end;
8083
8084function TGDBMIDebugger.CreateTypeRequestCache: TGDBPTypeRequestCache;
8085begin
8086  Result :=  TGDBPTypeRequestCache.Create;
8087end;
8088
8089procedure TGDBMIDebugger.DoNotifyAsync(Line: String);
8090var
8091  EventText: String;
8092  i, x: Integer;
8093  ct: TThreads;
8094  t: TThreadEntry;
8095  List: TGDBMINameValueList;
8096  BreakPoint: TGDBMIBreakPoint;
8097begin
8098  EventText := GetPart(['='], [','], Line, False, False);
8099  x := StringCase(EventText, [
8100    'thread-created', 'thread-exited',
8101    'shlibs-added',
8102    'library-loaded',
8103    'library-unloaded',
8104    'shlibs-updated',
8105    'thread-group-started',
8106    'thread-group-exited',
8107    'thread-created',
8108    'thread-exited',
8109    'breakpoint-modified'
8110    ], False, False);
8111    case x of
8112    0,1: begin
8113        i := StrToIntDef(GetPart(',id="', '"', Line, False, False), -1);
8114        if (i > 0) and (Threads.CurrentThreads <> nil)
8115        then begin
8116          ct := Threads.CurrentThreads;
8117          t := ct.EntryById[i];
8118          case x of
8119            0: begin
8120                if t = nil then begin
8121                  t := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, i, '', 'unknown');
8122                  ct.Add(t);
8123                  t.Free;
8124                end
8125                else
8126                  debugln(DBG_WARNINGS, 'GDBMI: Duplicate thread');
8127              end;
8128            1: begin
8129                if t <> nil then begin
8130                  ct.Remove(t);
8131                end
8132                else
8133                  debugln(DBG_WARNINGS, 'GDBMI: Missing thread');
8134              end;
8135          end;
8136          Threads.Changed;
8137        end;
8138      end;
8139    2: DoDbgEvent(ecModule, etModuleLoad, Line);
8140    3: DoDbgEvent(ecModule, etModuleLoad, ParseLibraryLoaded(Line));
8141    4: DoDbgEvent(ecModule, etModuleUnload, ParseLibraryUnloaded(Line));
8142    5: DoDbgEvent(ecModule, etDefault, Line);
8143    6: AddThreadGroup(Line);
8144    7: RemoveThreadGroup(Line);
8145    8: DoDbgEvent(ecThread, etThreadStart, ParseThread(Line, EventText));
8146    9: DoDbgEvent(ecThread, etThreadExit, ParseThread(Line, EventText));
8147    10: begin //breakpoint-modified
8148        List := TGDBMINameValueList.Create(Line);
8149        List.SetPath('bkpt');
8150        i := StrToIntDef(List.Values['number'], -1);
8151        BreakPoint := nil;
8152        if i >= 0 then
8153          BreakPoint := TGDBMIBreakPoint(FindBreakpoint(i));
8154        if (BreakPoint <> nil) and (BreakPoint.Valid = vsPending) and
8155           (List.IndexOf('pending') < 0) and
8156           (pos('pend', lowercase(List.Values['addr'])) <= 0)
8157        then
8158          BreakPoint.SetPendingToValid(vsValid);
8159        List.Free;
8160      end;
8161  else
8162    DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
8163  end;
8164end;
8165
8166procedure TGDBMIDebugger.DoDbgBreakpointEvent(ABreakpoint: TDBGBreakPoint;
8167  ALocation: TDBGLocationRec; AReason: TGDBMIBreakpointReason; AOldVal: String;
8168  ANewVal: String);
8169begin
8170  if not Assigned(EventLogHandler) then exit;
8171
8172  case AReason of
8173    gbrBreak:        EventLogHandler.LogEventBreakPointHit(ABreakpoint, ALocation);
8174    gbrWatchTrigger: EventLogHandler.LogEventWatchPointTriggered(
8175      ABreakpoint, ALocation, AOldVal, ANewVal);
8176    gbrWatchScope:   EventLogHandler.LogEventWatchPointScope(ABreakpoint, ALocation);
8177  end;
8178end;
8179
8180function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
8181  const AValues: array of const; const AFlags: TGDBMICommandFlags): Boolean;
8182var
8183  R: TGDBMIExecResult;
8184begin
8185  R:=GDBMIExecResultDefault;
8186  Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, R);
8187end;
8188
8189function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
8190  const AValues: array of const; const AFlags: TGDBMICommandFlags;
8191  var AResult: TGDBMIExecResult): Boolean;
8192begin
8193  Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, AResult);
8194end;
8195
8196function TGDBMIDebugger.ExecuteCommandFull(const ACommand: String;
8197  const AValues: array of const; const AFlags: TGDBMICommandFlags;
8198  const ACallback: TGDBMICallback; const ATag: PtrInt;
8199  var AResult: TGDBMIExecResult): Boolean;
8200var
8201  CommandObj: TGDBMIDebuggerSimpleCommand;
8202begin
8203  CommandObj := TGDBMIDebuggerSimpleCommand.Create(Self, ACommand, AValues, AFlags, ACallback, ATag);
8204  CommandObj.AddReference;
8205  QueueCommand(CommandObj);
8206  Result := CommandObj.State in [dcsExecuting, dcsFinished];
8207  if Result
8208  then
8209    AResult := CommandObj.Result;
8210  CommandObj.ReleaseReference;
8211end;
8212
8213procedure TGDBMIDebugger.RunQueue;
8214var
8215  R: Boolean;
8216  Cmd, NestedCurrentCmd, NestedCurrentCmdTmp: TGDBMIDebuggerCommand;
8217  SavedInExecuteCount: LongInt;
8218begin
8219  //RemoveRunQueueASync;
8220  if FCommandQueue.Count = 0
8221  then exit;
8222
8223  if FCommandProcessingLock > 0
8224  then begin
8225    FRunQueueOnUnlock := True;
8226    exit
8227  end;
8228
8229  // Safeguard the NestLvl and outer CurrrentCmd
8230  SavedInExecuteCount := FInExecuteCount;
8231  NestedCurrentCmd := FCurrentCommand;
8232  LockRelease;
8233  try
8234  try
8235    repeat
8236      Cmd := FCommandQueue[0];
8237      if (Cmd.QueueRunLevel >= 0) and (Cmd.QueueRunLevel < FInExecuteCount)
8238      then break;
8239
8240      Inc(FInExecuteCount);
8241
8242      FCommandQueue.Delete(0);
8243      DebugLnEnter(DBGMI_QUEUE_DEBUG, ['Executing (Recurse-Count=', FInExecuteCount-1, ') queued= ', FCommandQueue.Count, ' CmdPrior=', Cmd.Priority,' CmdMinRunLvl=', Cmd.QueueRunLevel, ' : "', Cmd.DebugText,'" State=',dbgs(State),' PauseWaitState=',ord(FPauseWaitState) ]);
8244      // cmd may be canceled while executed => don't loose it while working with it
8245      Cmd.AddReference;
8246      NestedCurrentCmdTmp := FCurrentCommand; // TODO: needs to be canceled, if there is a cancelation
8247      FCurrentCommand := Cmd;
8248      // excute, has it's own try-except block => so we don't have one here
8249      R := Cmd.Execute;
8250      Cmd.DoFinished;
8251      FCurrentCommand := NestedCurrentCmdTmp;
8252      Cmd.ReleaseReference;
8253      DebugLnExit(DBGMI_QUEUE_DEBUG, 'Exec done');
8254
8255      Dec(FInExecuteCount);
8256      // Do not add code with callbacks outside "FInExecuteCount"
8257      // Otherwhise "LockCommandProcessing" will fail to continue the queue
8258
8259      // TODO: if the debugger can accept them into a separate queue, the set stae here
8260      // TODO: For now do not allow new session, before old session is finished
8261      // There may already be commands for the next run queued,
8262      // which will then set a new state.
8263      //if FNeedStateToIdle and (FInExecuteCount = 0)
8264      //then ResetStateToIdle;
8265
8266      if State in [dsError, dsDestroying]
8267      then begin
8268        //DebugLn(DBG_WARNINGS, '[WARNING] TGDBMIDebugger:  ExecuteCommand "',Cmd,'" failed.');
8269        Break;
8270      end;
8271
8272      if  FCommandQueue.Count = 0
8273      then begin
8274        if  (FInExecuteCount = 0)                        // not in Recursive call
8275        and (FPauseWaitState = pwsInternal)
8276        and (State = dsRun)
8277        then begin
8278          // reset state
8279          FPauseWaitState := pwsNone;
8280          // insert continue command
8281          Cmd := TGDBMIDebuggerCommandExecute.Create(Self, ectContinue);
8282          FCommandQueue.Add(Cmd);
8283          debugln(DBGMI_QUEUE_DEBUG, ['Internal Queueing: exec-continue']);
8284        end
8285        else Break; // Queue empty
8286      end;
8287    until not R;
8288    debugln(DBGMI_QUEUE_DEBUG, ['Leaving Queue with count: ', FCommandQueue.Count, ' Recurse-Count=', FInExecuteCount,' State=',dbgs(State)]);
8289  finally
8290    UnlockRelease;
8291    FInExecuteCount := SavedInExecuteCount;
8292    FCurrentCommand := NestedCurrentCmd;
8293  end;
8294  except
8295    On E: Exception do DoUnknownException(Self, E);
8296    else
8297      debugln(['ERROR: Exception occurred in ',ClassName+': ',
8298                '" Addr=', dbgs(ExceptAddr), ' Dbg.State=', dbgs(State)]);
8299  end;
8300
8301  if (FCommandQueue.Count = 0) and assigned(OnIdle) and (FInExecuteCount=0) and
8302     (not FInIdle) and not(State in [dsError, dsDestroying])
8303  then begin
8304    repeat
8305      DebugLnEnter(DBGMI_QUEUE_DEBUG, ['>> Run OnIdle']);
8306      LockCommandProcessing;
8307      FInIdle := True;
8308      try
8309        OnIdle(Self);
8310      finally
8311        R := (FCommandQueue.Count > 0) and (FCommandProcessingLock = 1) and FRunQueueOnUnlock;
8312        DebugLn(DBGMI_QUEUE_DEBUG, ['OnIdle: UnLock']);
8313        UnLockCommandProcessing;
8314        FInIdle := False;
8315      end;
8316      DebugLnExit(DBGMI_QUEUE_DEBUG, ['<< Run OnIdle']);
8317    until (not R) or (not assigned(OnIdle)) or (State in [dsError, dsDestroying]);
8318    DebugLn(DBGMI_QUEUE_DEBUG, ['OnIdle: Finished ']);
8319  end;
8320
8321  if FNeedStateToIdle and (FInExecuteCount = 0)
8322  then ResetStateToIdle;
8323end;
8324
8325procedure TGDBMIDebugger.QueueCommand(const ACommand: TGDBMIDebuggerCommand; ForceQueue: Boolean = False);
8326var
8327  i, p: Integer;
8328  CanRunQueue: Boolean;
8329begin
8330  (* TODO: if an exec-command is queued, cancel watches-commands, etc (unless required for snapshot)
8331     This may occur if multiply exe are queued.
8332     Currently, they will be ForcedQueue, and end up, after the exec command => cancel by state change
8333     Also see call to CancelBeforeRun in TGDBMIDebuggerCommandExecute.DoExecute
8334  *)
8335
8336
8337  p := ACommand.Priority;
8338  i := 0;
8339  // CanRunQueue: The queue can be run for "ACommand"
8340  //  Either the queue is empty (so no other command will run)
8341  //  Or the first command on the queue is blocked by "QueueRunLevel"
8342  CanRunQueue := (FCommandQueue.Count = 0)
8343    or ( (FCommandQueue.Count > 0)
8344        and (FCommandQueue[0].QueueRunLevel >= 0)
8345        and (FCommandQueue[0].QueueRunLevel < FInExecuteCount)
8346       )
8347    or ( (p > FCommandQueue[0].Priority) and (FCommandQueueExecLock = 0) );
8348
8349  if (ACommand is TGDBMIDebuggerCommandExecute) then begin
8350    // Execute-commands, must be queued at the end. They have QueueRunLevel, so they only run in the outer loop
8351    CanRunQueue := (FCommandQueue.Count = 0);
8352    i := FCommandQueue.Add(ACommand);
8353  end
8354  else
8355  if p > 0 then begin
8356    // Queue Pririty commands
8357    // TODO: check for "CanRunQueue": should be at start?
8358    while (i < FCommandQueue.Count)
8359    and (FCommandQueue[i].Priority >= p)
8360    and ( (ForceQueue)
8361       or (FCommandQueue[i].QueueRunLevel < 0)
8362       or (FCommandQueue[i].QueueRunLevel >= FInExecuteCount)
8363        )
8364    do inc(i);
8365    FCommandQueue.Insert(i, ACommand);
8366  end
8367  else begin
8368    // Queue normal commands
8369    if (not ForceQueue) and (FCommandQueue.Count > 0)
8370    and CanRunQueue  // first item is deferred, so new item inserted can run
8371    then
8372      FCommandQueue.Insert(0, ACommand)
8373    else
8374      i := FCommandQueue.Add(ACommand);
8375  end;
8376
8377  // if other commands do run the queue,
8378  // make sure this command only runs after the CurrentCommand finished
8379  if ForceQueue and
8380    ( (ACommand.QueueRunLevel < 0) or (ACommand.QueueRunLevel >= FInExecuteCount) )
8381  then
8382    ACommand.QueueRunLevel := FInExecuteCount - 1;
8383
8384  if (not CanRunQueue) or (FCommandQueueExecLock > 0)
8385  or (FCommandProcessingLock > 0) or ForceQueue
8386  then begin
8387    debugln(DBGMI_QUEUE_DEBUG, ['Queueing (Recurse-Count=', FInExecuteCount, ') at pos=', i, ' cnt=',FCommandQueue.Count-1, ' State=',dbgs(State), ' Lock=',FCommandQueueExecLock, ' Forced=', dbgs(ForceQueue), ' Prior=',p, ': "', ACommand.DebugText,'"']);
8388    ACommand.DoQueued;
8389
8390    // FCommandProcessingLock still must call RunQueue
8391    if FCommandProcessingLock = 0 then
8392      Exit;
8393  end;
8394
8395  // If we are here we can process the command directly
8396  RunQueue;
8397end;
8398
8399procedure TGDBMIDebugger.UnQueueCommand(const ACommand: TGDBMIDebuggerCommand);
8400begin
8401  FCommandQueue.Remove(ACommand);
8402end;
8403
8404procedure TGDBMIDebugger.CancelAllQueued;
8405var
8406  i: Integer;
8407begin
8408  i := FCommandQueue.Count - 1;
8409  while i >= 0 do begin
8410    TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
8411    dec(i);
8412    if i >= FCommandQueue.Count
8413    then i := FCommandQueue.Count - 1;
8414  end;
8415  if FCurrentCommand <> nil
8416  then FCurrentCommand.Cancel;
8417end;
8418
8419procedure TGDBMIDebugger.CancelBeforeRun;
8420var
8421  i: Integer;
8422begin
8423  i := FCommandQueue.Count - 1;
8424  while i >= 0 do begin
8425    if dcpCancelOnRun in TGDBMIDebuggerCommand(FCommandQueue[i]).Properties
8426    then TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
8427    dec(i);
8428    if i >= FCommandQueue.Count
8429    then i := FCommandQueue.Count - 1;
8430  end;
8431  if (FCurrentCommand <> nil) and (dcpCancelOnRun in FCurrentCommand.Properties)
8432  then FCurrentCommand.Cancel;
8433end;
8434
8435procedure TGDBMIDebugger.CancelAfterStop;
8436var
8437  i: Integer;
8438begin
8439  i := FCommandQueue.Count - 1;
8440  while i >= 0 do begin
8441    if TGDBMIDebuggerCommand(FCommandQueue[i]) is TGDBMIDebuggerCommandExecute
8442    then TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
8443    dec(i);
8444    if i >= FCommandQueue.Count
8445    then i := FCommandQueue.Count - 1;
8446  end;
8447  // do not cancel FCurrentCommand;
8448end;
8449
8450procedure TGDBMIDebugger.RunQueueASync;
8451begin
8452  Application.QueueAsyncCall(@DoRunQueueFromASync, 0);
8453end;
8454
8455procedure TGDBMIDebugger.RemoveRunQueueASync;
8456begin
8457  Application.RemoveAsyncCalls(Self);
8458end;
8459
8460procedure TGDBMIDebugger.DoRunQueueFromASync(Data: PtrInt);
8461begin
8462  DebugLnEnter(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.DoRunQueueFromASync: Execute RunQueue ']);
8463  RunQueue;
8464  DebugLnExit(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.DoRunQueueFromASync: Finished RunQueue']);
8465end;
8466
8467class function TGDBMIDebugger.ExePaths: String;
8468begin
8469  {$IFdef MSWindows}
8470  Result := '$(LazarusDir)\mingw\$(TargetCPU)-$(TargetOS)\bin\gdb.exe;$(LazarusDir)\mingw\bin\gdb.exe;C:\lazarus\mingw\bin\gdb.exe';
8471  {$ELSE}
8472  Result := 'gdb;/usr/bin/gdb;/usr/local/bin/gdb;/opt/fpc/gdb';
8473  {$ENDIF}
8474end;
8475
8476function TGDBMIDebugger.FindBreakpoint(
8477  const ABreakpoint: Integer): TDBGBreakPoint;
8478var
8479  n: Integer;
8480begin
8481  if  ABreakpoint > 0
8482  then
8483    for n := 0 to Breakpoints.Count - 1 do
8484    begin
8485      Result := Breakpoints[n];
8486      if TGDBMIBreakPoint(Result).FBreakID = ABreakpoint
8487      then Exit;
8488    end;
8489  Result := nil;
8490end;
8491
8492function PosSetEx(const ASubStrSet, AString: string;
8493  const Offset: integer): integer;
8494begin
8495  for Result := Offset to Length(AString) do
8496    if Pos(AString[Result], ASubStrSet) > 0 then
8497      exit;
8498  Result := 0;
8499end;
8500
8501function EscapeGDBCommand(const AInput: string): string;
8502var
8503  lPiece: string;
8504  I, lPos, len: integer;
8505begin
8506  lPos := 1;
8507  Result := '';
8508  repeat
8509    I := PosSetEx(#9#10#13, AInput, lPos);
8510    { copy unmatched characters }
8511    if I > 0 then
8512      len := I-lPos
8513    else
8514      len := Length(AInput)+1-lPos;
8515    Result := Result + Copy(AInput, lPos, len);
8516    { replace a matched character or be done }
8517    if I > 0 then
8518    begin
8519      case AInput[I] of
8520        #9:  lPiece := '\t';
8521        #10: lPiece := '\n';
8522        #13: lPiece := '\r';
8523      else
8524        lPiece := '';
8525      end;
8526      Result := Result + lPiece;
8527      lPos := I+1;
8528    end else
8529      exit;
8530  until false;
8531end;
8532
8533function TGDBMIDebugger.GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean;
8534  out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
8535var
8536  NewEntryMap: TDBGDisassemblerEntryMap;
8537  CmdObj: TGDBMIDebuggerCommandDisassemble;
8538  Rng: TDBGDisassemblerEntryRange;
8539  i: Integer;
8540begin
8541  NewEntryMap := TDBGDisassemblerEntryMap.Create(itu8, SizeOf(TDBGDisassemblerEntryRange));
8542  CmdObj := TGDBMIDebuggerCommandDisassemble.Create(Self, NewEntryMap, AAddr, AAddr, -1, 2);
8543  CmdObj.AddReference;
8544  CmdObj.Priority := GDCMD_PRIOR_IMMEDIATE;
8545  QueueCommand(CmdObj);
8546  Result := CmdObj.State in [dcsExecuting, dcsFinished];
8547
8548  Rng := NewEntryMap.GetRangeForAddr(AAddr);
8549  if Result and (Rng <> nil)
8550  then begin
8551    i := Rng.IndexOfAddr(AAddr);
8552    if ABackward
8553    then dec(i);
8554
8555    if
8556    i >= 0
8557    then begin
8558      if i < Rng.Count
8559      then ANextAddr := Rng.EntriesPtr[i]^.Addr
8560      else ANextAddr := Rng.LastEntryEndAddr;
8561
8562      ADump := Rng.EntriesPtr[i]^.Dump;
8563      AStatement := Rng.EntriesPtr[i]^.Statement;
8564      AFile := Rng.EntriesPtr[i]^.SrcFileName;
8565      ALine := Rng.EntriesPtr[i]^.SrcFileLine;
8566    end;
8567  end;
8568
8569  if not Result
8570  then CmdObj.Cancel;
8571
8572  CmdObj.ReleaseReference;
8573  FreeAndNil(NewEntryMap);
8574end;
8575
8576procedure TGDBMIDebugger.DoPseudoTerminalRead(Sender: TObject);
8577begin
8578  {$IFDEF DBG_ENABLE_TERMINAL}
8579  if assigned(OnConsoleOutput)
8580  then OnConsoleOutput(self, FPseudoTerminal.Read);
8581  {$ENDIF}
8582end;
8583
8584function TGDBMIDebugger.GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
8585var
8586  S: String;
8587begin
8588  Result := True;
8589
8590  if State = dsRun
8591  then GDBPause(True);
8592  if ASet then
8593  begin
8594    S := EscapeGDBCommand(AVariable);
8595    ExecuteCommand('-gdb-set env %s', [S], [cfscIgnoreState, cfNoThreadContext]);
8596  end else begin
8597    S := AVariable;
8598    ExecuteCommand('unset env %s', [GetPart([], ['='], S, False, False)], [cfscIgnoreState, cfNoThreadContext]);
8599  end;
8600end;
8601
8602procedure TGDBMIDebugger.GDBEvaluateCommandCancelled(Sender: TObject);
8603begin
8604  TGDBMIDebuggerCommandEvaluate(Sender).Callback(Self, False, '', nil);
8605end;
8606
8607procedure TGDBMIDebugger.GDBEvaluateCommandExecuted(Sender: TObject);
8608begin
8609  if TGDBMIDebuggerCommandEvaluate(Sender).EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
8610  then FreeAndNil(TGDBMIDebuggerCommandEvaluate(Sender).FTypeInfo);
8611  with TGDBMIDebuggerCommandEvaluate(Sender) do
8612    Callback(Self, True, TextValue, TypeInfo);
8613end;
8614
8615function TGDBMIDebugger.GDBEvaluate(const AExpression: String;
8616  EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
8617var
8618  CommandObj: TGDBMIDebuggerCommandEvaluate;
8619begin
8620  CommandObj := TGDBMIDebuggerCommandEvaluate.Create(Self, AExpression, wdfDefault);
8621  CommandObj.EvalFlags := EvalFlags;
8622  CommandObj.AddReference;
8623  CommandObj.Priority := GDCMD_PRIOR_IMMEDIATE; // try run imediately
8624  CommandObj.Callback := ACallback;
8625  CommandObj.OnExecuted := @GDBEvaluateCommandExecuted;
8626  CommandObj.OnCancel := @GDBEvaluateCommandCancelled;
8627  QueueCommand(CommandObj);
8628  CommandObj.ReleaseReference;
8629  Result := true;
8630end;
8631
8632function TGDBMIDebugger.GDBModify(const AExpression, ANewValue: String): Boolean;
8633var
8634  R: TGDBMIExecResult;
8635  S: String;
8636begin
8637  S := Trim(ANewValue);
8638  if (S <> '') and (S[1] in ['''', '#'])
8639  then begin
8640    if not ConvertPascalExpression(S) then Exit(False);
8641  end;
8642
8643  R := GDBMIExecResultDefault;
8644  Result := ExecuteCommandFull('-gdb-set var %s := %s', [UpperCaseSymbols(AExpression), S], [cfscIgnoreError], @GDBModifyDone, 0, R)
8645        and (R.State <> dsError);
8646
8647  FTypeRequestCache.Clear;
8648end;
8649
8650procedure TGDBMIDebugger.GDBModifyDone(const AResult: TGDBMIExecResult;
8651  const ATag: PtrInt);
8652begin
8653  FTypeRequestCache.Clear;
8654  TGDBMILocals(Locals).Changed;
8655  TGDBMIWatches(Watches).Changed;
8656end;
8657
8658function TGDBMIDebugger.GDBJumpTo(const ASource: String; const ALine: Integer): Boolean;
8659begin
8660  Result := False;
8661end;
8662
8663function TGDBMIDebugger.GDBAttach(AProcessID: String): Boolean;
8664var
8665  Cmd: TGDBMIDebuggerCommandAttach;
8666begin
8667  Result := False;
8668  if State <> dsStop then exit;
8669
8670  Cmd := TGDBMIDebuggerCommandAttach.Create(Self, AProcessID);
8671  Cmd.AddReference;
8672  QueueCommand(Cmd);
8673  Result := Cmd.Success;
8674  if not Result
8675  then Cmd.Cancel;
8676  Cmd.ReleaseReference;
8677end;
8678
8679function TGDBMIDebugger.GDBDetach: Boolean;
8680begin
8681  Result := False;
8682
8683  if State = dsRun
8684  then GDBPause(True);
8685
8686  CancelAllQueued;
8687  QueueCommand(TGDBMIDebuggerCommandDetach.Create(Self));
8688  Result := True;
8689end;
8690
8691function TGDBMIDebugger.GDBPause(const AInternal: Boolean): Boolean;
8692begin
8693  if FInProcessStopped then exit;
8694
8695  // Check if we already issued a break
8696  if FPauseWaitState = pwsNone
8697  then InterruptTarget;
8698
8699  if AInternal
8700  then begin
8701    if FPauseWaitState = pwsNone
8702    then FPauseWaitState := pwsInternal;
8703  end
8704  else FPauseWaitState := pwsExternal;
8705
8706  Result := True;
8707end;
8708
8709function TGDBMIDebugger.GDBRun: Boolean;
8710begin
8711  Result := False;
8712  case State of
8713    dsStop: begin
8714      FThreadGroups.Clear;
8715      Result := StartDebugging(ectContinue);
8716    end;
8717    dsPause: begin
8718      CancelBeforeRun;
8719      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectContinue));
8720      Result := True;
8721    end;
8722    dsIdle: begin
8723      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to run in idle state');
8724    end;
8725  end;
8726end;
8727
8728function TGDBMIDebugger.GDBRunTo(const ASource: String;
8729  const ALine: Integer): Boolean;
8730begin
8731  Result := False;
8732  case State of
8733    dsStop: begin
8734      Result := False;
8735    end;
8736    dsPause: begin
8737      CancelBeforeRun;
8738      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectRunTo, [ASource, ALine]));
8739      Result := True;
8740    end;
8741    dsIdle: begin
8742      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to runto in idle state');
8743    end;
8744  end;
8745
8746end;
8747
8748function TGDBMIDebugger.GDBSourceAdress(const ASource: String; ALine, AColumn: Integer; out AAddr: TDbgPtr): Boolean;
8749var
8750  ID: packed record
8751    Line, Column: Integer;
8752  end;
8753  Map: TMap;
8754  idx, n: Integer;
8755  R: TGDBMIExecResult;
8756  LinesList, LineList: TGDBMINameValueList;
8757  Item: PGDBMINameValue;
8758  Addr: TDbgPtr;
8759begin
8760  Result := False;
8761  AAddr := 0;
8762  if ASource = ''
8763  then Exit;
8764  idx := FSourceNames.IndexOf(ASource);
8765  if (idx <> -1)
8766  then begin
8767    Map := TMap(FSourceNames.Objects[idx]);
8768    ID.Line := ALine;
8769    // since we do not have column info we map all on column 0
8770    // ID.Column := AColumn;
8771    ID.Column := 0;
8772    Result := (Map <> nil);
8773    if Result
8774    then Map.GetData(ID, AAddr);
8775    Exit;
8776  end;
8777
8778  R := GDBMIExecResultDefault;
8779  Result := ExecuteCommand('-symbol-list-lines %s', [ASource], [cfscIgnoreError, cfNoThreadContext], R)
8780        and (R.State <> dsError);
8781  // if we have an .inc file then search for filename only since there are some
8782  // problems with locating file by full path in gdb in case only relative file
8783  // name is stored
8784  if not Result then
8785    Result := ExecuteCommand('-symbol-list-lines %s', [ExtractFileName(ASource)], [cfscIgnoreError, cfNoThreadContext], R)
8786          and (R.State <> dsError);
8787
8788  if not Result then Exit;
8789
8790  Map := TMap.Create(its8, SizeOf(AAddr));
8791  FSourceNames.AddObject(ASource, Map);
8792
8793  LinesList := TGDBMINameValueList.Create(R, ['lines']);
8794  if LinesList = nil then Exit(False);
8795
8796  ID.Column := 0;
8797  LineList := TGDBMINameValueList.Create('');
8798
8799  for n := 0 to LinesList.Count - 1 do
8800  begin
8801    Item := LinesList.Items[n];
8802    LineList.Init(Item^.Name);
8803    if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
8804    if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
8805    // one line can have more than one address
8806    if Map.HasId(ID) then Continue;
8807    Map.Add(ID, Addr);
8808    if ID.Line = ALine
8809    then AAddr := Addr;
8810  end;
8811  LineList.Free;
8812  LinesList.Free;
8813end;
8814
8815function TGDBMIDebugger.GDBStepInto: Boolean;
8816begin
8817  Result := False;
8818  case State of
8819    dsStop: begin
8820      Result := StartDebugging;
8821    end;
8822    dsPause: begin
8823      CancelBeforeRun;
8824      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepInto));
8825      Result := True;
8826    end;
8827    dsIdle: begin
8828      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step in idle state');
8829    end;
8830  end;
8831end;
8832
8833function TGDBMIDebugger.GDBStepOverInstr: Boolean;
8834begin
8835  Result := False;
8836  case State of
8837    dsStop: begin
8838      Result := StartDebugging;
8839    end;
8840    dsPause: begin
8841      CancelBeforeRun;
8842      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOverInstruction));
8843      Result := True;
8844    end;
8845    dsIdle: begin
8846      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step over instr in idle state');
8847    end;
8848  end;
8849end;
8850
8851function TGDBMIDebugger.GDBStepIntoInstr: Boolean;
8852begin
8853  Result := False;
8854  case State of
8855    dsStop: begin
8856      Result := StartDebugging;
8857    end;
8858    dsPause: begin
8859      CancelBeforeRun;
8860      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepIntoInstruction));
8861      Result := True;
8862    end;
8863    dsIdle: begin
8864      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step in instr idle state');
8865    end;
8866  end;
8867end;
8868
8869function TGDBMIDebugger.GDBStepOut: Boolean;
8870begin
8871  Result := False;
8872  case State of
8873    dsStop: begin
8874      Result := False;
8875    end;
8876    dsPause: begin
8877      CancelBeforeRun;
8878      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOut));
8879      Result := True;
8880    end;
8881    dsIdle: begin
8882      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step out in idle state');
8883    end;
8884  end;
8885end;
8886
8887function TGDBMIDebugger.GDBStepOver: Boolean;
8888begin
8889  Result := False;
8890  case State of
8891    dsStop: begin
8892      Result := StartDebugging;
8893    end;
8894    dsPause: begin
8895      CancelBeforeRun;
8896      QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOver));
8897      Result := True;
8898    end;
8899    dsIdle: begin
8900      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step over in idle state');
8901    end;
8902  end;
8903end;
8904
8905function TGDBMIDebugger.GDBStop: Boolean;
8906begin
8907  if State = dsError
8908  then begin
8909    // We don't know the state of the debugger,
8910    // force a reinit. Let's hope this works.
8911    TerminateGDB;
8912    Done;
8913    Result := True;
8914    Exit;
8915  end;
8916
8917  if (FCurrentCommand <> nil) and FCurrentCommand.KillNow then begin
8918    debugln(DBG_VERBOSE, ['KillNow did stop']);
8919    Result := True;
8920    exit;
8921  end;
8922
8923  if State = dsRun
8924  then GDBPause(True);
8925
8926  CancelAllQueued;
8927  QueueCommand(TGDBMIDebuggerCommandKill.Create(Self));
8928  Result := True;
8929end;
8930
8931function TGDBMIDebugger.GetSupportedCommands: TDBGCommands;
8932begin
8933  Result := [dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcStepOut,
8934             dcStepOverInstr, dcStepIntoInstr, dcRunTo, dcAttach, dcDetach, dcJumpto,
8935             dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment,
8936             dcSetStackFrame, dcDisassemble
8937             {$IFDEF DBG_ENABLE_TERMINAL}, dcSendConsoleInput{$ENDIF}
8938            ];
8939end;
8940
8941function TGDBMIDebugger.GetCommands: TDBGCommands;
8942begin
8943  if FNeedStateToIdle
8944  then Result := []
8945  else Result := inherited GetCommands;
8946end;
8947
8948function TGDBMIDebugger.GetTargetWidth: Byte;
8949begin
8950  Result := FTargetInfo.TargetPtrSize*8;
8951end;
8952
8953procedure TGDBMIDebugger.Init;
8954
8955  procedure CheckGDBVersion;
8956  begin
8957    if FGDBVersion < '5.3'
8958    then begin
8959      DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Running an old (< 5.3) GDB version: ', FGDBVersion);
8960      DebugLn(DBG_WARNINGS, '                    Not all functionality will be supported.');
8961    end
8962    else begin
8963      DebugLn(DBG_VERBOSE, '[Debugger] Running GDB version: ', FGDBVersion);
8964      Include(FDebuggerFlags, dfImplicidTypes);
8965    end;
8966  end;
8967
8968var
8969  Options: String;
8970  Cmd: TGDBMIDebuggerCommandInitDebugger;
8971  env: TStringList;
8972begin
8973  Exclude(FDebuggerFlags, dfForceBreakDetected);
8974  Exclude(FDebuggerFlags, dfSetBreakFailed);
8975  Exclude(FDebuggerFlags, dfSetBreakPending);
8976  LockRelease;
8977  try
8978    FPauseWaitState := pwsNone;
8979    FErrorHandlingFlags := [];
8980    FInExecuteCount := 0;
8981    FInIdle := False;
8982    FNeedStateToIdle := False;
8983    Options := '-silent -i mi -nx';
8984
8985    if Length(TGDBMIDebuggerPropertiesBase(GetProperties).Debugger_Startup_Options) > 0
8986    then Options := Options + ' ' + TGDBMIDebuggerPropertiesBase(GetProperties).Debugger_Startup_Options;
8987
8988    env := EnvironmentAsStringList;
8989    DebuggerEnvironment := env;
8990    env.Free;
8991{$ifNdef MSWindows}
8992    DebuggerEnvironment.Values['LANG'] := 'C'; // try to prevent GDB from using localized messages
8993{$ENDIF}
8994
8995    if CreateDebugProcess(Options)
8996    then begin
8997      if not ParseInitialization
8998      then begin
8999        SetState(dsError);
9000      end
9001      else begin
9002        Cmd :=  CreateCommandInit;
9003        Cmd.AddReference;
9004        QueueCommand(Cmd);
9005        if not Cmd.Success then begin
9006          Cmd.Cancel;
9007          Cmd.ReleaseReference;
9008          SetState(dsError);
9009        end
9010        else begin
9011          Cmd.ReleaseReference;
9012          CheckGDBVersion;
9013          inherited Init;
9014        end;
9015      end;
9016    end
9017    else begin
9018      include(FErrorHandlingFlags, ehfDeferReadWriteError);
9019      SetErrorState(gdbmiFailedToLaunchExternalDbg, ReadLine(50));
9020    end;
9021
9022    FGDBPtrSize := CpuNameToPtrSize(FGDBCPU); // will be set in StartDebugging
9023  finally
9024    UnlockRelease;
9025  end;
9026end;
9027
9028procedure TGDBMIDebugger.InterruptTarget;
9029{$IFdef MSWindows}
9030  function TryNT: Boolean;
9031  var
9032    hProcess: THandle;
9033    hThread: THandle;
9034    E: Integer;
9035    Emsg: PChar;
9036  begin
9037    Result := False;
9038
9039    hProcess := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_WRITE or PROCESS_VM_READ, False, TargetPID);
9040    if hProcess = 0 then Exit;
9041
9042    try
9043      hThread := _CreateRemoteThread(hProcess, nil, 0, DebugBreakAddr, nil, 0, FPauseRequestInThreadID);
9044      if hThread = 0
9045      then begin
9046        E := GetLastError;
9047        FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, E, 0, PChar(@Emsg), 0, nil);
9048        DebugLN(DBG_WARNINGS, 'Error creating remote thread: ' + String(EMsg));
9049        // Yuck !
9050        // mixing handles and pointers, but it is how MS documented it
9051        LocalFree(HLOCAL(Emsg));
9052        Exit;
9053      end;
9054      Result := True;
9055      CloseHandle(hThread);
9056    finally
9057      CloseHandle(hProcess);
9058    end;
9059  end;
9060{$ENDIF}
9061begin
9062  debugln(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.InterruptTarget: TargetPID=', TargetPID]);
9063
9064  //if FAsyncModeEnabled then begin
9065  if FCurrentCmdIsAsync and (FCurrentCommand <> nil) then begin
9066    FCurrentCommand.ExecuteCommand('interrupt', [cfNoThreadContext]);
9067    FCurrentCommand.ExecuteCommand('info program', [cfNoThreadContext]); // trigger "*stopped..." msg. This may be deferred to the cmd after the "interupt"
9068    exit;
9069  end;
9070
9071  if TargetPID = 0 then Exit;
9072{$IFDEF UNIX}
9073  FpKill(TargetPID, SIGINT);
9074{$ENDIF}
9075
9076{$IFdef MSWindows}
9077  // GenerateConsoleCtrlEvent is nice, but only works if both gdb and
9078  // our target have a console. On win95 and family this is our only
9079  // option, on NT4+ we have a choice. Since this is not likely that
9080  // we have a console, we do it the hard way. On XP there exists
9081  // DebugBreakProcess, but it does efectively the same.
9082
9083  if (DebugBreakAddr = nil)
9084  or not Assigned(_CreateRemoteThread)
9085  or not TryNT
9086  then begin
9087    // We have no other choice than trying this
9088    debugln(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.InterruptTarget: Send CTRL_BREAK_EVENT']);
9089    GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, TargetPID);
9090    Exit;
9091  end;
9092{$ENDIF}
9093end;
9094
9095function TGDBMIDebugger.ParseInitialization: Boolean;
9096var
9097  Line, S: String;
9098begin
9099  Result := True;
9100
9101  // Get initial debugger lines
9102  S := '';
9103  Line := ReadLine;
9104  while DebugProcessRunning and (Line <> '(gdb) ') and (State <> dsError) do
9105  begin
9106    if Line <> ''
9107    then
9108      case Line[1] of
9109        '=': begin
9110          case StringCase(GetPart(['='], [','], Line, False, False),
9111            ['thread-group-added'])
9112          of
9113            0: {ignore};
9114          else
9115            S := S + Line + LineEnding;
9116          end;
9117        end;
9118      else
9119        S := S + Line + LineEnding;
9120      end;
9121    Line := ReadLine;
9122  end;
9123  if S <> ''
9124  then MessageDlg('Debugger', 'Initialization output: ' + LineEnding + S,
9125    mtInformation, [mbOK], 0);
9126end;
9127
9128function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand;
9129  const AParams: array of const; const ACallback: TMethod): Boolean;
9130var
9131  EvalFlags: TDBGEvaluateFlags;
9132begin
9133  LockRelease;
9134  try
9135    case ACommand of
9136      dcRun:         Result := GDBRun;
9137      dcPause:       Result := GDBPause(False);
9138      dcStop:        Result := GDBStop;
9139      dcStepOver:    Result := GDBStepOver;
9140      dcStepInto:    Result := GDBStepInto;
9141      dcStepOut:     Result := GDBStepOut;
9142      dcRunTo:       Result := GDBRunTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
9143      dcJumpto:      Result := GDBJumpTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
9144      dcAttach:      Result := GDBAttach(String(AParams[0].VAnsiString));
9145      dcDetach:      Result := GDBDetach;
9146      dcEvaluate:    begin
9147                       EvalFlags := [];
9148                       if high(AParams) >= 1 then
9149                         EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
9150                       Result := GDBEvaluate(String(AParams[0].VAnsiString),
9151                         EvalFlags, TDBGEvaluateResultCallback(ACallback));
9152                     end;
9153      dcModify:      Result := GDBModify(String(AParams[0].VAnsiString), String(AParams[1].VAnsiString));
9154      dcEnvironment: Result := GDBEnvironment(String(AParams[0].VAnsiString), AParams[1].VBoolean);
9155      dcDisassemble: Result := GDBDisassemble(AParams[0].VQWord^, AParams[1].VBoolean, TDbgPtr(AParams[2].VPointer^),
9156                                              String(AParams[3].VPointer^), String(AParams[4].VPointer^),
9157                                              String(AParams[5].VPointer^), Integer(AParams[6].VPointer^))
9158                                              {%H-};
9159      dcStepOverInstr: Result := GDBStepOverInstr;
9160      dcStepIntoInstr: Result := GDBStepIntoInstr;
9161      {$IFDEF DBG_ENABLE_TERMINAL}
9162      dcSendConsoleInput: FPseudoTerminal.Write(String(AParams[0].VAnsiString));
9163      {$ENDIF}
9164    end;
9165  finally
9166    UnlockRelease;
9167  end;
9168end;
9169
9170procedure TGDBMIDebugger.ClearCommandQueue;
9171var
9172  i: Integer;
9173begin
9174  for i:=0 to FCommandQueue.Count-1 do begin
9175    TGDBMIDebuggerCommand(FCommandQueue[i]).ReleaseReference;
9176  end;
9177  FCommandQueue.Clear;
9178end;
9179
9180function TGDBMIDebugger.GetIsIdle: Boolean;
9181begin
9182  Result := (FCommandQueue.Count = 0) and (State in [dsPause, dsInternalPause]);
9183end;
9184
9185procedure TGDBMIDebugger.ResetStateToIdle;
9186begin
9187  if FInExecuteCount > 0 then begin
9188    debugln(DBGMI_QUEUE_DEBUG, ['Defer dsIdle:  Recurse-Count=', FInExecuteCount]);
9189    FNeedStateToIdle := True;
9190    exit;
9191  end;
9192  FNeedStateToIdle := False;
9193  inherited ResetStateToIdle;
9194end;
9195
9196procedure TGDBMIDebugger.ClearSourceInfo;
9197var
9198  n: Integer;
9199begin
9200  for n := 0 to FSourceNames.Count - 1 do
9201    FSourceNames.Objects[n].Free;
9202
9203  FSourceNames.Clear;
9204end;
9205
9206function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIExecCommandType): Boolean;
9207begin
9208  Result := StartDebugging(TGDBMIDebuggerCommandExecute.Create(Self, AContinueCommand));
9209end;
9210
9211function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIExecCommandType;
9212  AValues: array of const): Boolean;
9213begin
9214  Result := StartDebugging(TGDBMIDebuggerCommandExecute.Create(Self, AContinueCommand, AValues));
9215end;
9216
9217function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
9218var
9219  Cmd: TGDBMIDebuggerCommandStartDebugging;
9220begin
9221  // We expect to be run immediately, no queue
9222  FCurrentStackFrameValid := False;
9223  FCurrentThreadIdValid   := False;
9224  Cmd := CreateCommandStartDebugging(AContinueCommand);
9225  Cmd.AddReference;
9226  QueueCommand(Cmd);
9227  Result := Cmd.Success;
9228  if not Result
9229  then Cmd.Cancel;
9230  Cmd.ReleaseReference;
9231end;
9232
9233procedure TGDBMIDebugger.TerminateGDB;
9234begin
9235  AbortReadLine;
9236  FPauseWaitState := pwsNone;
9237  if DebugProcessRunning then begin
9238    debugln(DBG_VERBOSE, ['TGDBMIDebugger.TerminateGDB ']);
9239    if not DebugProcess.Terminate(0) then begin
9240      if OnFeedback = nil then
9241        MessageDlg(gdbmiFailedToTerminateGDBTitle,
9242                   Format(gdbmiFailedToTerminateGDB, [LineEnding]), mtError, [mbOK], 0)
9243      else
9244        OnFeedback(Self,
9245              Format(gdbmiFailedToTerminateGDB, [LineEnding]),
9246              '',
9247              ftError, [frOk]
9248            );
9249      SetState(dsError);
9250    end;
9251  end;
9252end;
9253
9254{$IFDEF DBG_ENABLE_TERMINAL}
9255procedure TGDBMIDebugger.ProcessWhileWaitForHandles;
9256begin
9257  inherited ProcessWhileWaitForHandles;
9258  FPseudoTerminal.CheckCanRead;
9259end;
9260
9261function TGDBMIDebugger.GetPseudoTerminal: TPseudoTerminal;
9262begin
9263  Result := FPseudoTerminal;
9264end;
9265{$ENDIF}
9266
9267procedure TGDBMIDebugger.QueueExecuteLock;
9268begin
9269  inc(FCommandQueueExecLock);
9270end;
9271
9272procedure TGDBMIDebugger.QueueExecuteUnlock;
9273begin
9274  dec(FCommandQueueExecLock);
9275end;
9276
9277procedure TGDBMIDebugger.TestCmd(const ACommand: String);
9278begin
9279  ExecuteCommand(ACommand, [], [cfscIgnoreError]);
9280end;
9281
9282function TGDBMIDebugger.NeedReset: Boolean;
9283begin
9284  Result := FNeedReset;
9285end;
9286
9287{%region      *****  BreakPoints  *****  }
9288
9289{ TGDBMIDebuggerCommandBreakPointBase }
9290
9291function TGDBMIDebuggerCommandBreakPointBase.ExecCheckLineInUnit(ASource: string;
9292  ALine: Integer): Boolean;
9293var
9294  R: TGDBMIExecResult;
9295  i, m, n: Integer;
9296begin
9297  Result := ALine > 0;
9298  if not Result then exit;
9299
9300  m := -1;
9301  i := FTheDebugger.FMaxLineForUnitCache.IndexOf(ASource);
9302  if i >= 0 then
9303    m := PtrInt(FTheDebugger.FMaxLineForUnitCache.Objects[i]);
9304
9305  if ALine <= m then exit;;
9306
9307  if ExecuteCommand('info line "' + ASource + '":' + IntToStr(ALine), R)
9308  and (R.State <> dsError)
9309  then begin
9310    m := pos('"', R.Values);  // find start of filename in messages
9311    n := pos('out of range', R.Values);
9312    Result := (n < 1) or (n >= m);
9313  end;
9314
9315  if not Result then exit;
9316
9317  if i < 0 then
9318    i := FTheDebugger.FMaxLineForUnitCache.Add(ASource);
9319  FTheDebugger.FMaxLineForUnitCache.Objects[i] := TObject(PtrInt(ALine));
9320end;
9321
9322function TGDBMIDebuggerCommandBreakPointBase.ExecBreakDelete(ABreakId: Integer): Boolean;
9323begin
9324  Result := False;
9325  if ABreakID = 0 then Exit;
9326
9327  Result := ExecuteCommand('-break-delete %d', [ABreakID], []);
9328end;
9329
9330function TGDBMIDebuggerCommandBreakPointBase.ExecBreakEnabled(ABreakId: Integer;
9331  AnEnabled: Boolean): Boolean;
9332const
9333  // Use shortstring as fix for fpc 1.9.5 [2004/07/15]
9334  CMD: array[Boolean] of ShortString = ('disable', 'enable');
9335begin
9336  Result := False;
9337  if ABreakID = 0 then Exit;
9338
9339  Result := ExecuteCommand('-break-%s %d', [CMD[AnEnabled], ABreakID], []);
9340end;
9341
9342function TGDBMIDebuggerCommandBreakPointBase.ExecBreakCondition(ABreakId: Integer;
9343  AnExpression: string): Boolean;
9344begin
9345  Result := False;
9346  if ABreakID = 0 then Exit;
9347
9348  Result := ExecuteCommand('-break-condition %d %s', [ABreakID, UpperCaseSymbols(AnExpression)], []);
9349end;
9350
9351{ TGDBMIDebuggerCommandBreakInsert }
9352
9353function TGDBMIDebuggerCommandBreakInsert.ExecBreakInsert(out ABreakId,
9354  AHitCnt: Integer; out AnAddr: TDBGPtr; out APending: Boolean): Boolean;
9355var
9356  R: TGDBMIExecResult;
9357  ResultList: TGDBMINameValueList;
9358  WatchExpr, WatchDecl, WatchAddr: String;
9359  s1, s2: String;
9360begin
9361  Result := False;
9362  ABreakId := 0;
9363  AHitCnt := 0;
9364  AnAddr := 0;
9365  APending := False;
9366  case FKind of
9367    bpkSource:
9368      begin
9369        if (FSource = '') or (FLine < 0) then exit;
9370        Result := ExecCheckLineInUnit(FSource, FLine);
9371        if not Result then exit;
9372
9373        s1 := '';
9374        s2 := StringReplace(FSource, '\', '/', [rfReplaceAll]);
9375        //s2 := StringReplace(s2, '"', '\"', [rfReplaceAll]);
9376        Result := ExecuteCommand('-break-insert %s "\"%s\":%d"',    [s1, s2, FLine], R);
9377
9378        if dfForceBreak in FTheDebugger.FDebuggerFlags then s1 := '-f';
9379        if (not Result) or (R.State = dsError) then
9380          Result := ExecuteCommand('-break-insert %s %s:%d',    [s1, ExtractFileName(FSource), FLine], R);
9381      end;
9382    bpkAddress:
9383      begin
9384        if (FAddress = 0) then exit;
9385        if dfForceBreak in FTheDebugger.FDebuggerFlags
9386        then Result := ExecuteCommand('-break-insert -f *%u', [FAddress], R)
9387        else Result := ExecuteCommand('-break-insert *%u',    [FAddress], R);
9388      end;
9389    bpkData:
9390      begin
9391        if (FWatchData = '') then exit;
9392        WatchExpr := UpperCaseSymbols(WatchData);
9393        if FWatchScope = wpsGlobal then begin
9394          Result := ExecuteCommand('ptype %s', [WatchExpr], R);
9395          Result := Result and (R.State <> dsError);
9396          if not Result then exit;
9397          WatchDecl := PCLenToString(ParseTypeFromGdb(R.Values).Name);
9398          Result := ExecuteCommand('-data-evaluate-expression %s', [Quote('@'+WatchExpr)], R);
9399          Result := Result and (R.State <> dsError);
9400          if not Result then exit;
9401          WatchAddr := StripLN(GetPart('value="', '"', R.Values));
9402          WatchExpr := WatchDecl+'(' + WatchAddr + '^)';
9403        end;
9404        case FWatchKind of
9405          wpkWrite:     Result := ExecuteCommand('-break-watch %s', [WatchExpr], R);
9406          wpkRead:      Result := ExecuteCommand('-break-watch -r %s', [WatchExpr], R);
9407          wpkReadWrite: Result := ExecuteCommand('-break-watch -a %s', [WatchExpr], R);
9408        end;
9409        Result := Result and (R.State <> dsError);
9410      end;
9411  end;
9412
9413  ResultList := TGDBMINameValueList.Create(R);
9414  case FKind of
9415    bpkSource, bpkAddress:
9416      begin
9417        ResultList.SetPath('bkpt');
9418        if (not Result) or (r.State = dsError) and
9419           (DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwUserBreakPoint])
9420        then
9421          Include(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
9422        APending := (ResultList.IndexOf('pending') >= 0) or
9423          (pos('pend', lowercase(ResultList.Values['addr'])) > 0);
9424        if APending and (DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwUserBreakPoint])
9425        then
9426          Include(FTheDebugger.FDebuggerFlags, dfSetBreakPending);
9427      end;
9428    bpkData:
9429      case FWatchKind of
9430        wpkWrite: begin
9431            if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
9432            else
9433            if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
9434          end;
9435        wpkRead: begin
9436            if ResultList.IndexOf('hw-rwpt') >= 0 then ResultList.SetPath('hw-rwpt')
9437            else
9438            if ResultList.IndexOf('rwpt') >= 0 then ResultList.SetPath('rwpt')
9439            else
9440            if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
9441            else
9442            if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
9443          end;
9444        wpkReadWrite: begin
9445            if ResultList.IndexOf('hw-awpt') >= 0 then ResultList.SetPath('hw-awpt')
9446            else
9447            if ResultList.IndexOf('awpt') >= 0 then ResultList.SetPath('awpt')
9448            else
9449            if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
9450            else
9451            if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
9452          end;
9453      end;
9454  end;
9455  ABreakID := StrToIntDef(ResultList.Values['number'], 0);
9456  AHitCnt  := StrToIntDef(ResultList.Values['times'], 0);
9457  AnAddr   := StrToQWordDef(ResultList.Values['addr'], 0);
9458  if ABreakID = 0
9459  then Result := False;
9460  ResultList.Free;
9461end;
9462
9463function TGDBMIDebuggerCommandBreakInsert.DoExecute: Boolean;
9464var
9465  Pending: Boolean;
9466begin
9467  Result := True;
9468  FContext.ThreadContext := ccNotRequired;
9469  FContext.StackContext := ccNotRequired;
9470
9471  FValid := vsInvalid;
9472  DefaultTimeOut := DebuggerProperties.TimeoutForEval;
9473  try
9474    if FReplaceId <> 0
9475    then ExecBreakDelete(FReplaceId);
9476
9477    if ExecBreakInsert(FBreakID, FHitCnt, FAddr, Pending) then
9478      FValid := vsValid;
9479    if FValid = vsInvalid then Exit;
9480    if Pending then
9481      FValid := vsPending;
9482
9483    if (FExpression <> '') and not (dcsCanceled in SeenStates)
9484    then ExecBreakCondition(FBreakID, FExpression);
9485
9486    if not (dcsCanceled in SeenStates)
9487    then ExecBreakEnabled(FBreakID, FEnabled);
9488
9489    if dcsCanceled in SeenStates
9490    then begin
9491      ExecBreakDelete(FBreakID);
9492      FBreakID := 0;
9493      FValid := vsInvalid;
9494      FAddr := 0;
9495      FHitCnt := 0;
9496    end;
9497  finally
9498    DefaultTimeOut := -1;
9499  end;
9500end;
9501
9502constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger; ASource: string;
9503  ALine: Integer; AEnabled: Boolean; AnExpression: string; AReplaceId: Integer);
9504begin
9505  inherited Create(AOwner);
9506  FKind := bpkSource;
9507  FSource := ASource;
9508  FLine := ALine;
9509  FEnabled := AEnabled;
9510  FExpression := AnExpression;
9511  FReplaceId := AReplaceId;
9512end;
9513
9514constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger;
9515  AAddress: TDBGPtr; AEnabled: Boolean; AnExpression: string;
9516  AReplaceId: Integer);
9517begin
9518  inherited Create(AOwner);
9519  FKind := bpkAddress;
9520  FAddress := AAddress;
9521  FEnabled := AEnabled;
9522  FExpression := AnExpression;
9523  FReplaceId := AReplaceId;
9524end;
9525
9526constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger; AData: string;
9527  AScope: TDBGWatchPointScope; AKind: TDBGWatchPointKind; AEnabled: Boolean;
9528  AnExpression: string; AReplaceId: Integer);
9529begin
9530  inherited Create(AOwner);
9531  FKind := bpkData;
9532  FWatchData := AData;
9533  FWatchScope := AScope;
9534  FWatchKind := AKind;
9535  FEnabled := AEnabled;
9536  FExpression := AnExpression;
9537  FReplaceId := AReplaceId;
9538end;
9539
9540function TGDBMIDebuggerCommandBreakInsert.DebugText: String;
9541begin
9542  case FKind of
9543    bpkAddress:
9544      Result := Format('%s: Address=%x, Enabled=%s', [ClassName, FAddress, dbgs(FEnabled)]);
9545    bpkData:
9546      Result := Format('%s: Data=%s, Enabled=%s', [ClassName, FWatchData, dbgs(FEnabled)]);
9547    else
9548      Result := Format('%s: Source=%s, Line=%d, Enabled=%s', [ClassName, FSource, FLine, dbgs(FEnabled)]);
9549  end;
9550end;
9551
9552{ TGDBMIDebuggerCommandBreakRemove }
9553
9554function TGDBMIDebuggerCommandBreakRemove.DoExecute: Boolean;
9555begin
9556  Result := True;
9557  FContext.ThreadContext := ccNotRequired;
9558  FContext.StackContext := ccNotRequired;
9559
9560  DefaultTimeOut := DebuggerProperties.TimeoutForEval;
9561  try
9562  ExecBreakDelete(FBreakId);
9563  finally
9564    DefaultTimeOut := -1;
9565  end;
9566end;
9567
9568constructor TGDBMIDebuggerCommandBreakRemove.Create(AOwner: TGDBMIDebugger;
9569  ABreakId: Integer);
9570begin
9571  inherited Create(AOwner);
9572  FBreakId := ABreakId;
9573end;
9574
9575function TGDBMIDebuggerCommandBreakRemove.DebugText: String;
9576begin
9577  Result := Format('%s: BreakId=%d', [ClassName, FBreakId]);
9578end;
9579
9580{ TGDBMIDebuggerCommandBreakUpdate }
9581
9582function TGDBMIDebuggerCommandBreakUpdate.DoExecute: Boolean;
9583begin
9584  Result := True;
9585  FContext.ThreadContext := ccNotRequired;
9586  FContext.StackContext := ccNotRequired;
9587
9588  DefaultTimeOut := DebuggerProperties.TimeoutForEval;
9589  try
9590  if FUpdateExpression
9591  then ExecBreakCondition(FBreakID, FExpression);
9592  if FUpdateEnabled
9593  then ExecBreakEnabled(FBreakID, FEnabled);
9594  finally
9595    DefaultTimeOut := -1;
9596  end;
9597end;
9598
9599constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
9600begin
9601  inherited Create(AOwner);
9602  FBreakID := ABreakId;
9603  FUpdateEnabled := False;
9604  FUpdateExpression := False;
9605end;
9606
9607constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
9608  ABreakId: Integer; AnEnabled: Boolean);
9609begin
9610  inherited Create(AOwner);
9611  FBreakID := ABreakId;
9612  FEnabled := AnEnabled;
9613  FUpdateEnabled := True;
9614  FUpdateExpression := False;
9615end;
9616
9617constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
9618  ABreakId: Integer; AnExpression: string);
9619begin
9620  inherited Create(AOwner);
9621  FBreakID := ABreakId;
9622  FExpression := AnExpression;
9623  FUpdateExpression := True;
9624  FUpdateEnabled := False;
9625end;
9626
9627constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
9628  ABreakId: Integer; AnEnabled: Boolean; AnExpression: string);
9629begin
9630  inherited Create(AOwner);
9631  FBreakID := ABreakId;
9632  FEnabled := AnEnabled;
9633  FUpdateEnabled := True;
9634  FExpression := AnExpression;
9635  FUpdateExpression := True;
9636end;
9637
9638function TGDBMIDebuggerCommandBreakUpdate.DebugText: String;
9639begin
9640  Result := Format('%s: BreakId=%d ChangeEnabled=%s NewEnable=%s ChangeEpression=%s NewExpression=%s',
9641   [ClassName, FBreakId, dbgs(FUpdateEnabled), dbgs(FEnabled), dbgs(FUpdateExpression), FExpression]);
9642end;
9643
9644{ =========================================================================== }
9645{ TGDBMIBreakPoint }
9646{ =========================================================================== }
9647
9648constructor TGDBMIBreakPoint.Create(ACollection: TCollection);
9649begin
9650  inherited Create(ACollection);
9651  FCurrentCmd := nil;
9652  FUpdateFlags := [];
9653  FBreakID := 0;
9654end;
9655
9656destructor TGDBMIBreakPoint.Destroy;
9657begin
9658  ReleaseBreakPoint;
9659  if FCurrentCmd <> nil
9660  then begin
9661    // keep the command running
9662    FCurrentCmd.OnDestroy := nil;
9663    FCurrentCmd.OnCancel := nil;
9664    FCurrentCmd.OnExecuted := nil;
9665  end;
9666  inherited Destroy;
9667end;
9668
9669procedure TGDBMIBreakPoint.DoEnableChange;
9670begin
9671  if (FBreakID = 0) and Enabled and
9672     (TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun])
9673  then
9674    SetBreakPoint
9675  else
9676    UpdateProperties([bufEnabled]);
9677  inherited;
9678end;
9679
9680procedure TGDBMIBreakPoint.DoExpressionChange;
9681var
9682  S: String;
9683begin
9684  S := Expression;
9685  if ConvertPascalExpression(S)
9686  then FParsedExpression := S
9687  else FParsedExpression := Expression;
9688  if (FBreakID = 0) and Enabled and
9689     (TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun])
9690  then
9691    SetBreakPoint
9692  else
9693    UpdateProperties([bufCondition]);
9694  inherited;
9695end;
9696
9697procedure TGDBMIBreakPoint.DoStateChange(const AOldState: TDBGState);
9698begin
9699  inherited DoStateChange(AOldState);
9700
9701  case Debugger.State of
9702    dsInit: begin
9703      // Disabled data breakpoints: wait until enabled
9704      // Disabled other breakpoints: Cive to GDB to see if they are valid
9705      if (Kind <> bpkData) or Enabled then
9706        SetBreakpoint;
9707    end;
9708    dsStop: begin
9709      if FBreakID > 0
9710      then ReleaseBreakpoint;
9711    end;
9712  end;
9713end;
9714
9715procedure TGDBMIBreakPoint.DoLogExpressionCallback(Sender: TObject;
9716  ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
9717begin
9718  if ASuccess then
9719    TGDBMIDebugger(Sender).DoDbgEvent(ecBreakpoint, etBreakpointEvaluation, ResultText);
9720end;
9721
9722procedure TGDBMIBreakPoint.DoLogExpression(const AnExpression: String);
9723begin
9724  TGDBMIDebugger(Debugger).GDBEvaluate(AnExpression, [defNoTypeInfo], @DoLogExpressionCallback);
9725end;
9726
9727procedure TGDBMIBreakPoint.MakeInvalid;
9728begin
9729  BeginUpdate;
9730  ReleaseBreakPoint;
9731  SetValid(vsInvalid);
9732  Changed;
9733  EndUpdate;
9734end;
9735
9736procedure TGDBMIBreakPoint.SetAddress(const AValue: TDBGPtr);
9737begin
9738  if (Address = AValue) then exit;
9739  inherited;
9740  if (Debugger = nil) then Exit;
9741  if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
9742  then SetBreakpoint;
9743end;
9744
9745procedure TGDBMIBreakPoint.SetBreakpoint;
9746begin
9747  if Debugger = nil then Exit;
9748  if IsUpdating
9749  then begin
9750    FUpdateFlags := [bufSetBreakPoint];
9751    exit;
9752  end;
9753
9754  if (FCurrentCmd <> nil)
9755  then begin
9756    // We can not be changed, while we get destroyed
9757    if (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
9758    then begin
9759      SetValid(vsInvalid);
9760      exit;
9761    end;
9762
9763    if (FCurrentCmd is TGDBMIDebuggerCommandBreakInsert) and (FCurrentCmd.State = dcsQueued)
9764    then begin
9765      // update the current object
9766      TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Kind := Kind;
9767      case Kind of
9768        bpkSource:
9769          begin
9770            TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Source := Source;
9771            TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Line := Line;
9772          end;
9773        bpkAddress:
9774          begin
9775            TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Address := Address;
9776          end;
9777        bpkData:
9778          begin
9779            TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).WatchData := WatchData;
9780            TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).WatchScope := WatchScope;
9781          end;
9782      end;
9783      TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Enabled := Enabled;
9784      TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Expression := FParsedExpression;
9785      exit;
9786    end;
9787
9788    if (FCurrentCmd.State = dcsQueued)
9789    then begin
9790      // must be update for enabled or expression. both will be included in BreakInsert
9791      // cancel and schedule BreakInsert
9792      FCurrentCmd.OnDestroy := nil;
9793      FCurrentCmd.OnCancel := nil;
9794      FCurrentCmd.OnExecuted := nil;
9795      FCurrentCmd.Cancel;
9796    end
9797    else begin
9798      // let the command run (remove flags for enabled/condition)
9799      FUpdateFlags := [bufSetBreakPoint];
9800      exit;
9801    end;
9802  end;
9803
9804  FUpdateFlags := [];
9805  case Kind of
9806    bpkSource:
9807      FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), Source, Line, Enabled, FParsedExpression, FBreakID);
9808    bpkAddress:
9809      FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), Address, Enabled, FParsedExpression, FBreakID);
9810    bpkData:
9811      FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), WatchData, WatchScope, WatchKind, Enabled, FParsedExpression, FBreakID);
9812  end;
9813  FBreakID := 0; // will be replaced => no longer valid
9814  FCurrentCmd.OnDestroy  := @DoCommandDestroyed;
9815  FCurrentCmd.OnExecuted  := @DoCommandExecuted;
9816  FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
9817  TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
9818
9819  if Debugger.State = dsRun
9820  then TGDBMIDebugger(Debugger).GDBPause(True);
9821end;
9822
9823procedure TGDBMIBreakPoint.DoCommandDestroyed(Sender: TObject);
9824begin
9825  if Sender = FCurrentCmd
9826  then FCurrentCmd := nil;
9827  // in case of cancelation
9828  if bufSetBreakPoint in FUpdateFlags
9829  then SetBreakPoint;
9830  if FUpdateFlags * [bufEnabled, bufCondition] <> []
9831  then UpdateProperties(FUpdateFlags);
9832end;
9833
9834procedure TGDBMIBreakPoint.DoCommandExecuted(Sender: TObject);
9835begin
9836  if Sender = FCurrentCmd
9837  then FCurrentCmd := nil;
9838
9839  if (Sender is TGDBMIDebuggerCommandBreakInsert)
9840  then begin
9841    // Check Insert Result
9842    BeginUpdate;
9843
9844    case TGDBMIDebuggerCommandBreakInsert(Sender).Valid of
9845      vsValid: SetValid(vsValid);
9846      vsPending: SetValid(vsPending);
9847      else begin
9848        if (TGDBMIDebuggerCommandBreakInsert(Sender).Kind = bpkData) and
9849           (TGDBMIDebugger(Debugger).State = dsInit)
9850        then begin
9851          // disable data breakpoint, if unable to set (only at startup)
9852          SetValid(vsValid);
9853          SetEnabled(False);
9854        end
9855        else SetValid(vsInvalid);
9856      end;
9857    end;
9858
9859    FBreakID := TGDBMIDebuggerCommandBreakInsert(Sender).BreakID;
9860    SetHitCount(TGDBMIDebuggerCommandBreakInsert(Sender).HitCnt);
9861
9862    if Enabled
9863    and (TGDBMIDebugger(Debugger).FBreakAtMain = nil)
9864    then begin
9865      // Check if this BP is at the same location as the temp break
9866      if TGDBMIDebugger(Debugger).FMainAddrBreak.MatchAddr(TGDBMIDebuggerCommandBreakInsert(Sender).Addr)
9867      then TGDBMIDebugger(Debugger).FBreakAtMain := Self;
9868    end;
9869
9870    EndUpdate;
9871  end;
9872
9873  if bufSetBreakPoint in FUpdateFlags
9874  then SetBreakPoint;
9875  if FUpdateFlags * [bufEnabled, bufCondition] <> []
9876  then UpdateProperties(FUpdateFlags);
9877end;
9878
9879procedure TGDBMIBreakPoint.DoEndUpdate;
9880begin
9881  if bufSetBreakPoint in FUpdateFlags
9882  then SetBreakPoint;
9883  if FUpdateFlags * [bufEnabled, bufCondition] <> []
9884  then UpdateProperties(FUpdateFlags);
9885  inherited DoEndUpdate;
9886end;
9887
9888procedure TGDBMIBreakPoint.ReleaseBreakPoint;
9889begin
9890  if Debugger = nil then Exit;
9891
9892  FUpdateFlags := [];
9893  if (FCurrentCmd <> nil) and (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
9894  then exit;
9895
9896  // Cancel any other current command
9897  if (FCurrentCmd <> nil)
9898  then begin
9899    FCurrentCmd.OnDestroy := nil;
9900    FCurrentCmd.OnCancel := nil;
9901    FCurrentCmd.OnExecuted := nil;
9902    // if CurrenCmd is TGDBMIDebuggerCommandBreakInsert then it will remove itself
9903    FCurrentCmd.Cancel;
9904  end;
9905
9906  if FBreakID = 0 then Exit;
9907
9908  FCurrentCmd := TGDBMIDebuggerCommandBreakRemove.Create(TGDBMIDebugger(Debugger), FBreakID);
9909  FCurrentCmd.OnDestroy  := @DoCommandDestroyed;
9910  FCurrentCmd.OnExecuted  := @DoCommandExecuted;
9911  FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
9912  TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
9913
9914  FBreakID:=0;
9915  SetHitCount(0);
9916
9917  if Debugger.State = dsRun
9918  then TGDBMIDebugger(Debugger).GDBPause(True);
9919end;
9920
9921procedure TGDBMIBreakPoint.SetLocation(const ASource: String; const ALine: Integer);
9922begin
9923  if (Source = ASource) and (Line = ALine) then exit;
9924  inherited;
9925  if (Debugger = nil) or (Source = '')  then Exit;
9926  if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
9927  then SetBreakpoint;
9928end;
9929
9930procedure TGDBMIBreakPoint.SetWatch(const AData: String; const AScope: TDBGWatchPointScope;
9931  const AKind: TDBGWatchPointKind);
9932begin
9933  if (AData = WatchData) and (AScope = WatchScope) and (AKind = WatchKind) then exit;
9934  inherited SetWatch(AData, AScope, AKind);
9935  if (Debugger = nil) or (WatchData = '')  then Exit;
9936  if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
9937  then SetBreakpoint;
9938end;
9939
9940procedure TGDBMIBreakPoint.UpdateProperties(AFlags: TGDBMIBreakPointUpdateFlags);
9941begin
9942  if (Debugger = nil) then Exit;
9943  if AFlags * [bufEnabled, bufCondition] = [] then Exit;
9944  if IsUpdating
9945  then begin
9946    if not(bufSetBreakPoint in FUpdateFlags)
9947    then FUpdateFlags := FUpdateFlags + AFlags;
9948    exit;
9949  end;
9950
9951  if (FCurrentCmd <> nil)
9952  then begin
9953    // We can not be changed, while we get destroyed
9954    if (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
9955    then begin
9956      SetValid(vsInvalid);
9957      exit;
9958    end;
9959
9960    if (FCurrentCmd is TGDBMIDebuggerCommandBreakInsert) and (FCurrentCmd.State = dcsQueued)
9961    then begin
9962      if bufEnabled in AFlags
9963      then TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Enabled := Enabled;
9964      if bufCondition in AFlags
9965      then TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Expression := Expression;
9966      exit;
9967    end;
9968
9969    if (FCurrentCmd is TGDBMIDebuggerCommandBreakUpdate) and (FCurrentCmd.State = dcsQueued)
9970    then begin
9971      // update the current object
9972      if bufEnabled in AFlags
9973      then begin
9974        TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateEnabled := True;
9975        TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Enabled := Enabled;
9976      end;
9977      if bufCondition in AFlags
9978      then begin
9979        TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateExpression := True;
9980        TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Expression := FParsedExpression;
9981      end;
9982      exit;
9983    end;
9984
9985    if bufSetBreakPoint in FUpdateFlags
9986    then exit;
9987
9988    // let the command run
9989    FUpdateFlags := FUpdateFlags + AFlags;
9990    exit;
9991  end;
9992
9993  if (FBreakID = 0) then Exit;
9994
9995  FUpdateFlags := FUpdateFlags - [bufEnabled, bufCondition];
9996
9997  FCurrentCmd:= TGDBMIDebuggerCommandBreakUpdate.Create(TGDBMIDebugger(Debugger), FBreakID);
9998  if bufEnabled in AFlags
9999  then begin
10000    TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateEnabled := True;
10001    TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Enabled := Enabled;
10002  end;
10003  if bufCondition in AFlags
10004  then begin
10005    TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateExpression := True;
10006    TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Expression := FParsedExpression;
10007  end;
10008  FCurrentCmd.OnDestroy  := @DoCommandDestroyed;
10009  FCurrentCmd.OnExecuted  := @DoCommandExecuted;
10010  FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
10011  TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
10012
10013  if Debugger.State = dsRun
10014  then TGDBMIDebugger(Debugger).GDBPause(True);
10015end;
10016
10017{%endregion   ^^^^^  BreakPoints  ^^^^^  }
10018
10019{%region      *****  Locals  *****  }
10020{ TGDBMIDebuggerCommandLocals }
10021
10022procedure TGDBMIDebuggerCommandLocals.DoLockQueueExecute;
10023begin
10024  //
10025end;
10026
10027procedure TGDBMIDebuggerCommandLocals.DoUnLockQueueExecute;
10028begin
10029  //
10030end;
10031
10032procedure TGDBMIDebuggerCommandLocals.DoLockQueueExecuteForInstr;
10033begin
10034  //
10035end;
10036
10037procedure TGDBMIDebuggerCommandLocals.DoUnLockQueueExecuteForInstr;
10038begin
10039  //
10040end;
10041
10042function TGDBMIDebuggerCommandLocals.DoExecute: Boolean;
10043
10044  procedure AddLocals(const AParams: String);
10045  var
10046    n: Integer;
10047    addr: TDbgPtr;
10048    LocList, List: TGDBMINameValueList;
10049    Item: PGDBMINameValue;
10050    Name, Value: String;
10051  begin
10052    LocList := TGDBMINameValueList.Create(AParams);
10053    List := TGDBMINameValueList.Create('');
10054    for n := 0 to LocList.Count - 1 do
10055    begin
10056      Item := LocList.Items[n];
10057      List.Init(Item^.Name);
10058      Name := List.Values['name'];
10059      if Name = 'this'
10060      then Name := 'Self';
10061
10062      Value := List.Values['value'];
10063      (* GDB up to about 6.6 (stabs only) may return:
10064         {name="ARGANSISTRING",value="(ANSISTRING) 0x43cc84"}
10065       * newer GDB may return AnsiString/PChar prefixed with an address (shortstring have no address)
10066         {name="ARGANSISTRING",value="0x43cc84 'Ansi'"}
10067      *)
10068      if (lowercase(copy(Value, 1, 8)) = '(pchar) ') then begin
10069        delete(Value, 1, 8);
10070        if GetLeadingAddr(Value, addr) then begin
10071          if addr = 0
10072          then Value := ''''''
10073          else Value := MakePrintable(GetText(addr));
10074        end;
10075      end
10076      else
10077      if (lowercase(copy(Value, 1, 13)) = '(ansistring) ') then begin
10078        delete(Value, 1, 13);
10079        if GetLeadingAddr(Value, addr) then begin
10080          if addr = 0
10081          then Value := ''''''
10082          else Value := MakePrintable(GetText(addr));
10083        end;
10084      end
10085      else
10086      if GetLeadingAddr(Value, addr, True) then
10087      begin
10088        // AnsiString
10089        if (length(Value) > 0) and (Value[1] in ['''', '#']) then begin
10090          Value := MakePrintable(ProcessGDBResultText(Value, [prNoLeadingTab]));
10091        end
10092        else
10093          Value := ProcessGDBResultStruct(List.Values['value'], [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
10094      end
10095      else
10096      // ShortString
10097      if (length(Value) > 0) and (Value[1] in ['''', '#']) then begin
10098        Value := MakePrintable(ProcessGDBResultText(Value, [prNoLeadingTab]));
10099      end
10100      else
10101        Value := ProcessGDBResultStruct(Value, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
10102
10103      FLocals.Add(Name, Value);
10104    end;
10105    FreeAndNil(List);
10106    FreeAndNil(LocList);
10107  end;
10108
10109var
10110  R: TGDBMIExecResult;
10111  List: TGDBMINameValueList;
10112begin
10113  Result := True;
10114
10115  FContext.ThreadContext := ccUseLocal;
10116  FContext.ThreadId := FLocals.ThreadId;
10117  FContext.StackContext := ccUseLocal;
10118  FContext.StackFrame := FLocals.StackFrame;
10119
10120  FLocals.Clear;
10121  // args
10122  ExecuteCommand('-stack-list-arguments 1 %0:d %0:d',
10123    [FTheDebugger.FCurrentStackFrame], R, [cfNoStackContext]);
10124  if R.State <> dsError
10125  then begin
10126    List := TGDBMINameValueList.Create(R, ['stack-args', 'frame']);
10127    AddLocals(List.Values['args']);
10128    FreeAndNil(List);
10129  end;
10130
10131  // variables
10132  ExecuteCommand('-stack-list-locals 1', R);
10133  if R.State <> dsError
10134  then begin
10135    List := TGDBMINameValueList.Create(R);
10136    AddLocals(List.Values['locals']);
10137    FreeAndNil(List);
10138  end;
10139  FLocals.SetDataValidity(ddsValid);
10140end;
10141
10142constructor TGDBMIDebuggerCommandLocals.Create(AOwner: TGDBMIDebugger; ALocals: TLocals);
10143begin
10144  inherited Create(AOwner);
10145  FLocals := ALocals;
10146  FLocals.AddReference;
10147end;
10148
10149destructor TGDBMIDebuggerCommandLocals.Destroy;
10150begin
10151  ReleaseRefAndNil(FLocals);
10152  inherited Destroy;
10153end;
10154
10155function TGDBMIDebuggerCommandLocals.DebugText: String;
10156begin
10157  Result := Format('%s:', [ClassName]);
10158end;
10159
10160{ =========================================================================== }
10161{ TGDBMILocals }
10162{ =========================================================================== }
10163
10164procedure TGDBMILocals.Changed;
10165begin
10166  if CurrentLocalsList <> nil
10167  then CurrentLocalsList.Clear;
10168end;
10169
10170constructor TGDBMILocals.Create(const ADebugger: TDebuggerIntf);
10171begin
10172  FCommandList := TList.Create;
10173  inherited;
10174end;
10175
10176destructor TGDBMILocals.Destroy;
10177begin
10178  CancelAllCommands;
10179  inherited;
10180  FreeAndNil(FCommandList);
10181end;
10182
10183procedure TGDBMILocals.CancelAllCommands;
10184var
10185  i: Integer;
10186begin
10187  for i := 0 to FCommandList.Count-1 do
10188    with TGDBMIDebuggerCommandStack(FCommandList[i]) do begin
10189      OnExecuted := nil;
10190      OnDestroy := nil;
10191      Cancel;
10192    end;
10193  FCommandList.Clear;
10194end;
10195
10196function TGDBMILocals.ForceQueuing: Boolean;
10197begin
10198  Result := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
10199            and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
10200            and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
10201            and (Debugger.State <> dsInternalPause);
10202end;
10203
10204procedure TGDBMILocals.RequestData(ALocals: TLocals);
10205var
10206  EvaluationCmdObj: TGDBMIDebuggerCommandLocals;
10207begin
10208  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then Exit;
10209
10210  EvaluationCmdObj := TGDBMIDebuggerCommandLocals.Create(TGDBMIDebugger(Debugger), ALocals);
10211  EvaluationCmdObj.OnDestroy   := @DoEvaluationDestroyed;
10212  EvaluationCmdObj.Priority := GDCMD_PRIOR_LOCALS;
10213  EvaluationCmdObj.Properties := [dcpCancelOnRun];
10214  FCommandList.add(EvaluationCmdObj);
10215  TGDBMIDebugger(Debugger).QueueCommand(EvaluationCmdObj, ForceQueuing);
10216  (* DoEvaluationFinished may be called immediately at this point *)
10217end;
10218
10219procedure TGDBMILocals.DoEvaluationDestroyed(Sender: TObject);
10220begin
10221  FCommandList.Remove(Sender);
10222end;
10223
10224procedure TGDBMILocals.CancelEvaluation;
10225begin
10226end;
10227
10228{%endregion   ^^^^^  BreakPoints  ^^^^^  }
10229
10230{ =========================================================================== }
10231{ TGDBMIWatches }
10232{ =========================================================================== }
10233
10234procedure TGDBMIWatches.DoEvaluationDestroyed(Sender: TObject);
10235begin
10236  FCommandList.Remove(Sender);
10237end;
10238
10239function TGDBMIWatches.GetParentFPList(AThreadId: Integer): PGDBMIDebuggerParentFrameCache;
10240var
10241  i: Integer;
10242begin
10243  for i := 0 to high(FParentFPList) do
10244    if FParentFPList[i].ThreadId = AThreadId
10245    then exit(@FParentFPList[i]);
10246  i := Length(FParentFPList);
10247  SetLength(FParentFPList, i + 1);
10248  FParentFPList[i].ThreadId := AThreadId;
10249  Result := @FParentFPList[i];
10250end;
10251
10252procedure TGDBMIWatches.DoStateChange(const AOldState: TDBGState);
10253begin
10254  SetLength(FParentFPList, 0);
10255  if FParentFPListChangeStamp = high(FParentFPListChangeStamp) then
10256    FParentFPListChangeStamp := low(FParentFPListChangeStamp)
10257  else
10258    inc(FParentFPListChangeStamp);
10259  inherited DoStateChange(AOldState);
10260end;
10261
10262procedure TGDBMIWatches.Changed;
10263begin
10264  SetLength(FParentFPList, 0);
10265  if CurrentWatches <> nil
10266  then CurrentWatches.ClearValues;
10267end;
10268
10269procedure TGDBMIWatches.Clear;
10270var
10271  i: Integer;
10272begin
10273  for i := 0 to FCommandList.Count-1 do
10274    with TGDBMIDebuggerCommandEvaluate(FCommandList[i]) do begin
10275      OnExecuted := nil;
10276      OnDestroy := nil;
10277      Cancel;
10278    end;
10279  FCommandList.Clear;
10280end;
10281
10282function TGDBMIWatches.ForceQueuing: Boolean;
10283begin
10284  Result := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
10285            and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
10286            and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
10287            and (Debugger.State <> dsInternalPause);
10288end;
10289
10290procedure TGDBMIWatches.InternalRequestData(AWatchValue: TWatchValue);
10291var
10292  EvaluationCmdObj: TGDBMIDebuggerCommandEvaluate;
10293begin
10294  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
10295    AWatchValue.Validity := ddsInvalid;
10296    Exit;
10297  end;
10298
10299  EvaluationCmdObj := TGDBMIDebuggerCommandEvaluate.Create
10300    (TGDBMIDebugger(Debugger), AWatchValue);
10301  //EvaluationCmdObj.OnExecuted := @DoEvaluationFinished;
10302  EvaluationCmdObj.OnDestroy    := @DoEvaluationDestroyed;
10303  EvaluationCmdObj.Properties := [dcpCancelOnRun];
10304  // If a ExecCmd is running, then defer exec until the exec cmd is done
10305  FCommandList.Add(EvaluationCmdObj);
10306  TGDBMIDebugger(Debugger).QueueCommand(EvaluationCmdObj, ForceQueuing);
10307  (* DoEvaluationFinished may be called immediately at this point *)
10308end;
10309
10310constructor TGDBMIWatches.Create(const ADebugger: TDebuggerIntf);
10311begin
10312  FCommandList := TList.Create;
10313  inherited Create(ADebugger);
10314end;
10315
10316destructor TGDBMIWatches.Destroy;
10317begin
10318  inherited Destroy;
10319  Clear;
10320  FreeAndNil(FCommandList);
10321end;
10322
10323
10324
10325{ =========================================================================== }
10326{ TGDBMICallStack }
10327{ =========================================================================== }
10328
10329procedure TGDBMICallStack.DoDepthCommandExecuted(Sender: TObject);
10330var
10331  Cmd: TGDBMIDebuggerCommandStackDepth;
10332begin
10333  FCommandList.Remove(Sender);
10334  FDepthEvalCmdObj := nil;
10335  Cmd := TGDBMIDebuggerCommandStackDepth(Sender);
10336  if Cmd.Callstack = nil then exit;
10337  if Cmd.Depth < 0 then begin
10338    Cmd.Callstack.SetCountValidity(ddsInvalid);
10339    Cmd.Callstack.SetHasAtLeastCountInfo(ddsInvalid);
10340  end else begin
10341    if (Cmd.Limit > 0) and not(Cmd.Depth < Cmd.Limit) then begin
10342      Cmd.Callstack.SetHasAtLeastCountInfo(ddsValid, Cmd.Depth);
10343    end
10344    else begin
10345      Cmd.Callstack.Count := Cmd.Depth;
10346      Cmd.Callstack.SetCountValidity(ddsValid);
10347    end;
10348  end;
10349end;
10350
10351procedure TGDBMICallStack.RequestCount(ACallstack: TCallStackBase);
10352begin
10353  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
10354  then begin
10355    ACallstack.SetCountValidity(ddsInvalid);
10356    exit;
10357  end;
10358
10359  if (FDepthEvalCmdObj <> nil) and (FDepthEvalCmdObj .State = dcsQueued) then begin
10360    FDepthEvalCmdObj.Limit := -1;
10361    exit;
10362  end;
10363
10364  FDepthEvalCmdObj := TGDBMIDebuggerCommandStackDepth.Create(TGDBMIDebugger(Debugger), ACallstack);
10365  FDepthEvalCmdObj.OnExecuted := @DoDepthCommandExecuted;
10366  FDepthEvalCmdObj.OnDestroy   := @DoCommandDestroyed;
10367  FDepthEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
10368  FCommandList.Add(FDepthEvalCmdObj);
10369  TGDBMIDebugger(Debugger).QueueCommand(FDepthEvalCmdObj);
10370  (* DoDepthCommandExecuted may be called immediately at this point *)
10371end;
10372
10373procedure TGDBMICallStack.RequestAtLeastCount(ACallstack: TCallStackBase;
10374  ARequiredMinCount: Integer);
10375begin
10376  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
10377  then begin
10378    ACallstack.SetCountValidity(ddsInvalid);
10379    exit;
10380  end;
10381
10382  // avoid calling with many small minimum
10383  // FLimitSeen starts at 11;
10384  FLimitSeen := Max(FLimitSeen, Min(ARequiredMinCount, 51)); // remember, if the user has asked for more
10385  if ARequiredMinCount <= 11 then
10386    ARequiredMinCount := 11
10387  else
10388    ARequiredMinCount := Max(ARequiredMinCount, FLimitSeen);
10389
10390  if (FDepthEvalCmdObj <> nil) and (FDepthEvalCmdObj .State = dcsQueued) then begin
10391    if FDepthEvalCmdObj.Limit <= 0 then
10392      exit;
10393    if FDepthEvalCmdObj.Limit < ARequiredMinCount then
10394      FDepthEvalCmdObj.Limit := ARequiredMinCount;
10395    exit;
10396  end;
10397
10398  FDepthEvalCmdObj := TGDBMIDebuggerCommandStackDepth.Create(TGDBMIDebugger(Debugger), ACallstack);
10399  FDepthEvalCmdObj.Limit := ARequiredMinCount;
10400  FDepthEvalCmdObj.OnExecuted := @DoDepthCommandExecuted;
10401  FDepthEvalCmdObj.OnDestroy   := @DoCommandDestroyed;
10402  FDepthEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
10403  FCommandList.Add(FDepthEvalCmdObj);
10404  TGDBMIDebugger(Debugger).QueueCommand(FDepthEvalCmdObj);
10405  (* DoDepthCommandExecuted may be called immediately at this point *)
10406end;
10407
10408procedure TGDBMICallStack.RequestCurrent(ACallstack: TCallStackBase);
10409begin
10410  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
10411    ACallstack.SetCurrentValidity(ddsInvalid);
10412    Exit;
10413  end;
10414
10415  if ACallstack.ThreadId = TGDBMIDebugger(Debugger).FCurrentThreadId
10416  then ACallstack.CurrentIndex := TGDBMIDebugger(Debugger).FCurrentStackFrame
10417  else ACallstack.CurrentIndex := 0; // will be used, if thread is changed
10418  ACallstack.SetCurrentValidity(ddsValid);
10419end;
10420
10421procedure TGDBMICallStack.RequestEntries(ACallstack: TCallStackBase);
10422var
10423  FramesEvalCmdObj: TGDBMIDebuggerCommandStackFrames;
10424begin
10425  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then Exit;
10426
10427  FramesEvalCmdObj := TGDBMIDebuggerCommandStackFrames.Create(TGDBMIDebugger(Debugger), ACallstack);
10428  //FramesEvalCmdObj.OnExecuted := @DoFramesCommandExecuted;
10429  FramesEvalCmdObj.OnDestroy  := @DoCommandDestroyed;
10430  FramesEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
10431  FCommandList.Add(FramesEvalCmdObj);
10432  TGDBMIDebugger(Debugger).QueueCommand(FramesEvalCmdObj);
10433  (* DoFramesCommandExecuted may be called immediately at this point *)
10434end;
10435
10436procedure TGDBMICallStack.DoCommandDestroyed(Sender: TObject);
10437begin
10438  FCommandList.Remove(Sender);
10439  if FDepthEvalCmdObj = Sender then
10440    FDepthEvalCmdObj := nil;
10441end;
10442
10443procedure TGDBMICallStack.Clear;
10444var
10445  i: Integer;
10446begin
10447  for i := 0 to FCommandList.Count-1 do
10448    with TGDBMIDebuggerCommandStack(FCommandList[i]) do begin
10449      OnExecuted := nil;
10450      OnDestroy := nil;
10451      Cancel;
10452    end;
10453  FCommandList.Clear;
10454  FDepthEvalCmdObj := nil;
10455end;
10456
10457procedure TGDBMICallStack.UpdateCurrentIndex;
10458var
10459  tid, idx: Integer;
10460  cs: TCallStackBase;
10461begin
10462  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
10463    exit;
10464  end;
10465
10466  tid := Debugger.Threads.CurrentThreads.CurrentThreadId;
10467  cs := TCallStackBase(CurrentCallStackList.EntriesForThreads[tid]);
10468  idx := cs.NewCurrentIndex;  // NEW-CURRENT
10469  if TGDBMIDebugger(Debugger).FCurrentStackFrame = idx then Exit;
10470
10471  TGDBMIDebugger(Debugger).FCurrentStackFrame := idx;
10472  if cs <> nil then
10473    cs.CurrentIndex := idx;
10474end;
10475
10476procedure TGDBMICallStack.DoThreadChanged;
10477var
10478  tid, idx: Integer;
10479  cs: TCallStackBase;
10480begin
10481  if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
10482    exit;
10483  end;
10484
10485  TGDBMIDebugger(Debugger).FCurrentStackFrame := 0;
10486  tid := Debugger.Threads.CurrentThreads.CurrentThreadId;
10487  cs := TCallStackBase(CurrentCallStackList.EntriesForThreads[tid]);
10488  idx := cs.CurrentIndex;  // CURRENT
10489  if idx < 0 then idx := 0;
10490
10491  TGDBMIDebugger(Debugger).FCurrentStackFrame := idx;
10492  if cs <> nil then
10493    cs.CurrentIndex := idx;
10494end;
10495
10496constructor TGDBMICallStack.Create(const ADebugger: TDebuggerIntf);
10497begin
10498  FCommandList := TList.Create;
10499  FLimitSeen := 11;
10500  inherited Create(ADebugger);
10501end;
10502
10503destructor TGDBMICallStack.Destroy;
10504begin
10505  inherited Destroy;
10506  Clear;
10507  FreeAndNil(FCommandList);
10508end;
10509
10510{ TGDBStringIterator }
10511
10512constructor TGDBStringIterator.Create(const AParsableData: String);
10513begin
10514  inherited Create;
10515  FParsableData := AParsableData;
10516  FReadPointer := 1;
10517  FDataSize := Length(AParsableData);
10518  DebugLn(AParsableData);
10519end;
10520
10521function TGDBStringIterator.ParseNext(out ADecomposable: Boolean; out
10522  APayload: String; out ACharStopper: Char): Boolean;
10523var
10524  InStr: Boolean;
10525  InBrackets1, InBrackets2: Integer;
10526  c: Char;
10527  BeginString: Integer;
10528  EndString: Integer;
10529begin
10530  ADecomposable := False;
10531  InStr := False;
10532  InBrackets1 := 0;
10533  InBrackets2 := 0;
10534  BeginString := FReadPointer;
10535  EndString := FDataSize;
10536  ACharStopper := #0; //none
10537  while FReadPointer <= FDataSize do
10538  begin
10539    c := FParsableData[FReadPointer];
10540    if c = '''' then InStr := not InStr;
10541    if not InStr
10542    then begin
10543      case c of
10544        '{': Inc(InBrackets1);
10545        '}': Dec(InBrackets1);
10546        '[': Inc(InBrackets2);
10547        ']': Dec(InBrackets2);
10548      end;
10549
10550      if (InBrackets1 = 0) and (InBrackets2 = 0) and (c in [',', '='])
10551      then begin
10552        EndString := FReadPointer - 1;
10553        Inc(FReadPointer); //Skip this char
10554        ACharStopper := c;
10555        Break;
10556      end;
10557    end;
10558    Inc(FReadPointer);
10559  end;
10560
10561  //Remove boundary spaces.
10562  while BeginString<EndString do
10563  begin
10564    if FParsableData[BeginString] <> ' ' then break;
10565    Inc(BeginString);
10566  end;
10567
10568  while EndString >= BeginString do
10569  begin
10570    if FParsableData[EndString] <> ' ' then break;
10571    Dec(EndString);
10572  end;
10573
10574  Result := EndString >= BeginString;
10575
10576  if Result
10577  and (FParsableData[BeginString] = '{')
10578  then begin
10579    Result := FParsableData[EndString] = '}';
10580    inc(BeginString);
10581    dec(EndString);
10582    ADecomposable := True;
10583  end;
10584
10585  if Result
10586  then APayload := Copy(FParsableData, BeginString, EndString - BeginString + 1)
10587  else APayload := '';
10588end;
10589
10590{ TGDBMIDebuggerCommand }
10591
10592function TGDBMIDebuggerCommand.GetDebuggerState: TDBGState;
10593begin
10594  Result := FTheDebugger.State;
10595end;
10596
10597function TGDBMIDebuggerCommand.GetDebuggerProperties: TGDBMIDebuggerPropertiesBase;
10598begin
10599  Result := TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties);
10600end;
10601
10602function TGDBMIDebuggerCommand.GetTargetInfo: PGDBMITargetInfo;
10603begin
10604  Result := @FTheDebugger.FTargetInfo;
10605end;
10606
10607function TGDBMIDebuggerCommand.ContextThreadId: Integer;
10608begin
10609  if FContext.ThreadContext = ccUseGlobal then
10610    Result := FTheDebugger.FCurrentThreadId
10611  else
10612    Result := FContext.ThreadId;
10613end;
10614
10615function TGDBMIDebuggerCommand.ContextStackFrame: Integer;
10616begin
10617  if FContext.StackContext = ccUseGlobal then
10618    Result := FTheDebugger.FCurrentStackFrame
10619  else
10620    Result := FContext.StackFrame;
10621end;
10622
10623procedure TGDBMIDebuggerCommand.CopyGlobalContextToLocal;
10624begin
10625  if FContext.ThreadContext = ccUseGlobal then begin
10626    if FTheDebugger.FCurrentThreadIdValid then begin
10627      FContext.ThreadContext := ccUseLocal;
10628      FContext.ThreadId := FTheDebugger.FCurrentThreadId
10629    end
10630    else
10631      debugln(DBG_VERBOSE, ['CopyGlobalContextToLocal: FAILED thread, global data is not valid']);
10632  end;
10633
10634  if FContext.StackContext = ccUseGlobal then begin
10635    if FTheDebugger.FCurrentStackFrameValid then begin
10636      FContext.StackContext := ccUseLocal;
10637      FContext.StackFrame := FTheDebugger.FCurrentStackFrame;
10638    end
10639    else
10640      debugln(DBG_VERBOSE, ['CopyGlobalContextToLocal: FAILED stackframe, global data is not valid']);
10641  end;
10642end;
10643
10644procedure TGDBMIDebuggerCommand.SetDebuggerState(const AValue: TDBGState);
10645begin
10646  FTheDebugger.SetState(AValue);
10647end;
10648
10649procedure TGDBMIDebuggerCommand.SetDebuggerErrorState(const AMsg: String;
10650  const AInfo: String);
10651begin
10652  if FTheDebugger.IsInReset then
10653    exit;
10654  FTheDebugger.SetErrorState(AMsg, AInfo);
10655end;
10656
10657function TGDBMIDebuggerCommand.ErrorStateMessage: String;
10658begin
10659  Result := '';
10660  if ehfGotWriteError in FTheDebugger.FErrorHandlingFlags
10661  then Result := Result + Format(gdbmiErrorStateInfoFailedWrite, [LineEnding])
10662  else
10663  if ehfGotReadError in FTheDebugger.FErrorHandlingFlags
10664  then Result := Result + Format(gdbmiErrorStateInfoFailedRead, [LineEnding]);
10665
10666  if not FTheDebugger.DebugProcessRunning
10667  then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
10668end;
10669
10670function TGDBMIDebuggerCommand.ErrorStateInfo: String;
10671begin
10672  Result := Format(gdbmiErrorStateGenericInfo, [LineEnding, DebugText]);
10673  if FLastExecResult.Values = ''
10674  then Result := Format(gdbmiErrorStateInfoCommandNoResult, [LineEnding, FLastExecCommand])
10675  else Result := Format(gdbmiErrorStateInfoCommandError, [LineEnding, FLastExecCommand, FLastExecResult.Values]);
10676  if not FTheDebugger.DebugProcessRunning
10677  then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
10678end;
10679
10680procedure TGDBMIDebuggerCommand.SetCommandState(NewState: TGDBMIDebuggerCommandState);
10681var
10682  OldState: TGDBMIDebuggerCommandState;
10683begin
10684  if FState = NewState
10685  then exit;
10686  OldState := FState;
10687  FState := NewState;
10688  Include(FSeenStates, NewState);
10689  DoStateChanged(OldState);
10690  if (State in [dcsFinished, dcsCanceled]) and not(dcsInternalRefReleased in FSeenStates)
10691  then begin
10692    Include(FSeenStates, dcsInternalRefReleased);
10693    ReleaseReference; //internal reference
10694  end;
10695end;
10696
10697procedure TGDBMIDebuggerCommand.DoStateChanged(OldState: TGDBMIDebuggerCommandState);
10698begin
10699  // nothing
10700end;
10701
10702procedure TGDBMIDebuggerCommand.DoLockQueueExecute;
10703begin
10704  FTheDebugger.QueueExecuteLock;
10705end;
10706
10707procedure TGDBMIDebuggerCommand.DoUnLockQueueExecute;
10708begin
10709  FTheDebugger.QueueExecuteUnlock;
10710end;
10711
10712procedure TGDBMIDebuggerCommand.DoLockQueueExecuteForInstr;
10713begin
10714  FTheDebugger.QueueExecuteLock;
10715end;
10716
10717procedure TGDBMIDebuggerCommand.DoUnLockQueueExecuteForInstr;
10718begin
10719  FTheDebugger.QueueExecuteUnlock;
10720end;
10721
10722procedure TGDBMIDebuggerCommand.DoOnExecuted;
10723begin
10724  if assigned(FOnExecuted) then
10725    FOnExecuted(self);
10726end;
10727
10728procedure TGDBMIDebuggerCommand.DoCancel;
10729begin
10730  // empty
10731end;
10732
10733procedure TGDBMIDebuggerCommand.DoOnCanceled;
10734begin
10735  if assigned(FOnCancel) then
10736    FOnCancel(self);
10737end;
10738
10739function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
10740  AFlags: TGDBMICommandFlags = []; ATimeOut: Integer = -1): Boolean;
10741var
10742  R: TGDBMIExecResult;
10743begin
10744  Result := ExecuteCommand(ACommand, R, AFlags, ATimeOut);
10745end;
10746
10747function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
10748  out AResult: TGDBMIExecResult; AFlags: TGDBMICommandFlags = [];
10749  ATimeOut: Integer = -1): Boolean;
10750var
10751  Instr: TGDBMIDebuggerInstruction;
10752  ASyncFailed: Boolean;
10753begin
10754  ASyncFailed := False;
10755
10756  if cfTryAsync in AFlags then begin
10757    if FTheDebugger.FAsyncModeEnabled then begin
10758      Result := ExecuteCommand(ACommand + ' &', AResult, AFlags - [cfTryAsync], ATimeOut);
10759      if (not Result) or (AResult.State <> dsError) then
10760        exit;
10761    end;
10762
10763    ASyncFailed := True;
10764  end;
10765
10766  FLastExecCommand := ACommand;
10767  FLastExecwasTimeOut := False;
10768
10769  if (ATimeOut = -1) and (DefaultTimeOut > 0)
10770  then ATimeOut := DefaultTimeOut;
10771  if FTheDebugger.IsInReset then
10772    ATimeOut := 500;
10773
10774  try
10775    DoLockQueueExecuteForInstr;
10776
10777    if (cfNoThreadContext in AFlags) or (FContext.ThreadContext = ccNotRequired) or
10778       ((FContext.ThreadContext = ccUseGlobal) and (not FTheDebugger.FCurrentThreadIdValid)) or
10779       (ContextThreadId = 0) // TODO: 0 is not valid => use current
10780    then
10781      Instr := TGDBMIDebuggerInstruction.Create(ACommand, [], ATimeOut)
10782    else
10783    if (cfNoStackContext in AFlags) or (FContext.StackContext = ccNotRequired) or
10784       ((FContext.StackContext = ccUseGlobal) and (not FTheDebugger.FCurrentStackFrameValid))
10785    then
10786      Instr := TGDBMIDebuggerInstruction.Create(ACommand, ContextThreadId, [], ATimeOut)
10787    else
10788      Instr := TGDBMIDebuggerInstruction.Create(ACommand, ContextThreadId,
10789                 ContextStackFrame, [], ATimeOut);
10790    Instr.AddReference;
10791    Instr.Cmd := Self;
10792
10793  if (pos('-stack-list-', ACommand) = 1) or
10794     (pos('-thread-info', ACommand) = 1)
10795  then begin
10796    // includes locals
10797    Instr.ApplyMemLimit(DebuggerProperties.GdbLocalsValueMemLimit);
10798    if FTheDebugger.FGDBVersionMajor >= 7 then
10799      Instr.ApplyArrayLenLimit(DebuggerProperties.MaxLocalsLengthForStaticArray);
10800  end
10801  else
10802  if not( (Length(ACommand) < 2) or
10803          ( (ACommand[1] = '-') and (
10804            ( (ACommand[2] = 'd') and (
10805              (pos('-data-list-register-', ACommand) = 1) or
10806              (pos('-data-list-changed-registers', ACommand) = 1) or
10807              (pos('-data-disassemble', ACommand) = 1) or
10808              (pos('-data-read-memory', ACommand) = 1)
10809            )) or
10810            ( (ACommand[2] = 'g') and (
10811              (pos('-gdb-version ', ACommand) = 1) or
10812              (pos('-gdb-set ', ACommand) = 1) or
10813              (pos('-gdb-exit', ACommand) = 1)
10814            )) or
10815            ( (not(ACommand[2] in ['d', 'g'])) and (
10816              (pos('-exec-', ACommand) = 1) or
10817              (pos('-file-exec-', ACommand) = 1) or
10818              (pos('-break-', ACommand) = 1)
10819            ))
10820          )) or
10821          ( (ACommand[1] = 'i') and (
10822            (pos('info line', ACommand) = 1) or
10823            (pos('info address', ACommand) = 1) or
10824            (pos('info pid', ACommand) = 1) or
10825            (pos('info proc', ACommand) = 1) or
10826            (pos('info function', ACommand) = 1) or
10827            (pos('interrupt', ACommand) = 1) or
10828            (pos('info program', ACommand) = 1)
10829          )) or
10830          ( (ACommand[1] = 's') and (
10831            (pos('set ', ACommand) = 1) or
10832            (pos('show ', ACommand) = 1)
10833          )) or
10834          ( (ACommand[1] = 'm') and (
10835            (pos('maint ', ACommand) = 1)
10836          ))
10837        )
10838  then begin
10839    Instr.ApplyMemLimit(DebuggerProperties.GdbValueMemLimit);
10840    if FTheDebugger.FGDBVersionMajor >= 7 then
10841      Instr.ApplyArrayLenLimit(DebuggerProperties.MaxDisplayLengthForStaticArray);
10842  end;
10843
10844    FTheDebugger.FInstructionQueue.RunInstruction(Instr);
10845
10846    Result := Instr.IsSuccess and Instr.FHasResult;
10847    AResult := Instr.ResultData;
10848    if ASyncFailed then
10849      AResult.Flags := [rfAsyncFailed];
10850    FLastExecResult := AResult;
10851    FLogWarnings := Instr.LogWarnings;  // TODO: Do not clear in time-out handling
10852    FFullCmdReply := Instr.FullCmdReply; // TODO: Do not clear in time-out handling
10853
10854    if (ifeTimedOut in Instr.ErrorFlags) then begin
10855      AResult.State := dsError;
10856      FLastExecwasTimeOut := True;
10857    end;
10858    if (ifeRecoveredTimedOut in Instr.ErrorFlags) then begin
10859      // TODO: use feedback dialog
10860      Result := True;
10861      DoDbgEvent(ecDebugger, etDefault, Format(gdbmiTimeOutForCmd, [ACommand]));
10862      DoTimeoutFeedback;
10863    end;
10864  finally
10865    DoUnLockQueueExecuteForInstr;
10866    Instr.ReleaseReference;
10867  end;
10868
10869  if not Result
10870  then begin
10871    // either gdb did not return a Result Record: "^xxxx,"
10872    // or the Result Record was not a known one: 'done', 'running', 'exit', 'error'
10873    DebugLn(DBG_WARNINGS, '[WARNING] TGDBMIDebugger:  ExecuteCommand "',ACommand,'" failed.');
10874    SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
10875    AResult.State := dsError;
10876  end;
10877
10878  if (cfCheckError in AFlags) and (AResult.State = dsError)
10879  then SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
10880
10881  if (cfCheckState in AFlags) and not (AResult.State in [dsError, dsNone])
10882  then SetDebuggerState(AResult.State);
10883end;
10884
10885function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
10886  const AValues: array of const; AFlags: TGDBMICommandFlags;
10887  ATimeOut: Integer = -1): Boolean;
10888var
10889  R: TGDBMIExecResult;
10890begin
10891  Result := ExecuteCommand(ACommand, AValues, R, AFlags, ATimeOut);
10892end;
10893
10894function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
10895  const AValues: array of const; out AResult: TGDBMIExecResult;
10896  AFlags: TGDBMICommandFlags = []; ATimeOut: Integer = -1): Boolean;
10897begin
10898  Result := ExecuteCommand(Format(ACommand, AValues), AResult, AFlags, ATimeOut);
10899end;
10900
10901procedure TGDBMIDebuggerCommand.DoTimeoutFeedback;
10902begin
10903  if DebuggerProperties.WarnOnTimeOut
10904  then MessageDlg('Warning', 'A timeout occurred, the debugger will try to continue, but further error may occur later',
10905                  mtWarning, [mbOK], 0);
10906end;
10907
10908function TGDBMIDebuggerCommand.ProcessGDBResultStruct(S: String;
10909  Opts: TGDBMIProcessResultOpts): String;
10910
10911  function ProcessData(AData: String): String;
10912  var
10913    addr: TDBGPtr;
10914  begin
10915    Result := AData;
10916    if (prStripAddressFromString in Opts) and GetLeadingAddr(Result, addr, True) then
10917      if (Result = '') or not(Result[1] in ['''', '#']) then
10918        Result := AData; // Restore address, not a string
10919
10920    if (Result <> '') and (Result[1] in ['''', '#']) and (prMakePrintAble in Opts) then
10921      Result := MakePrintable(ProcessGDBResultText(Result, Opts + [prNoLeadingTab]));
10922  end;
10923
10924var
10925  start, idx, len: Integer;
10926  InQuote, InSingle, InValue: Boolean;
10927  InStruct: Integer;
10928begin
10929  Result := '';
10930  InQuote := False;  // "
10931  InSingle := False; // '
10932  InValue := False;  // after "="
10933  InStruct := 0;
10934  len := Length(S);
10935  start := 1;
10936  idx := 1;
10937  while idx <= len do begin
10938    case S[idx] of
10939      '"': begin // will be escaped if in single quotes
10940          inc(idx);
10941          InValue := False; // should never happen
10942          if not InQuote then
10943            Result := Result + copy(s, start, idx - start)
10944          else
10945            Result := Result + ProcessData(copy(s, start, idx - start - 1)) + '"';
10946          InQuote := not InQuote;
10947          start := idx;
10948        end;
10949      '\': begin
10950          inc(idx,2);
10951        end;
10952      '''': begin
10953          InSingle := not InSingle;
10954          inc(idx);
10955        end;
10956      '=': begin
10957          if (not (InQuote or InSingle)) and (InStruct > 0) and (idx > 1) and (idx < len) and
10958             (S[idx-1] = ' ') and (S[idx+1] = ' ') then
10959          begin
10960            inc(idx, 2);
10961            Result := Result + copy(s, start, idx - start);
10962            start := idx;
10963            InValue := True;
10964          end
10965          else
10966            inc(idx);
10967        end;
10968      ',': begin
10969          if (not (InQuote or InSingle)) and InValue and (idx < len) and
10970             (S[idx+1] = ' ')
10971          then begin
10972            Result := Result + ProcessData(copy(s, start, idx - start));
10973            start := idx;
10974            InValue := False;
10975          end
10976          else
10977            inc(idx);
10978        end;
10979      '}': begin
10980          if (not (InQuote or InSingle)) then begin
10981            if InStruct > 0 then
10982              dec(InStruct);
10983            if InValue then begin
10984              Result := Result + ProcessData(copy(s, start, idx - start));
10985              start := idx;
10986            end;
10987            InValue := False;
10988          end;
10989          inc(idx);
10990        end;
10991      '{': begin
10992          if (not (InQuote or InSingle)) then begin
10993            inc(InStruct);
10994            InValue := False;
10995           end;
10996          inc(idx);
10997        end;
10998      else begin
10999          inc(idx);
11000        end;
11001    end;
11002  end;
11003  if idx > len then idx := len + 1;
11004  if not InQuote then
11005    Result := Result + copy(s, start, idx - start)
11006  else
11007    Result := Result + ProcessData(copy(s, start, idx - start - 1)) + '"';
11008end;
11009
11010function TGDBMIDebuggerCommand.ProcessGDBResultText(S: String;
11011  Opts: TGDBMIProcessResultOpts = []): String;
11012var
11013  Trailor: String;
11014  n, len, idx: Integer;
11015  v: Integer;
11016begin
11017
11018  // don't use ' as end terminator, there might be one as part of the text
11019  // since ' will be the last char, simply strip it.
11020  if not (prNOLeadingTab in Opts) then begin
11021    S := GetPart(['\t'], [], S);
11022    if (length(S) > 0) and (S[1] = ' ') then
11023      delete(S,1,1);
11024  end;
11025
11026  // Scan the string
11027  len := Length(S);
11028  // Set the resultstring initially to the same size
11029  SetLength(Result, len);
11030  n := 0;
11031  idx := 1;
11032  Trailor:='';
11033  while idx <= len do
11034  begin
11035    case S[idx] of
11036      '''': begin
11037        Inc(idx);
11038        // scan till end
11039        while idx <= len do
11040        begin
11041          case S[idx] of
11042            '''' : begin
11043              Inc(idx);
11044              if idx > len then Break;
11045              if S[idx] <> '''' then Break;
11046            end;
11047            '\' : if not (prKeepBackSlash in Opts) then begin
11048              Inc(idx);
11049              if idx > len then Break;
11050              case S[idx] of
11051                't': S[idx] := #9;
11052                'n': S[idx] := #10;
11053                'r': S[idx] := #13;
11054              end;
11055            end;
11056          end;
11057          Inc(n);
11058          Result[n] := S[idx];
11059          Inc(idx);
11060        end;
11061      end;
11062      '#': begin
11063        Inc(idx);
11064        v := 0;
11065        // scan till non number (correct input is assumed)
11066        while (idx <= len) and (S[idx] >= '0') and (S[idx] <= '9') do
11067        begin
11068          v := v * 10 + Ord(S[idx]) - Ord('0');
11069          Inc(idx)
11070        end;
11071        Inc(n);
11072        Result[n] := Chr(v and $FF);
11073      end;
11074      ',', ' ': begin
11075        Inc(idx); //ignore them;
11076      end;
11077      '<': begin
11078        // Debugger has returned something like <repeats 10 times>
11079        v := StrToIntDef(GetPart(['<repeats '], [' times>'], S), 0);
11080        // Since we deleted the first part of S, reset idx
11081        idx := 8; // the char after ' times>'
11082        len := Length(S);
11083        if v <= 1 then Continue;
11084
11085        // limit the amount of repeats
11086        if v > 1000
11087        then begin
11088          Trailor := Trailor + Format('###(repeat truncated: %u -> 1000)###', [v]);
11089          v := 1000;
11090        end;
11091
11092        // make sure result has some room
11093        SetLength(Result, Length(Result) + v - 1);
11094        while v > 1 do begin
11095          Inc(n);
11096          Result[n] := Result[n - 1];
11097          Dec(v);
11098        end;
11099      end;
11100    else // Should not get here
11101      // Debugger has returned something we don't know of
11102      // Append the remainder to our parsed result
11103      Delete(S, 1, idx - 1);
11104      Trailor := Trailor + '###(gdb unparsed remainder:' + S + ')###';
11105      Break;
11106    end;
11107  end;
11108  SetLength(Result, n);
11109  Result := Result + Trailor;
11110end;
11111
11112function TGDBMIDebuggerCommand.GetStackDepth(MaxDepth: integer): Integer;
11113var
11114  R: TGDBMIExecResult;
11115  List: TGDBMINameValueList;
11116begin
11117  Result := -1;
11118  if (MaxDepth < 0) and (not ExecuteCommand('-stack-info-depth', R, [cfNoStackContext]))
11119  then exit;
11120  if (MaxDepth >= 0) and (not ExecuteCommand('-stack-info-depth %d', [MaxDepth], R, [cfNoStackContext]))
11121  then exit;
11122  if R.State = dsError
11123  then exit;
11124
11125  List := TGDBMINameValueList.Create(R);
11126  Result := StrToIntDef(List.Values['depth'], -1);
11127  FreeAndNil(List);
11128end;
11129
11130function TGDBMIDebuggerCommand.FindStackFrame(FP: TDBGPtr; StartAt,
11131  MaxDepth: Integer): Integer;
11132var
11133  R: TGDBMIExecResult;
11134  List: TGDBMINameValueList;
11135  Cur, Prv: QWord;
11136  CurContext: TGDBMICommandContext;
11137begin
11138  // Result;
11139  // -1 : Not found
11140  // -2 : FP is outside stack
11141  Result := StartAt;
11142  Cur := 0;
11143  List := TGDBMINameValueList.Create('');
11144  try
11145    CurContext := FContext;
11146    FContext.ThreadContext := ccUseGlobal;
11147    FContext.StackContext := ccUseLocal;
11148    repeat
11149      FContext.StackFrame := Result;
11150
11151      if not ExecuteCommand('-data-evaluate-expression $fp', R)
11152      or (R.State = dsError)
11153      then begin
11154        Result := -1;
11155        break;
11156      end;
11157
11158      List.Init(R.Values);
11159      Prv := Cur;
11160      Cur := StrToQWordDef(List.Values['value'], 0);
11161      if Fp = Cur then begin
11162        exit;
11163      end;
11164
11165      if (Prv <> 0) and (Prv < Cur)
11166      then begin
11167        // FP is increasing
11168        if FP < Prv
11169        then begin
11170          Result := -2;
11171          exit;
11172        end;
11173      end;
11174      if (Prv <> 0) and (Prv > Cur)
11175      then begin
11176        // FP is decreasing
11177        if FP > Prv
11178        then begin
11179          Result := -2;
11180          exit;
11181        end;
11182      end;
11183
11184      inc(Result);
11185    until Result > MaxDepth;
11186
11187    Result := -1;
11188  finally
11189    List.Free;
11190    FContext := CurContext;
11191  end;
11192end;
11193
11194function TGDBMIDebuggerCommand.GetFrame(const AIndex: Integer): String;
11195var
11196  R: TGDBMIExecResult;
11197  List: TGDBMINameValueList;
11198begin
11199  Result := '';
11200  if ExecuteCommand('-stack-list-frames %d %d', [AIndex, AIndex], R, [cfNoStackContext])
11201  then begin
11202    List := TGDBMINameValueList.Create(R, ['stack']);
11203    Result := List.Values['frame'];
11204    List.Free;
11205  end;
11206end;
11207
11208function TGDBMIDebuggerCommand.GetText(const ALocation: TDBGPtr): String;
11209var
11210  S: String;
11211begin
11212  Str(ALocation, S);
11213  Result := GetText(S, []);
11214end;
11215
11216function TGDBMIDebuggerCommand.GetText(const AExpression: String;
11217  const AValues: array of const): String;
11218var
11219  R: TGDBMIExecResult;
11220begin
11221  if not ExecuteCommand('x/s ' + AExpression, AValues, R, [],
11222                       DebuggerProperties.TimeoutForEval)
11223  then begin
11224    FLastExecResult.State := dsError;
11225    Result := '';
11226    Exit;
11227  end;
11228  Result := ProcessGDBResultText(StripLN(R.Values));
11229end;
11230
11231function TGDBMIDebuggerCommand.GetChar(const AExpression: String;
11232  const AValues: array of const): String;
11233var
11234  R: TGDBMIExecResult;
11235begin
11236  if not ExecuteCommand('x/c ' + AExpression, AValues, R)
11237  then begin
11238    FLastExecResult.State := dsError;
11239    Result := '';
11240    Exit;
11241  end;
11242  Result := ProcessGDBResultText(StripLN(R.Values));
11243end;
11244
11245function TGDBMIDebuggerCommand.GetFloat(const AExpression: String;
11246  const AValues: array of const): String;
11247var
11248  R: TGDBMIExecResult;
11249begin
11250  if not ExecuteCommand('x/f ' + AExpression, AValues, R)
11251  then begin
11252    Result := '';
11253    Exit;
11254  end;
11255  Result := ProcessGDBResultText(StripLN(R.Values));
11256end;
11257
11258function TGDBMIDebuggerCommand.GetWideText(const ALocation: TDBGPtr): String;
11259
11260  function GetWideChar(const ALocation: TDBGPtr): WideChar;
11261  var
11262    Address, S: String;
11263    R: TGDBMIExecResult;
11264  begin
11265    Str(ALocation, Address);
11266    if not ExecuteCommand('x/uh' + Address, [], R)
11267    then begin
11268      Result := #0;
11269      Exit;
11270    end;
11271    S := StripLN(R.Values);
11272    S := GetPart(['\t'], [], S);
11273    Result := WideChar(StrToIntDef(S, 0) and $FFFF);
11274  end;
11275var
11276  OneChar: WideChar;
11277  CurLocation: TDBGPtr;
11278  WStr: WideString;
11279begin
11280  WStr := '';
11281  CurLocation := ALocation;
11282  repeat
11283    OneChar := GetWideChar(CurLocation);
11284    if OneChar <> #0 then
11285    begin
11286      WStr := WStr + OneChar;
11287      CurLocation := CurLocation + 2;
11288    end;
11289  until (OneChar = #0) or (Length(WStr) > DebuggerProperties.MaxDisplayLengthForString);
11290  Result := UTF16ToUTF8(WStr);
11291end;
11292
11293function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String;
11294  FullTypeInfo: Boolean; AFlags: TGDBTypeCreationFlags; AFormat: TWatchDisplayFormat;
11295  ARepeatCount: Integer): TGDBType;
11296var
11297  R: TGDBMIExecResult;
11298  f: Boolean;
11299  AReq: PGDBPTypeRequest;
11300  CReq: TGDBPTypeRequest;
11301  i: Integer;
11302begin
11303  (*   Analyze what type is in AExpression
11304     * "whatis AExpr"
11305       This return the declared type of the expression (as in the pascal source)
11306       - The type may be replaced:
11307         - type TAlias = TOriginal; // TAlias may be reported as TOriginal
11308           type TAlias = type TOriginal; // Not guranteed, but not likely to be replaced
11309                                       // This leaves room for arbitraty names for all types
11310         - ^TFoo may be replaced by PFF, if PFF exist and is ^TFoo (seen with stabs, not dwarf)
11311       - The type may be prefixed by "&" for var param under dwarf (an fpc workaround)
11312         Under dwarf var param are hnadled by gdb, if casted or part of an expression,
11313           but not if standalone or dereferred ("^") only
11314         Under stabs "var param" have no indications, but are completely and correctly
11315           handled by gdb
11316
11317     * ptype TheWhatisType
11318       Should return the base type info
11319       Since under dwarf classes are always pointers (again work in expression,
11320         but not standalone); a further "whatis" on the declared-type may be needed,
11321         to check if the type is a pointer or not.
11322         This may be limited, if types are strongly aliased over several levels...
11323
11324     * tfClassIsPointer in TargetFlags
11325       usually true for dwarf, false for stabs. Can be detected with "ptype TObject"
11326       Dwarf:
11327         "ptype TObject" => ~"type = ^TOBJECT = class \n"
11328       Stabs:
11329         "ptype TObject" => ~ ~"type = TOBJECT = class \n"
11330
11331     * Examples
11332       * Type-info for objects
11333         TFoo = Tobject; PFoo = ^TFoo;
11334         ArgTFoo: TFoo;    ArgPFoo: PFoo
11335         Dwarf:
11336           "whatis ArgTFoo\n" => ~"type = TFOO\n"    (for var-param ~"type = &TFOO\n")
11337           "ptype TFoo\n"     => ~"type = ^TFOO = class : public TOBJECT \n"
11338
11339           whatis ArgPFoo\n"  => ~"type = PFOO\n"
11340           "ptype PFoo\n"     => ~"type = ^TFOO = class : public TOBJECT \n"
11341
11342           // ptype is the same for TFoo and PFoo, so we need to find out if any is a pointer:
11343           // they both have "^", but PFoo does not have "= class"
11344           // (this may fial if pfoo is an alias for yet another name)
11345           "whatis TFoo\n"    => ~"type = ^TFOO = class \n"
11346           "whatis PFoo\n"    => ~"type = ^TFOO\n"
11347
11348         Stabs:
11349           "whatis ArgTFoo\n" => ~"type = TFOO\n"    (same vor var param)
11350           "ptype TFoo\n"     => ~"type = TFOO = class : public TOBJECT \n"
11351
11352           "whatis ArgPFoo\n" => ~"type = PFOO\n"
11353           ptype PFoo\n"      => ~"type = ^TFOO = class : public TOBJECT \n"
11354
11355           // ptype gives desired info in stabs (and whatis, does not reveal anything)
11356           "whatis TFoo\n"    => ~"type = TFOO\n"
11357           "whatis PFoo\n"    => ~"type = PFOO\n"
11358
11359         Limitations: Under Mac gdb 6.3.50 "whatis" does not work on types.
11360                      The info can not be obtained (with Dwarf: PFoo will be treated the same as TFoo)
11361       *
11362
11363  *)
11364
11365  if tfClassIsPointer in TargetInfo^.TargetFlags
11366  then AFlags := AFlags + [gtcfClassIsPointer];
11367  if FullTypeInfo
11368  then AFlags := AFlags + [gtcfFullTypeInfo];
11369  Result := TGdbType.CreateForExpression(AExpression, AFlags, wdfDefault, ARepeatCount);
11370  while not Result.ProcessExpression do begin
11371    if Result.EvalError
11372    then break;
11373    AReq := Result.EvalRequest;
11374    while AReq <> nil do begin
11375      if (dcsCanceled in SeenStates) then begin
11376        FreeAndNil(Result);
11377        exit;
11378      end;
11379
11380      i := FTheDebugger.FTypeRequestCache.IndexOf(ContextThreadId, ContextStackFrame, AReq^);
11381      if i >= 0 then begin
11382        debugln(DBGMI_QUEUE_DEBUG, ['DBG TypeRequest-Cache: Found entry for T=',  ContextThreadId,
11383          ' F=', ContextStackFrame, ' R="', AReq^.Request,'"']);
11384        CReq := FTheDebugger.FTypeRequestCache.Request[i];
11385        AReq^.Result := CReq.Result;
11386        AReq^.Error := CReq.Error;
11387        //TODO: get rid of FLastExecResult
11388        FLastExecResult.State := dsError;
11389        FLastExecResult.Values := CReq.Result.GdbDescription;
11390      end
11391      else begin
11392        f :=  ExecuteCommand(AReq^.Request, R);
11393        if f and (R.State <> dsError) then begin
11394          if AReq^.ReqType = gcrtPType
11395          then AReq^.Result := ParseTypeFromGdb(R.Values)
11396          else begin
11397            AReq^.Result.GdbDescription := R.Values;
11398            AReq^.Result.Kind := ptprkSimple;
11399          end;
11400        end
11401        else begin
11402          AReq^.Result.GdbDescription := R.Values;
11403          AReq^.Error := R.Values;
11404        end;
11405
11406        FTheDebugger.FTypeRequestCache.Add(ContextThreadId, ContextStackFrame, AReq^);
11407      end;
11408
11409      AReq := AReq^.Next;
11410    end;
11411  end;
11412
11413  if Result.EvalError then begin
11414    FreeAndNil(Result);
11415  end;
11416end;
11417
11418function TGDBMIDebuggerCommand.GetClassName(const AClass: TDBGPtr): String;
11419var
11420  S: String;
11421begin
11422  // format has a problem with %u, so use Str for it
11423  Str(AClass, S);
11424  Result := GetClassName(S, []);
11425end;
11426
11427function TGDBMIDebuggerCommand.GetClassName(const AExpression: String;
11428  const AValues: array of const): String;
11429var
11430  OK: Boolean;
11431  S: String;
11432  R: TGDBMIExecResult;
11433  ResultList: TGDBMINameValueList;
11434  UseShortString: Boolean;
11435  i: Integer;
11436begin
11437  Result := '';
11438  UseShortString := False;
11439
11440  if dfImplicidTypes in FTheDebugger.DebuggerFlags
11441  then begin
11442    S := Format(AExpression, AValues);
11443    UseShortString := tfFlagHasTypeShortstring in TargetInfo^.TargetFlags;
11444    if UseShortString
11445    then s := Format('^^shortstring(%s+%d)^^', [S, TargetInfo^.TargetPtrSize * 3])
11446    else s := Format('^^char(%s+%d)^', [S, TargetInfo^.TargetPtrSize * 3]);
11447    OK :=  ExecuteCommand('-data-evaluate-expression %s',
11448          [S], R);
11449    if (not OK) or (LastExecResult.State = dsError)
11450    or (pos('value="#0', LastExecResult.Values) > 0)
11451    then begin
11452      OK :=  ExecuteCommand('-data-evaluate-expression ^char(^pointer(%s+%d)^)',
11453             [S, TargetInfo^.TargetPtrSize * 3], R);
11454      UseShortString := False;
11455    end;
11456  end
11457  else begin
11458    UseShortString := True;
11459    Str(TDbgPtr(GetData(AExpression + '+12', AValues)), S);
11460    OK := ExecuteCommand('-data-evaluate-expression pshortstring(%s)^', [S], R);
11461  end;
11462
11463  if OK
11464  then begin
11465    ResultList := TGDBMINameValueList.Create(R);
11466    S := ResultList.Values['value'];
11467    if UseShortString then begin
11468      Result := GetPart('''', '''', S);
11469    end
11470    else begin
11471      s := ParseGDBString(s);
11472      if s <> ''
11473      then i := ord(s[1])
11474      else i := 1;
11475      if i <= length(s)-1 then begin
11476        Result := copy(s, 2, i);
11477      end
11478      else begin
11479        // fall back
11480        S := DeleteEscapeChars(S);
11481        Result := GetPart('''', '''', S);
11482      end;
11483    end;
11484
11485    ResultList.Free;
11486  end;
11487end;
11488
11489function TGDBMIDebuggerCommand.GetInstanceClassName(const AInstance: TDBGPtr): String;
11490var
11491  S: String;
11492begin
11493  Str(AInstance, S);
11494  Result := GetInstanceClassName(S, []);
11495end;
11496
11497function TGDBMIDebuggerCommand.GetInstanceClassName(const AExpression: String;
11498  const AValues: array of const): String;
11499begin
11500  if dfImplicidTypes in FTheDebugger.DebuggerFlags
11501  then begin
11502    Result := GetClassName('^' + PointerTypeCast + '(' + AExpression + ')^', AValues);
11503  end
11504  else begin
11505    Result := GetClassName(GetData(AExpression, AValues));
11506  end;
11507end;
11508
11509function TGDBMIDebuggerCommand.GetData(const ALocation: TDbgPtr): TDbgPtr;
11510var
11511  S: String;
11512begin
11513  Str(ALocation, S);
11514  Result := GetData(S, []);
11515end;
11516
11517function TGDBMIDebuggerCommand.GetData(const AExpression: String;
11518  const AValues: array of const): TDbgPtr;
11519var
11520  R: TGDBMIExecResult;
11521  e: Integer;
11522begin
11523  Result := 0;
11524  if ExecuteCommand('x/d ' + AExpression, AValues, R)
11525  then Val(StripLN(GetPart('\t', '', R.Values)), Result, e);
11526  if e=0 then ;
11527end;
11528
11529function TGDBMIDebuggerCommand.GetStrValue(const AExpression: String;
11530  const AValues: array of const): String;
11531var
11532  R: TGDBMIExecResult;
11533  ResultList: TGDBMINameValueList;
11534begin
11535  if ExecuteCommand('-data-evaluate-expression %s', [Format(AExpression, AValues)], R)
11536  then begin
11537    ResultList := TGDBMINameValueList.Create(R);
11538    Result := DeleteEscapeChars(ResultList.Values['value']);
11539    ResultList.Free;
11540  end
11541  else Result := '';
11542end;
11543
11544function TGDBMIDebuggerCommand.GetIntValue(const AExpression: String;
11545  const AValues: array of const): Integer;
11546var
11547  e: Integer;
11548begin
11549  Result := 0;
11550  Val(GetStrValue(AExpression, AValues), Result, e);
11551  if e=0 then ;
11552end;
11553
11554function TGDBMIDebuggerCommand.GetPtrValue(const AExpression: String;
11555  const AValues: array of const; ConvertNegative: Boolean = False): TDbgPtr;
11556var
11557  e: Integer;
11558  i: Int64;
11559  s: String;
11560begin
11561  Result := 0;
11562  s := GetStrValue(AExpression, AValues);
11563  if (s <> '') and (s[1] = '-')
11564  then begin
11565    Val(s, i, e);
11566    Result := TDBGPtr(i);
11567  end
11568  else Val(s, Result, e);
11569  if e=0 then ;
11570end;
11571
11572function TGDBMIDebuggerCommand.CheckHasType(TypeName: String;
11573  TypeFlag: TGDBMITargetFlag): TGDBMIExecResult;
11574begin
11575  if not ExecuteCommand('ptype %s', [TypeName], Result, [], DebuggerProperties.TimeoutForEval) then begin
11576    Result.State := dsError;
11577    exit;
11578  end;
11579  if (LeftStr(Result.Values, 6) = 'type =') then
11580    include(TargetInfo^.TargetFlags, TypeFlag);
11581end;
11582
11583function TGDBMIDebuggerCommand.PointerTypeCast: string;
11584begin
11585  if tfFlagHasTypePointer in TargetInfo^.TargetFlags
11586  then Result := 'POINTER'
11587  // TODO: check dfImplicidTypes support?
11588  else if tfFlagHasTypeByte in TargetInfo^.TargetFlags
11589  then Result := '^byte'
11590  else Result := '^char';
11591end;
11592
11593function TGDBMIDebuggerCommand.FrameToLocation(const AFrame: String): TDBGLocationRec;
11594var
11595  S: String;
11596  e: Integer;
11597  Frame: TGDBMINameValueList;
11598begin
11599  // Do we have a frame ?
11600  if AFrame = ''
11601  then S := GetFrame(0)
11602  else S := AFrame;
11603
11604  Frame := TGDBMINameValueList.Create(S);
11605
11606  Result.Address := 0;
11607  Val(Frame.Values['addr'], Result.Address, e);
11608  if e=0 then ;
11609  Result.FuncName := Frame.Values['func'];
11610  Result.SrcFile := ConvertGdbPathAndFile(Frame.Values['file']);
11611  Result.SrcFullName := ConvertGdbPathAndFile(Frame.Values['fullname']);
11612  Result.SrcLine := StrToIntDef(Frame.Values['line'], -1);
11613
11614  Frame.Free;
11615end;
11616
11617procedure TGDBMIDebuggerCommand.ProcessFrame(ALocation: TDBGLocationRec;
11618  ASeachStackForSource: Boolean);
11619begin
11620  // TODO: process stack in gdbmi debugger // currently: signal IDE
11621  if (not ASeachStackForSource) and (ALocation.SrcLine < 0) then
11622    ALocation.SrcLine := -2;
11623  FTheDebugger.DoCurrent(ALocation); // TODO: only selected callers
11624  FTheDebugger.FCurrentLocation := ALocation;
11625end;
11626
11627procedure TGDBMIDebuggerCommand.ProcessFrame(const AFrame: String;
11628  ASeachStackForSource: Boolean);
11629var
11630  Location: TDBGLocationRec;
11631begin
11632  Location := FrameToLocation(AFrame);
11633  ProcessFrame(Location, ASeachStackForSource);
11634end;
11635
11636procedure TGDBMIDebuggerCommand.DoDbgEvent(const ACategory: TDBGEventCategory;
11637  const AEventType: TDBGEventType; const AText: String);
11638begin
11639  FTheDebugger.DoDbgEvent(ACategory, AEventType, AText);
11640end;
11641
11642constructor TGDBMIDebuggerCommand.Create(AOwner: TGDBMIDebugger);
11643begin
11644  FQueueRunLevel := -1;
11645  FState := dcsNone;
11646  FTheDebugger := AOwner;
11647  FContext.StackContext := ccUseGlobal;
11648  FContext.ThreadContext := ccUseGlobal;
11649  FDefaultTimeOut := -1;
11650  FPriority := 0;
11651  FProperties := [];
11652  AddReference; // internal reference
11653end;
11654
11655destructor TGDBMIDebuggerCommand.Destroy;
11656begin
11657  if assigned(FOnDestroy)
11658  then FOnDestroy(Self);
11659  inherited Destroy;
11660end;
11661
11662procedure TGDBMIDebuggerCommand.DoQueued;
11663begin
11664  SetCommandState(dcsQueued);
11665end;
11666
11667procedure TGDBMIDebuggerCommand.DoFinished;
11668begin
11669  SetCommandState(dcsFinished);
11670end;
11671
11672function TGDBMIDebuggerCommand.Execute: Boolean;
11673begin
11674  // Set the state first, so DoExecute can set an error-state
11675  SetCommandState(dcsExecuting);
11676  AddReference;
11677  DoLockQueueExecute;
11678  try
11679    Result := DoExecute;
11680    DoOnExecuted;
11681  except
11682
11683    On E: Exception do FTheDebugger.DoUnknownException(Self, E)
11684    else
11685      debugln(['ERROR: Exception occurred in ',ClassName+'.DoExecute ',
11686                '" Addr=', dbgs(ExceptAddr), ' Dbg.State=', dbgs(FTheDebugger.State)]);
11687  end;
11688  // No re-raise in the except block. So no try-finally required
11689  DoUnLockQueueExecute;
11690  ReleaseReference;
11691end;
11692
11693procedure TGDBMIDebuggerCommand.Cancel;
11694begin
11695  debugln(DBGMI_QUEUE_DEBUG, ['Canceling: "', DebugText,'"']);
11696  FTheDebugger.UnQueueCommand(Self);
11697  DoCancel;
11698  DoOnCanceled;
11699  SetCommandState(dcsCanceled);
11700end;
11701
11702function TGDBMIDebuggerCommand.KillNow: Boolean;
11703begin
11704  Result := False;
11705end;
11706
11707function TGDBMIDebuggerCommand.DebugText: String;
11708begin
11709  Result := ClassName;
11710end;
11711
11712{ TGDBMIDebuggerCommandList }
11713
11714function TGDBMIDebuggerCommandList.Get(Index: Integer): TGDBMIDebuggerCommand;
11715begin
11716  Result := TGDBMIDebuggerCommand(inherited Items[Index]);
11717end;
11718
11719procedure TGDBMIDebuggerCommandList.Put(Index: Integer; const AValue: TGDBMIDebuggerCommand);
11720begin
11721  inherited Items[Index] := AValue;
11722end;
11723
11724{ TGDBMIInternalBreakPoint }
11725
11726procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand;
11727  ALoc: TInternalBreakLocation; ABlock: TBlockOpt);
11728begin
11729  if (FBreaks[ALoc].BreakGdbId = -2) and (ABlock <> boUnblock) then exit;
11730  if (FBreaks[ALoc].BreakGdbId = -1) then exit;
11731
11732  if (FBreaks[ALoc].BreakGdbId >= 0) then
11733    ACmd.ExecuteCommand('-break-delete %d', [FBreaks[ALoc].BreakGdbId], [cfCheckError]);
11734  if ABlock = boBlock then
11735    FBreaks[ALoc].BreakGdbId := -2
11736  else
11737    FBreaks[ALoc].BreakGdbId := -1;
11738
11739  FBreaks[ALoc].BreakAddr := 0;
11740  FBreaks[ALoc].BreakFunction := '';
11741  FBreaks[ALoc].BreakFile := '';
11742  FBreaks[ALoc].BreakLine := '';
11743
11744  FEnabled := FEnabled and IsBreakSet;
11745
11746  if ALoc = iblAddrOfNamed then FMainAddrFound := 0;
11747end;
11748
11749function TGDBMIInternalBreakPoint.BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
11750  ALoc: TInternalBreakLocation; AClearIfSet: TClearOpt): Boolean;
11751var
11752  R: TGDBMIExecResult;
11753  ResultList: TGDBMINameValueList;
11754begin
11755  Result := True; // true, if already set (dsError does not matter)
11756  if ACmd.DebuggerState = dsError then exit;
11757
11758  if AClearIfSet = coClearIfSet then
11759    Clear(ACmd, ALoc);                         // keeps blocked indicator
11760  if FBreaks[ALoc].BreakGdbId <> -1 then exit; // not(set or blocked)
11761
11762  FBreaks[ALoc].BreakGdbId := -1;
11763  FBreaks[ALoc].BreakAddr := 0;
11764  FBreaks[ALoc].BreakFunction := '';
11765
11766  if UseForceFlag and (dfForceBreak in ACmd.FTheDebugger.FDebuggerFlags) then
11767  begin
11768    if (not ACmd.ExecuteCommand('-break-insert -f %s', [ABreakLoc], R)) or
11769       (R.State = dsError)
11770    then
11771      ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
11772  end
11773  else
11774    ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
11775  Result := R.State <> dsError;
11776  if not Result then exit;
11777  FEnabled := True; // TODO: What if some bp are disabled?
11778
11779  ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
11780  FBreaks[ALoc].BreakGdbId    := StrToIntDef(ResultList.Values['number'], -1);
11781  FBreaks[ALoc].BreakAddr     := StrToQWordDef(ResultList.Values['addr'], 0);
11782  FBreaks[ALoc].BreakFunction := ResultList.Values['func'];
11783  FBreaks[ALoc].BreakFile     := ResultList.Values['fullname'];
11784  if FBreaks[ALoc].BreakFile = '' then
11785    FBreaks[ALoc].BreakFile     := ResultList.Values['file'];
11786  FBreaks[ALoc].BreakLine     := ResultList.Values['line'];
11787  ResultList.Free;
11788end;
11789
11790function TGDBMIInternalBreakPoint.GetBreakAddr(ALoc: TInternalBreakLocation): TDBGPtr;
11791begin
11792  Result := FBreaks[ALoc].BreakAddr;
11793end;
11794
11795function TGDBMIInternalBreakPoint.GetBreakFile(ALoc: TInternalBreakLocation): String;
11796begin
11797  Result := FBreaks[ALoc].BreakFile;
11798end;
11799
11800function TGDBMIInternalBreakPoint.GetBreakId(ALoc: TInternalBreakLocation): Integer;
11801begin
11802  Result := FBreaks[ALoc].BreakGdbId;
11803end;
11804
11805function TGDBMIInternalBreakPoint.GetBreakLine(ALoc: TInternalBreakLocation): String;
11806begin
11807  Result := FBreaks[ALoc].BreakLine;
11808end;
11809
11810function TGDBMIInternalBreakPoint.GetInfoAddr(ACmd: TGDBMIDebuggerCommand): TDBGPtr;
11811var
11812  R: TGDBMIExecResult;
11813  S: String;
11814begin
11815  Result := FMainAddrFound;
11816  if Result <> 0 then
11817    exit;
11818  if ACmd.DebuggerState = dsError then Exit;
11819  if (not ACmd.ExecuteCommand('info address ' + FName, R)) or
11820     (R.State = dsError)
11821  then exit;
11822  S := GetPart(['at address ', ' at '], ['.', ' '], R.Values);
11823  if S <> '' then
11824    Result := StrToQWordDef(S, 0);
11825  FMainAddrFound := Result;
11826end;
11827
11828function TGDBMIInternalBreakPoint.HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
11829var
11830  i: TInternalBreakLocation;
11831begin
11832  Result := True;
11833  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11834    if (FBreaks[i].BreakGdbId >= 0) and (FBreaks[i].BreakAddr = AnAddr) then
11835      exit;
11836  Result := False;
11837end;
11838
11839function TGDBMIInternalBreakPoint.HasBreakWithId(AnId: Integer): Boolean;
11840var
11841  i: TInternalBreakLocation;
11842begin
11843  Result := True;
11844  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11845    if (FBreaks[i].BreakGdbId = AnId) then
11846      exit;
11847  Result := False;
11848end;
11849
11850procedure TGDBMIInternalBreakPoint.InternalSetAddr(ACmd: TGDBMIDebuggerCommand;
11851  ALoc: TInternalBreakLocation; AnAddr: TDBGPtr);
11852begin
11853  if (AnAddr = 0) or HasBreakAtAddr(AnAddr) then // HasBreakAddr includes this BP being allready at AnAddr.
11854    exit;
11855
11856  // Always ClearIfSet since the address changed
11857  BreakSet(ACmd, Format('*%u', [AnAddr]), ALoc, coClearIfSet);
11858end;
11859
11860constructor TGDBMIInternalBreakPoint.Create(AName: string);
11861var
11862  i: TInternalBreakLocation;
11863begin
11864  FMainAddrFound := 0;
11865  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do begin
11866    FBreaks[i].BreakGdbId := -1;
11867    FBreaks[i].BreakAddr := 0;
11868  end;
11869  FUseForceFlag := False;
11870  FName := AName;
11871  FEnabled := False;
11872end;
11873
11874(* Using -insert-break with a function name allows GDB to adjust the address
11875   to be behind the functions initialization.
11876   Which means values passed by register may no longer be accessible.
11877   Therefore we determine the address and force the breakpoint to it.
11878   This does not work for position independent executables (PIE), if the
11879   breakpoint is set before the application is run, because the real address
11880   is only known at run time.
11881   Therefore during startup a named break point is used as fallback.
11882*)
11883procedure TGDBMIInternalBreakPoint.SetBoth(ACmd: TGDBMIDebuggerCommand);
11884begin
11885  if not BreakSet(ACmd, FName, iblNamed, coKeepIfSet) then exit;
11886
11887  if FBreaks[iblAddrOfNamed].BreakGdbId = -2 then exit;
11888  // Try to retrieve the address of the procedure
11889  InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
11890end;
11891
11892procedure TGDBMIInternalBreakPoint.SetByName(ACmd: TGDBMIDebuggerCommand);
11893begin
11894  BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
11895  // keep others
11896end;
11897
11898procedure TGDBMIInternalBreakPoint.SetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
11899begin
11900  if FBreaks[iblAddrOfNamed].BreakGdbId <> -2 then
11901    InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
11902
11903  // SetNamedOnFail includes if blocked
11904  {$ifdef WIN64}
11905  If SetNamedOnFail and (FBreaks[iblNamed].BreakGdbId < 0) and
11906     (FBreaks[iblAddrOfNamed].BreakGdbId < 0) and
11907     ( (FMainAddrFound = 0) or (not HasBreakAtAddr(FMainAddrFound)) )
11908  then
11909  {$else}
11910  If SetNamedOnFail and (FBreaks[iblNamed].BreakGdbId < 0) then
11911  {$endif}
11912    BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
11913end;
11914
11915procedure TGDBMIInternalBreakPoint.SetAtCustomAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
11916begin
11917  InternalSetAddr(ACmd, iblCustomAddr, AnAddr);
11918end;
11919
11920procedure TGDBMIInternalBreakPoint.SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
11921begin
11922  // always clear, and set again
11923  if AnOffset < 0 then
11924    BreakSet(ACmd, Format('%d', [AnOffset]), iblAddOffset, coClearIfSet)
11925  else
11926    BreakSet(ACmd, Format('+%d', [AnOffset]), iblAddOffset, coClearIfSet);
11927end;
11928
11929procedure TGDBMIInternalBreakPoint.SetAtFileLine(ACmd: TGDBMIDebuggerCommand; AFile,
11930  ALine: String);
11931begin
11932  AFile := StringReplace(AFile, '\', '/', [rfReplaceAll]);
11933  BreakSet(ACmd, Format(' "\"%s\":%s"', [AFile, ALine]), iblFileLine, coKeepIfSet);
11934end;
11935
11936procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand);
11937var
11938  i: TInternalBreakLocation;
11939begin
11940  if ACmd.DebuggerState = dsError then Exit;
11941  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11942    Clear(ACmd, i, boUnblock);
11943  FEnabled := False;
11944end;
11945
11946function TGDBMIInternalBreakPoint.ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
11947var
11948  i: TInternalBreakLocation;
11949begin
11950  Result := False;
11951  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11952    if (AnId = FBreaks[i].BreakGdbId) then begin
11953      Clear(ACmd, i);
11954      Result := True;
11955      break;
11956    end;
11957end;
11958
11959function TGDBMIInternalBreakPoint.ClearAndBlockId(ACmd: TGDBMIDebuggerCommand;
11960  AnId: Integer): Boolean;
11961var
11962  i: TInternalBreakLocation;
11963begin
11964  Result := False;
11965  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11966    if (AnId = FBreaks[i].BreakGdbId) then begin
11967      Clear(ACmd, i, boBlock);
11968      Result := True;
11969      break;
11970    end;
11971end;
11972
11973function TGDBMIInternalBreakPoint.MatchAddr(AnAddr: TDBGPtr): boolean;
11974begin
11975  Result := (AnAddr <> 0) and HasBreakAtAddr(AnAddr);
11976end;
11977
11978function TGDBMIInternalBreakPoint.MatchId(AnId: Integer): boolean;
11979begin
11980  Result := (AnId >= 0) and HasBreakWithId(AnId);
11981end;
11982
11983function TGDBMIInternalBreakPoint.IsBreakSet: boolean;
11984begin
11985  Result := BreakSetCount > 0;
11986end;
11987
11988function TGDBMIInternalBreakPoint.BreakSetCount: Integer;
11989var
11990  i: TInternalBreakLocation;
11991begin
11992  Result := 0;
11993  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
11994    if (FBreaks[i].BreakGdbId >= 0) then
11995      inc(Result);
11996end;
11997
11998procedure TGDBMIInternalBreakPoint.EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand;
11999  SetNamedOnFail: Boolean);
12000begin
12001  if IsBreakSet then
12002    Enable(ACmd)
12003  else
12004    SetByAddr(ACmd, SetNamedOnFail);
12005end;
12006
12007procedure TGDBMIInternalBreakPoint.Enable(ACmd: TGDBMIDebuggerCommand);
12008var
12009  R: TGDBMIExecResult;
12010  i: TInternalBreakLocation;
12011begin
12012  if FEnabled then exit;
12013  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
12014    if FBreaks[i].BreakGdbId >= 0 then begin
12015      ACmd.ExecuteCommand('-break-enable %d', [FBreaks[i].BreakGdbId], R);
12016      FEnabled := True;
12017    end;
12018end;
12019
12020procedure TGDBMIInternalBreakPoint.Disable(ACmd: TGDBMIDebuggerCommand);
12021var
12022  R: TGDBMIExecResult;
12023  i: TInternalBreakLocation;
12024begin
12025  if not FEnabled then exit;
12026  FEnabled := False;
12027  for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
12028    if FBreaks[i].BreakGdbId >= 0 then
12029      ACmd.ExecuteCommand('-break-disable %d', [FBreaks[i].BreakGdbId], R);
12030end;
12031
12032{$ifdef WIN64}
12033{ TGDBMIInternalAddrBreakPointList.TGDBMIInternalAddrBreakPointListEntry }
12034
12035class operator TGDBMIInternalAddrBreakPointList.TGDBMIInternalAddrBreakPointListEntry. = (a,
12036  b: TGDBMIInternalAddrBreakPointListEntry)c: Boolean;
12037begin
12038  raise Exception.Create(''); // should not get here
12039  c := false;
12040//  c := (a.FId = b.FId) and (a.FAddr = b.FAddr);
12041end;
12042
12043{ TGDBMIInternalAddrBreakPointList }
12044
12045function TGDBMIInternalAddrBreakPointList.IndexOfAddr(AnAddr: TDBGPtr): Integer;
12046begin
12047  Result := FList.Count - 1;
12048  while (Result >= 0) and (FList.List^[Result].FAddr <> AnAddr) do
12049    dec(Result);
12050end;
12051
12052function TGDBMIInternalAddrBreakPointList.IndexOfId(AnId: integer): Integer;
12053begin
12054  Result := FList.Count - 1;
12055  while (Result >= 0) and (FList.List^[Result].FId <> AnId) do
12056    dec(Result);
12057end;
12058
12059procedure TGDBMIInternalAddrBreakPointList.RemoveIndex(ACmd: TGDBMIDebuggerCommand;
12060  AnIndex: Integer);
12061var
12062  c, id: Integer;
12063begin
12064  if AnIndex < 0 then
12065    exit;
12066  c := FList.List^[AnIndex].FCount;
12067  FList.List^[AnIndex].FCount := c - 1;
12068  if c > 1 then
12069    exit;
12070
12071  id := FList.List^[AnIndex].FId;
12072  if id > 0 then
12073    ACmd.ExecuteCommand('-break-delete %d', [id], [cfCheckError]);
12074  FList.Delete(AnIndex);
12075end;
12076
12077constructor TGDBMIInternalAddrBreakPointList.Create;
12078begin
12079  FList := TBPEntryList.Create;
12080end;
12081
12082destructor TGDBMIInternalAddrBreakPointList.Destroy;
12083begin
12084  FList.Destroy;
12085  inherited Destroy;
12086end;
12087
12088procedure TGDBMIInternalAddrBreakPointList.AddAddr(ACmd: TGDBMIDebuggerCommand;
12089  AnAddr: TDBGPtr);
12090var
12091  R: TGDBMIExecResult;
12092  E: TGDBMIInternalAddrBreakPointListEntry;
12093  ResultList: TGDBMINameValueList;
12094  i: Integer;
12095begin
12096  i := IndexOfAddr(AnAddr);
12097  if i >= 0 then begin
12098    FList.List^[i].FCount := FList.List^[i].FCount + 1;
12099  end;
12100
12101  E.FCount := 1;
12102  E.FAddr := AnAddr;
12103
12104  ACmd.ExecuteCommand('-break-insert *%u', [AnAddr], R);
12105  if R.State <> dsError then begin
12106    ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
12107    E.FId := StrToIntDef(ResultList.Values['number'], -1);
12108    ResultList.Free;
12109  end
12110  else
12111    E.FId := -1;
12112
12113  FList.Add(E);
12114end;
12115
12116procedure TGDBMIInternalAddrBreakPointList.RemoveAddr(ACmd: TGDBMIDebuggerCommand;
12117  AnAddr: TDBGPtr);
12118begin
12119  RemoveIndex(ACmd, IndexOfAddr(AnAddr));
12120end;
12121
12122procedure TGDBMIInternalAddrBreakPointList.RemoveId(ACmd: TGDBMIDebuggerCommand;
12123  AnId: Integer);
12124begin
12125  RemoveIndex(ACmd, IndexOfId(AnId));
12126end;
12127
12128procedure TGDBMIInternalAddrBreakPointList.ClearAll(ACmd: TGDBMIDebuggerCommand);
12129var
12130  i: Integer;
12131  id: LongInt;
12132begin
12133  i := FList.Count - 1;
12134  while i >= 0 do begin
12135    id := FList.List^[i].FId;
12136    if id > 0 then
12137      ACmd.ExecuteCommand('-break-delete %d', [id], [cfCheckError]);
12138    FList.Delete(i);
12139    dec(i);
12140  end;
12141end;
12142
12143function TGDBMIInternalAddrBreakPointList.HasBreakId(AnId: Integer): boolean;
12144begin
12145  Result := IndexOfId(AnId) >= 0;
12146end;
12147{$endif}
12148
12149{ TGDBMIDebuggerSimpleCommand }
12150
12151constructor TGDBMIDebuggerSimpleCommand.Create(AOwner: TGDBMIDebugger;
12152  const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags;
12153  const ACallback: TGDBMICallback; const ATag: PtrInt);
12154begin
12155  inherited Create(AOwner);
12156  FCommand := Format(ACommand, AValues);
12157  FFlags := AFlags;
12158  FCallback := ACallback;
12159  FTag := ATag;
12160  FResult.Values := '';
12161  FResult.State := dsNone;
12162  FResult.Flags := [];
12163end;
12164
12165function TGDBMIDebuggerSimpleCommand.DebugText: String;
12166begin
12167  Result := Format('%s: %s', [ClassName, FCommand]);
12168end;
12169
12170function TGDBMIDebuggerSimpleCommand.DoExecute: Boolean;
12171begin
12172  Result := True;
12173  if not ExecuteCommand(FCommand, FResult, FFlags)
12174  then exit;
12175
12176  if (FResult.State <> dsNone)
12177  and not (cfscIgnoreState in FFlags)
12178  and ((FResult.State <> dsError) or not (cfscIgnoreError in FFlags))
12179  then SetDebuggerState(FResult.State);
12180
12181  if Assigned(FCallback)
12182  then FCallback(FResult, FTag);
12183end;
12184
12185{ TGDBMIDebuggerCommandEvaluate }
12186
12187function TGDBMIDebuggerCommandEvaluate.GetTypeInfo: TGDBType;
12188begin
12189  Result := FTypeInfo;
12190  // if the command wasn't executed, typeinfo may still get set, and need auto-destroy
12191  FTypeInfoAutoDestroy := FTypeInfo = nil;
12192end;
12193
12194procedure TGDBMIDebuggerCommandEvaluate.DoWatchFreed(Sender: TObject);
12195begin
12196  debugln(DBGMI_QUEUE_DEBUG, ['DoWatchFreed: ', DebugText]);
12197  FWatchValue := nil;
12198  Cancel;
12199end;
12200
12201procedure TGDBMIDebuggerCommandEvaluate.DoLockQueueExecute;
12202begin
12203  FLockFlag := FWatchValue = nil;
12204  //if FLockFlag then
12205  //  inherited DoLockQueueExecute;
12206end;
12207
12208procedure TGDBMIDebuggerCommandEvaluate.DoUnLockQueueExecute;
12209begin
12210  //if FLockFlag then
12211  //  inherited DoUnLockQueueExecute;
12212end;
12213
12214procedure TGDBMIDebuggerCommandEvaluate.DoLockQueueExecuteForInstr;
12215begin
12216  //
12217end;
12218
12219procedure TGDBMIDebuggerCommandEvaluate.DoUnLockQueueExecuteForInstr;
12220begin
12221  //
12222end;
12223
12224function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
12225var
12226  TypeInfoFlags: TGDBTypeCreationFlags;
12227
12228  function FormatResult(const AInput: String; IsArray: Boolean = False): String;
12229  const
12230    INDENTSTRING = '  ';
12231  var
12232    Indent: String;
12233    i: Integer;
12234    InStr: Boolean;
12235    InBrackets, InRounds: Integer;
12236    Limit: Integer;
12237    Skip: Integer;
12238  begin
12239    Indent := '';
12240    Skip := 0;
12241    InStr := False;
12242    InBrackets := 0;
12243    InRounds := 0;
12244    Limit := Length(AInput);
12245    Result := '';
12246
12247    for i := 1 to Limit do
12248    begin
12249      if Skip>0
12250      then begin
12251        Dec(SKip);
12252        Continue;
12253      end;
12254
12255      if AInput[i] in [#10, #13]
12256      then begin
12257        //Removes unneeded LineEnding.
12258        Continue;
12259      end;
12260
12261      Result := Result + AInput[i];
12262      if InStr
12263      then begin
12264        InStr := AInput[i] <> '''';
12265        Continue;
12266      end;
12267
12268      if InBrackets > 0
12269      then begin
12270        if AInput[i] = ']' then
12271          dec(InBrackets);
12272        Continue;
12273      end;
12274
12275      case AInput[i] of
12276        '[': begin
12277          inc(InBrackets);
12278        end;
12279        '(': begin
12280          inc(InRounds);
12281        end;
12282        ')': begin
12283          if InRounds > 0 then
12284            dec(InRounds);
12285        end;
12286        '''': begin
12287          InStr:=true;
12288        end;
12289        '{': begin
12290           if (i < Limit) and (AInput[i+1] <> '}')
12291           then begin
12292             Indent := Indent + INDENTSTRING;
12293             if (not IsArray) or (InRounds = 0) then
12294               Result := Result + LineEnding + Indent;
12295           end;
12296        end;
12297        '}': begin
12298           if (i > 1) and (AInput[i-1] <> '{') and
12299              ((not IsArray) or (InRounds = 0))
12300           then Delete(Indent, 1, Length(INDENTSTRING));
12301        end;
12302        ' ': begin
12303           if ((i > 1) and (AInput[i-1] = ',')) and
12304              ( (not IsArray) or
12305                ((Indent = '') and (InRounds <= 1)) or
12306                ((Indent = INDENTSTRING) and (InRounds = 0))
12307              )
12308           then Result := Result + LineEnding + Indent;
12309        end;
12310        '0': begin
12311           if (i > 4) and (i < Limit - 2)
12312           then begin
12313             //Pascalize pointers  "Var = 0x12345 => Var = $12345"
12314             if  (AInput[i-3] = ' ')
12315             and (AInput[i-2] = '=')
12316             and (AInput[i-1] = ' ')
12317             and (AInput[i+1] = 'x')
12318             then begin
12319               Skip := 1;
12320               Result[Length(Result)] := '$';
12321             end;
12322           end;
12323        end;
12324      end;
12325
12326    end;
12327  end;
12328
12329  function WhichIsFirst(const ASource: String; const ASearchable: array of Char): Integer;
12330  var
12331    j, k: Integer;
12332    InString: Boolean;
12333  begin
12334    InString := False;
12335    for j := 1 to Length(ASource) do
12336    begin
12337      if ASource[j] = '''' then InString := not InString;
12338      if InString then Continue;
12339
12340      for k := Low(ASearchable) to High(ASearchable) do
12341      begin
12342        if ASource[j] = ASearchable[k] then Exit(j);
12343      end;
12344    end;
12345    Result := -1;
12346  end;
12347
12348  function SkipPairs(var ASource: String; const ABeginChar: Char; const AEndChar: Char): String;
12349  var
12350    Deep,j: SizeInt;
12351    InString: Boolean;
12352  begin
12353    DebugLn(DBG_VERBOSE, '->->', ASource);
12354    Deep := 0;
12355    InString := False;
12356
12357    for j := 1 to Length(ASource) do
12358    begin
12359      if ASource[j]='''' then InString := not InString;
12360      if InString then Continue;
12361
12362      if ASource[j] = ABeginChar
12363      then begin
12364        Inc(Deep)
12365      end
12366      else begin
12367        if ASource[j] = AEndChar
12368        then Dec(Deep);
12369      end;
12370
12371      if Deep=0
12372      then begin
12373        Result := Copy(ASource, 1, j);
12374        ASource := Copy(ASource, j + 1, Length(ASource) - j);
12375        Exit;
12376      end;
12377    end;
12378  end;
12379
12380  function IsHexC(const ASource: String): Boolean;
12381  begin
12382    if Length(ASource) <= 2 then Exit(False);
12383    if ASource[1] <> '0' then Exit(False);
12384    Result := ASource[2] = 'x';
12385  end;
12386
12387  function HexCToHexPascal(const ASource: String; MinChars: Byte = 0): String;
12388  var
12389    Zeros: String;
12390  begin
12391    if IsHexC(Asource)
12392    then begin
12393      Result := Copy(ASource, 3, Length(ASource) - 2);
12394      if Length(Result) < MinChars then
12395      begin
12396        SetLength(Zeros, MinChars - Length(Result));
12397        FillChar(Zeros[1], Length(Zeros), '0');
12398        Result := Zeros + Result;
12399      end;
12400      Result := '$' + Result;
12401    end
12402    else Result := ASource;
12403  end;
12404
12405  procedure PutValuesInTypeRecord(const AType: TDBGType; const ATextInfo: String);
12406  var
12407    GDBParser: TGDBStringIterator;
12408    Payload, s: String;
12409    Composite: Boolean;
12410    StopChar: Char;
12411    j: Integer;
12412  begin
12413    GDBParser := TGDBStringIterator.Create(ATextInfo);
12414    GDBParser.ParseNext(Composite, Payload, StopChar);
12415    GDBParser.Free;
12416
12417    if not Composite
12418    then begin
12419      //It is not a record
12420      debugln(DBGMI_STRUCT_PARSER, 'Expected record, but found: "', ATextInfo, '"');
12421      exit;
12422    end;
12423
12424    //Parse information between brackets...
12425    GDBParser := TGDBStringIterator.Create(Payload);
12426    for j := 0 to AType.Fields.Count-1 do
12427    begin
12428      if not GDBParser.ParseNext(Composite, Payload, StopChar)
12429      then begin
12430        debugln(DBGMI_STRUCT_PARSER, 'Premature end of parsing');
12431        Break;
12432      end;
12433
12434      s := uppercase(AType.Fields[j].Name);
12435      if uppercase(Payload) <> s
12436      then begin
12437        debugln(DBGMI_STRUCT_PARSER, 'Field name does not match, expected "', AType.Fields[j].Name, '" but found "', Payload,'"');
12438        Break;
12439      end;
12440      if (Payload <> AType.Fields[j].Name) and (s = AType.Fields[j].Name) then begin
12441        // gdb returned different case
12442        AType.Fields[j].Name := Payload;
12443      end;
12444
12445      if StopChar <> '='
12446      then begin
12447        debugln(DBGMI_STRUCT_PARSER, 'Expected assignment, but other found.');
12448        Break;
12449      end;
12450
12451      //Field name verified...
12452      if not GDBParser.ParseNext(Composite, Payload, StopChar)
12453      then begin
12454        debugln(DBGMI_STRUCT_PARSER, 'Premature end of parsing');
12455        Break;
12456      end;
12457
12458      if Composite
12459      then THackDBGType(AType.Fields[j].DBGType).FKind := skRecord;
12460
12461      AType.Fields[j].DBGType.Value.AsString := HexCToHexPascal(Payload);
12462    end;
12463
12464    GDBParser.Free;
12465  end;
12466
12467  procedure PutValuesInClass(const AType: TGDBType; ATextInfo: String);
12468  var
12469    //GDBParser: TGDBStringIterator;
12470    //Payload: String;
12471    //Composite: Boolean;
12472    //StopChar: Char;
12473    //j: Integer;
12474    AWarnText: string;
12475    StartPtr, EndPtr: PChar;
12476
12477    Procedure SkipSpaces;
12478    begin
12479      while (StartPtr <= EndPtr) and (StartPtr^ = ' ') do inc(StartPtr);
12480    end;
12481
12482    Procedure SkipToEndOfField(EndAtComma: Boolean = False);
12483    var
12484      i, j: Integer;
12485    begin
12486      // skip forward, past the next ",", but do NOT skip the closing "}"
12487      i := 1;
12488      j := 0;
12489      while (StartPtr <= EndPtr) and (i > 0) do begin
12490        case StartPtr^ of
12491          '{': inc(i);
12492          '}': if i = 1
12493               then break  // do not skip }
12494               else dec(i);
12495          '[': inc(j);
12496          ']': dec(j);
12497          '''': begin
12498              inc(StartPtr);
12499              while (StartPtr <= EndPtr) and (StartPtr^ <> '''') do inc(StartPtr);
12500            end;
12501          ',': if (i = 1) and (j < 1) then begin
12502              if EndAtComma then break; // Do not increase StartPtr;
12503              i := 0;
12504            end;
12505        end;
12506        inc(StartPtr);
12507      end;
12508      SkipSpaces;
12509    end;
12510
12511    procedure ProcessAncestor(ATypeName: String);
12512    var
12513      HelpPtr, HelpPtr2: PChar;
12514      NewName, NewVal, Sn, Sc: String;
12515      i: Integer;
12516      NewField: TDBGField;
12517    begin
12518      inc(StartPtr); // skip '{'
12519      SkipSpaces;
12520      if StartPtr^ = '<' Then begin
12521        inc(StartPtr);
12522        HelpPtr := StartPtr;
12523        while (HelpPtr <= EndPtr) and (HelpPtr^ <> '>') do inc(HelpPtr);
12524        NewName := copy(StartPtr, 1, HelpPtr - StartPtr);
12525        StartPtr := HelpPtr + 1;
12526        SkipSpaces;
12527        if StartPtr^ <> '=' then begin
12528          debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "=" for ancestor "' + NewName + '" in: ' + AWarnText);
12529          AWarnText := '';
12530          SkipToEndOfField;
12531          // continue fields, or end
12532        end
12533        else begin
12534          inc(StartPtr);
12535          SkipSpaces;
12536          if StartPtr^ <> '{'
12537          then begin
12538            //It is not a class
12539            debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "{" for ancestor "' + NewName + '" in: ' + AWarnText);
12540            AWarnText := '';
12541            SkipToEndOfField;
12542          end
12543          else
12544            ProcessAncestor(NewName);
12545            if StartPtr^ = ',' then inc(StartPtr);
12546            SkipSpaces;
12547        end;
12548      end;
12549
12550      // process fields in this ancestor
12551      while (StartPtr <= EndPtr) and (StartPtr^ <> '}') do begin
12552        HelpPtr := StartPtr;
12553        while (HelpPtr < EndPtr) and not (HelpPtr^ in [' ', '=', ',']) do inc(HelpPtr);
12554        NewName := copy(StartPtr, 1, HelpPtr - StartPtr);  // name of field
12555
12556        StartPtr := HelpPtr;
12557        SkipSpaces;
12558        if StartPtr^ <> '=' then begin
12559          debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "=" for field"' + NewName + '" in: ' + AWarnText);
12560          AWarnText := '';
12561          SkipToEndOfField;
12562          continue;
12563        end;
12564
12565        inc(StartPtr);
12566        SkipSpaces;
12567        HelpPtr := StartPtr;
12568        SkipToEndOfField(True);
12569        HelpPtr2 := StartPtr; // "," or "}"
12570        dec(HelpPtr2);
12571        while HelpPtr2^ = ' ' do dec(HelpPtr2);
12572        NewVal := copy(HelpPtr, 1, HelpPtr2 + 1 - HelpPtr);  // name of field
12573
12574        i := AType.Fields.Count - 1;
12575        Sn := UpperCase(NewName);
12576        Sc := UpperCase(ATypeName);
12577        while (i >= 0)
12578        and ( (uppercase(AType.Fields[i].Name) <> Sn)
12579           or (uppercase(AType.Fields[i].ClassName) <> Sc) )
12580        do dec(i);
12581
12582        if i < 0 then begin
12583          if (Sc <> 'TOBJECT') or (pos('VPTR', Sn) < 1) then begin
12584            if not(defFullTypeInfo in FEvalFlags) then begin
12585              NewField := TDBGField.Create(NewName, TGDBType.Create(skSimple, ''), flPublic, [], '');
12586              AType.Fields.Add(NewField);
12587              NewField.DBGType.Value.AsString := HexCToHexPascal(NewVal);
12588            end
12589            else
12590              debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: No field for "' + ATypeName + '"."' + NewName + '"');
12591          end;
12592        end
12593        else begin
12594          if (AType.Fields[i].Name <> NewName) and
12595             (uppercase(AType.Fields[i].Name) = AType.Fields[i].Name)
12596          then
12597            AType.Fields[i].Name := NewName; // Adjust to mixed case
12598          if (AType.Fields[i].ClassName <> ATypeName) and
12599             (uppercase(AType.Fields[i].ClassName) = AType.Fields[i].ClassName)
12600          then
12601            AType.Fields[i].ClassName := ATypeName; // Adjust to mixed case
12602          AType.Fields[i].DBGType.Value.AsString := HexCToHexPascal(NewVal);
12603        end;
12604
12605        if (StartPtr^ <> '}') then inc(StartPtr);
12606        SkipSpaces;
12607      end;
12608
12609      inc(StartPtr); // skip the }
12610    end;
12611
12612  begin
12613    if ATextInfo = '' then exit;
12614    AWarnText := ATextInfo;
12615    StartPtr := @ATextInfo[1];
12616    EndPtr := @ATextInfo[length(ATextInfo)];
12617
12618    while EndPtr^ = ' ' do dec(EndPtr);
12619
12620    SkipSpaces;
12621    if StartPtr^ <> '{'
12622    then begin
12623      //It is not a class
12624      debugln(DBGMI_STRUCT_PARSER, 'ERROR: PutValuesInClass: Expected class, but found: "', ATextInfo, '"');
12625      exit;
12626    end;
12627
12628    ProcessAncestor(AType.TypeName);
12629
12630  end;
12631
12632  procedure PutValuesInTree();
12633  var
12634    ValData: string;
12635  begin
12636    if not Assigned(FTypeInfo) then exit;
12637
12638    ValData := FTextValue;
12639    case FTypeInfo.Kind of
12640      skClass: begin
12641        GetPart('','{',ValData);
12642        PutValuesInClass(FTypeInfo,ValData);
12643      end;
12644      skRecord: begin
12645        GetPart('','{',ValData);
12646        PutValuesInTypeRecord(FTypeInfo,ValData);
12647      end;
12648      skVariant: begin
12649        FTypeInfo.Value.AsString:=ValData;
12650      end;
12651      skEnum: begin
12652        FTypeInfo.Value.AsString:=ValData;
12653      end;
12654      skSet: begin
12655        FTypeInfo.Value.AsString:=ValData;
12656      end;
12657      skSimple: begin
12658        FTypeInfo.Value.AsString:=ValData;
12659      end;
12660//      skPointer: ;
12661    end;
12662  end;
12663
12664  function SelectParentFrame(var aFrameIdx: Integer): Boolean;
12665  var
12666    CurPFPListChangeStamp: Integer;
12667
12668    function ParentSearchCanContinue: Boolean;
12669    begin
12670      Result :=
12671        (not (dcsCanceled in SeenStates)) and
12672        (CurPFPListChangeStamp = TGDBMIWatches(FTheDebugger.Watches).ParentFPListChangeStamp) and // State changed: FrameCache is no longer valid
12673        (FTheDebugger.State <> dsError);
12674    end;
12675
12676  var
12677    R: TGDBMIExecResult;
12678    List: TGDBMINameValueList;
12679    ParentFp, Fp, LastFp: String;
12680    i, j: Integer;
12681    FrameCache: PGDBMIDebuggerParentFrameCache;
12682    ParentFpNum, FpNum, FpDiff, LastFpDiff: QWord;
12683    FpDir: Integer;
12684  begin
12685    Result := False;
12686    CurPFPListChangeStamp := TGDBMIWatches(FTheDebugger.Watches).ParentFPListChangeStamp;
12687    FrameCache := TGDBMIWatches(FTheDebugger.Watches).GetParentFPList(ContextThreadId);
12688    List := nil;
12689    try
12690
12691      i := length(FrameCache^.ParentFPList);
12692      j := Max(i, aFrameIdx+1);
12693      if j >= i
12694      then SetLength(FrameCache^.ParentFPList, j + 3);
12695
12696      // Did a previous check for parentfp fail?
12697      ParentFP := FrameCache^.ParentFPList[aFrameIdx].parentfp;
12698      if ParentFp = '-'
12699      then Exit(False);
12700
12701      if ParentFp = '' then begin
12702        // not yet evaluated
12703        if ExecuteCommand('-data-evaluate-expression parentfp', R)
12704        and (R.State <> dsError)
12705        then begin
12706          List := TGDBMINameValueList.Create(R);
12707          ParentFP := List.Values['value'];
12708        end;
12709        if not ParentSearchCanContinue then
12710          exit;
12711        if ParentFp = '' then begin
12712          FrameCache^.ParentFPList[aFrameIdx].parentfp := '-'; // mark as no parentfp
12713          Exit(False);
12714        end;
12715        FrameCache^.ParentFPList[aFrameIdx].parentfp := ParentFp;
12716      end;
12717
12718      ParentFpNum := StrToQWordDef(ParentFp, 0);
12719      if ParentFpNum = 0 then begin
12720        FrameCache^.ParentFPList[aFrameIdx].parentfp := '-'; // mark as no parentfp
12721        Exit(False);
12722      end;
12723
12724      if List = nil
12725      then List := TGDBMINameValueList.Create('');
12726
12727      LastFp := '';
12728      LastFpDiff := 0;
12729      FpDir := 0;
12730      repeat
12731        Inc(aFrameIdx);
12732        i := length(FrameCache^.ParentFPList);
12733        j := Max(i, aFrameIdx+1);
12734        if j >= i
12735        then SetLength(FrameCache^.ParentFPList, j + 5);
12736
12737        Fp := FrameCache^.ParentFPList[aFrameIdx].Fp;
12738        if Fp = '-'
12739        then begin
12740          Exit(False);
12741        end;
12742
12743        if (Fp = '') or (Fp = ParentFP) then begin
12744          FContext.StackContext := ccUseLocal;
12745          FContext.StackFrame := aFrameIdx;
12746
12747          if (Fp = '') then begin
12748            if not ExecuteCommand('-data-evaluate-expression $fp', R)
12749            or (R.State = dsError)
12750            then begin
12751              FrameCache^.ParentFPList[aFrameIdx].Fp := '-'; // mark as no Fp (not accesible)
12752              Exit(False);
12753            end;
12754            if not ParentSearchCanContinue then
12755              exit;
12756            List.Init(R.Values);
12757            Fp := List.Values['value'];
12758            if Fp = ''
12759            then Fp := '-';
12760            FrameCache^.ParentFPList[aFrameIdx].Fp := Fp;
12761          end;
12762        end;
12763
12764        if FP = LastFp then          // Propably top of stack, FP no longer changes
12765          Exit(False);
12766        LastFp := Fp;
12767
12768        // check that FP gets closer to ParentFp
12769        FpNum := StrToQWordDef(Fp, 0);
12770        if FpNum > ParentFpNum then begin
12771          if FpDir = 1 then exit; // went to far
12772          FpDir := -1;
12773          FpDiff := FpNum - ParentFpNum;
12774        end else begin
12775          if FpDir = -1 then exit; // went to far
12776          FpDir := 1;
12777          FpDiff := ParentFpNum - FpNum;
12778        end;
12779        if (LastFpDiff <> 0) and (FpDiff >= LastFpDiff) then
12780          Exit(False);
12781
12782        LastFpDiff := FpDiff;
12783
12784      until ParentFP = Fp;
12785
12786      Result := True;
12787
12788    finally
12789      List.Free;
12790    end;
12791  end;
12792
12793  function PascalizePointer(AString: String; const TypeCast: String = ''): String;
12794  var
12795    s: String;
12796  begin
12797    Result := AString;
12798    if not IsHexC(AString)
12799    then exit;
12800
12801    // there may be data after the pointer
12802    s := GetPart([], [' '], AString, False, True);
12803    if s = '0x0'
12804    then begin
12805      Result := 'nil';
12806    end
12807    else begin
12808      // 0xabc0 => $0000ABC0
12809      Result := UpperCase(HexCToHexPascal(s, FTheDebugger.TargetWidth div 4));
12810    end;
12811
12812    if TypeCast <> '' then
12813      Result := TypeCast + '(' + Result + ')';
12814    if AString <> '' then
12815      Result := Result + ' ' + AString;
12816  end;
12817
12818  function FormatCurrency(const AString: String): String;
12819  var
12820    i, e: Integer;
12821    c: Currency;
12822  begin
12823    Result := AString;
12824    Val(Result, i, e);
12825    // debugger outputs 12345 for 1,2345 values
12826    if e=0 then
12827    begin
12828      c := i / 10000;
12829      Result := CurrToStr(c);
12830    end;
12831  end;
12832
12833  function GetVariantValue(AString: String): String;
12834
12835    function FormatVarError(const AString: String): String; inline;
12836    begin
12837      Result := 'Error('+AString+')';
12838    end;
12839
12840  var
12841    VarList: TGDBMINameValueList;
12842    VType: Integer;
12843    Addr: TDbgPtr;
12844    dt: TDateTime;
12845    e: Integer;
12846  begin
12847    VarList := TGDBMINameValueList.Create('');
12848    try
12849      VarList.UseTrim := True;
12850      VarList.Init(AString);
12851      VType := StrToIntDef(VarList.Values['VTYPE'], -1);
12852      if VType = -1 then // can never happen if no error since varType is word
12853        Exit('variant: unknown type');
12854      case VType and not varTypeMask of
12855        0:
12856          begin
12857            case VType of
12858              varEmpty: Result := 'UnAssigned';
12859              varNull: Result := 'Null';
12860              varsmallint: Result := VarList.Values['VSMALLINT'];
12861              varinteger: Result := VarList.Values['VINTEGER'];
12862              varsingle: Result := VarList.Values['VSINGLE'];
12863              vardouble: Result := VarList.Values['VDOUBLE'];
12864              vardate:
12865                begin
12866                  // float number
12867                  Result := VarList.Values['VDATE'];
12868                  val(Result, dt, e);
12869                  if e = 0 then
12870                    Result := DateTimeToStr(dt);
12871                end;
12872              varcurrency: Result := FormatCurrency(VarList.Values['VCURRENCY']);
12873              varolestr: Result := VarList.Values['VOLESTR'];
12874              vardispatch: Result := PascalizePointer(VarList.Values['VDISPATCH'], 'IDispatch');
12875              varerror: Result := FormatVarError(VarList.Values['VERROR']);
12876              varboolean: Result := VarList.Values['VBOOLEAN'];
12877              varunknown: Result := PascalizePointer(VarList.Values['VUNKNOWN'], 'IUnknown');
12878              varshortint: Result := VarList.Values['VSHORTINT'];
12879              varbyte: Result := VarList.Values['VBYTE'];
12880              varword: Result := VarList.Values['VWORD'];
12881              varlongword: Result := VarList.Values['VLONGWORD'];
12882              varint64: Result := VarList.Values['VINT64'];
12883              varqword: Result := VarList.Values['VQWORD'];
12884              varstring:
12885                begin
12886                  // address of string
12887                  Result := VarList.Values['VSTRING'];
12888                  Val(Result, Addr, e);
12889                  if e = 0 then
12890                  begin
12891                    if Addr = 0 then
12892                      Result := ''''''
12893                    else
12894                      Result := MakePrintable(GetText(Addr));
12895                  end;
12896                end;
12897              varany:  Result := VarList.Values['VANY'];
12898            else
12899              Result := 'unsupported variant type: ' + VarTypeAsText(VType);
12900            end;
12901          end;
12902        varArray:
12903          begin
12904            Result := VarTypeAsText(VType);
12905            // TODO: show variant array data?
12906            // Result := VarList.Values['VARRAY'];
12907          end;
12908        varByRef:
12909          begin
12910            Result := VarList.Values['VPOINTER'];
12911            Val(Result, Addr, e);
12912            if e = 0 then
12913            begin
12914              if Addr = 0 then
12915                Result := '???'
12916              else
12917              begin
12918                // Result contains a valid address
12919                case VType xor varByRef of
12920                  varEmpty: Result := 'UnAssigned';
12921                  varNull: Result := 'Null';
12922                  varsmallint: Result := GetStrValue('psmallint(%s)^', [Result]);
12923                  varinteger: Result := GetStrValue('pinteger(%s)^', [Result]);
12924                  varsingle: Result := GetStrValue('psingle(%s)^', [Result]);
12925                  vardouble: Result := GetStrValue('pdouble(%s)^', [Result]);
12926                  vardate:
12927                    begin
12928                      // float number
12929                      Result := GetStrValue('pdatetime(%s)^', [Result]);
12930                      val(Result, dt, e);
12931                      if e = 0 then
12932                        Result := DateTimeToStr(dt);
12933                    end;
12934                  varcurrency: Result := FormatCurrency(GetStrValue('pcurrency(%s)^', [Result]));
12935                  varolestr:
12936                    begin
12937                      Result := GetStrValue('^pointer(%s)^', [Result]);
12938                      val(Result, Addr, e);
12939                      if e = 0 then
12940                        Result := MakePrintable(GetWideText(Addr));
12941                    end;
12942                  vardispatch: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IDispatch');
12943                  varerror: Result := FormatVarError(GetStrValue('phresult(%s)^', [Result]));
12944                  varboolean: Result := GetStrValue('pwordbool(%s)^', [Result]);
12945                  varunknown: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IUnknown');
12946                  varshortint: Result := GetStrValue('pshortint(%s)^', [Result]);
12947                  varbyte: Result := GetStrValue('pbyte(%s)^', [Result]);
12948                  varword: Result := GetStrValue('pword(%s)^', [Result]);
12949                  varlongword: Result := GetStrValue('plongword(%s)^', [Result]);
12950                  varint64: Result := GetStrValue('pint64(%s)^', [Result]);
12951                  varqword: Result := GetStrValue('pqword(%s)^', [Result]);
12952                  varstring: Result := MakePrintable(GetText('pansistring(%s)^', [Result]));
12953                else
12954                  Result := 'unsupported variant type: ' + VarTypeAsText(VType);
12955                end;
12956              end;
12957            end;
12958          end;
12959        else
12960          Result := 'unsupported variant type: ' + VarTypeAsText(VType);
12961      end;
12962    finally
12963      VarList.Free;
12964    end;
12965  end;
12966
12967  function StripExprNewlines(const ASource: String): String;
12968  var
12969    len: Integer;
12970    srcPtr, dstPtr: PChar;
12971  begin
12972    len := Length(ASource);
12973    SetLength(Result, len);
12974    if len = 0 then Exit;
12975    srcPtr := @ASource[1];
12976    dstPtr := @Result[1];
12977    while len > 0 do
12978    begin
12979      case srcPtr^ of
12980        #0:;
12981        #10, #13: dstPtr^ := ' ';
12982      else
12983        dstPtr^ := srcPtr^;
12984      end;
12985      Dec(len);
12986      Inc(srcPtr);
12987      Inc(dstPtr);
12988    end;
12989  end;
12990
12991  procedure FixUpResult(AnExpression: string; ResultInfo: TGDBType = nil);
12992  var
12993    addr: TDbgPtr;
12994    e: Integer;
12995    PrintableString: String;
12996    i: Integer;
12997    addrtxt: string;
12998  begin
12999    // Check for strings
13000    if ResultInfo = nil then
13001      ResultInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags, TypeInfoFlags);
13002    if (ResultInfo = nil) then Exit;
13003    FTypeInfo := ResultInfo;
13004
13005    case ResultInfo.Kind of
13006      skPointer: begin
13007        addrtxt := GetPart([], [' '], FTextValue, False, False);
13008        Val(addrtxt, addr, e);
13009        if e <> 0 then
13010          Exit;
13011
13012        AnExpression := Lowercase(ResultInfo.TypeName);
13013        case StringCase(AnExpression, ['char', 'character', 'ansistring', '__vtbl_ptr_type',
13014                                       'wchar', 'widechar', 'widestring', 'unicodestring',
13015                                       'pointer'])
13016        of
13017          0, 1, 2: begin // 'char', 'character', 'ansistring'
13018            // check for addr 'text' / 0x1234 'abc'
13019            i := length(addrtxt)+1;
13020            if (i <= length(FTextValue)) and (FTextValue[i] = ' ') then inc(i); // skip 1 or 2 spaces after addr
13021            if (i <= length(FTextValue)) and (FTextValue[i] = ' ') then inc(i);
13022
13023            if (i <= length(FTextValue)) and (FTextValue[i] in ['''', '#'])
13024            then
13025              FTextValue := MakePrintable(ProcessGDBResultText(
13026                copy(FTextValue, i, length(FTextValue) - i + 1), [prNoLeadingTab]))
13027            else
13028            if Addr = 0
13029            then
13030              FTextValue := ''''''
13031            else
13032              FTextValue := MakePrintable(GetText(Addr));
13033              PrintableString := FTextValue;
13034          end;
13035          3: begin // '__vtbl_ptr_type'
13036            if Addr = 0
13037            then FTextValue := 'nil'
13038            else begin
13039              AnExpression := GetClassName(Addr);
13040              if AnExpression = '' then AnExpression := '???';
13041              FTextValue := 'class of ' + AnExpression + ' ' + UnEscapeBackslashed(FTextValue);
13042            end;
13043          end;
13044          4,5,6,7: begin // 'wchar', 'widechar'
13045            // widestring handling
13046            if Addr = 0
13047            then FTextValue := ''''''
13048            else FTextValue := MakePrintable(GetWideText(Addr));
13049            PrintableString := FTextValue;
13050          end;
13051          8: begin // pointer
13052            if Addr = 0
13053            then FTextValue := 'nil';
13054            FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue));
13055          end;
13056        else
13057          if Addr = 0
13058          then FTextValue := 'nil';
13059          if (Length(AnExpression) > 0)
13060          then begin
13061            if AnExpression[1] = 't'
13062            then begin
13063              AnExpression[1] := 'T';
13064              if Length(AnExpression) > 1 then AnExpression[2] := UpperCase(AnExpression[2])[1];
13065            end;
13066            FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue), AnExpression);
13067          end;
13068
13069        end;
13070
13071        ResultInfo.Value.AsPointer := {%H-}Pointer(PtrUint(Addr));
13072        AnExpression := Format('$%x', [Addr]);
13073        if PrintableString <> ''
13074        then AnExpression := AnExpression + ' ' + PrintableString;
13075        ResultInfo.Value.AsString := AnExpression;
13076      end;
13077
13078      skClass: begin
13079        Val(FTextValue, addr, e); //Get the class mem address
13080        if (e = 0) and (addr = 0)
13081        then FTextValue := 'nil';
13082
13083        if (FTextValue <> '') and (FTypeInfo <> nil)
13084        then begin
13085          FTextValue := '<' + FTypeInfo.TypeName + '> = ' +
13086            ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
13087        end
13088        else
13089        if (e = 0) and (addr <> 0)
13090        then begin //No error ?
13091          AnExpression := GetInstanceClassName(Addr);
13092          if AnExpression = '' then AnExpression := '???'; //No instanced class found
13093          FTextValue := 'instance of ' + AnExpression + ' ' +
13094            ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
13095        end;
13096      end;
13097
13098      skVariant: begin
13099        FTextValue := UnEscapeBackslashed(GetVariantValue(FTextValue));
13100      end;
13101      skRecord: begin
13102        FTextValue := 'record ' + ResultInfo.TypeName + ' '+
13103          ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
13104      end;
13105
13106      skSimple: begin
13107        if ResultInfo.TypeName = 'CURRENCY' then
13108          FTextValue := FormatCurrency(UnEscapeBackslashed(FTextValue))
13109        else
13110        if ResultInfo.TypeName = 'ShortString' then
13111          FTextValue := MakePrintable(ProcessGDBResultText(FTextValue, [prNoLeadingTab]))
13112        else
13113        if (ResultInfo.TypeName = '&ShortString') then // should no longer happen
13114          FTextValue := GetStrValue('ShortString(%s)', [AnExpression]) // we have an address here, so we need to typecast
13115        else
13116        if saDynArray in ResultInfo.Attributes then  // may also be a string
13117          FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue))
13118        else
13119          FTextValue := UnEscapeBackslashed(FTextValue); // TODO: Check for string
13120      end;
13121    end;
13122
13123    PutValuesInTree;
13124    FTextValue := FormatResult(FTextValue, (ResultInfo.Kind = skSimple) and (ResultInfo.Attributes*[saArray,saDynArray] <> []));
13125  end;
13126
13127  function AddAddressOfToExpression(const AnExpression: string; TypeInfo: TGDBType): String;
13128  var
13129    UseAt: Boolean;
13130  begin
13131    UseAt := True;
13132    case TypeInfo.Kind of // (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer, skVariant)
13133      skPointer: begin
13134          case StringCase(Lowercase(TypeInfo.TypeName),
13135                          ['char', 'character', 'ansistring', '__vtbl_ptr_type', 'wchar', 'widechar', 'pointer']
13136                         )
13137          of
13138            2: UseAt := False;
13139            3: UseAt := False;
13140          end;
13141        end;
13142    end;
13143
13144    if UseAt
13145    then Result := '@(' + AnExpression + ')'
13146    else Result := AnExpression;
13147  end;
13148
13149  function QuoteExpr(const AnExpression: string): string;
13150    var
13151      i, j, Cnt: integer;
13152    begin
13153    if pos(' ', AnExpression) < 1
13154    then exit(AnExpression);
13155    Cnt := length(AnExpression);
13156    SetLength(Result, 2 * Cnt + 2);
13157    Result[1] := '"';
13158    i := 1;
13159    j := 2;
13160    while i <= Cnt do begin
13161      if AnExpression[i] in ['"', '\']
13162      then begin
13163        Result[j] := '\';
13164        inc(j);
13165      end;
13166      Result[j] := AnExpression[i];
13167      inc(i);
13168      inc(j);
13169    end;
13170    Result[j] := '"';
13171    SetLength(Result, j + 1);
13172  end;
13173
13174  procedure ParseLastError;
13175  var
13176    ResultList: TGDBMINameValueList;
13177  begin
13178    if (dcsCanceled in SeenStates)
13179    then begin
13180      FTextValue := '<Canceled>';
13181      FValidity := ddsInvalid;
13182      exit;
13183    end;
13184    ResultList := TGDBMINameValueList.Create(LastExecResult.Values);
13185    FTextValue := ResultList.Values['msg'];
13186    if FTextValue = ''
13187    then  FTextValue := '<Error>';
13188    FreeAndNil(ResultList);
13189    FValidity := ddsError;
13190  end;
13191
13192  function TryExecute(AnExpression: string): Boolean;
13193
13194    function PrepareExpr(var expr: string; NoAddressOp: Boolean = False): boolean;
13195    begin
13196      Assert(FTypeInfo = nil, 'Type info must be nil');
13197      FTypeInfo := GetGDBTypeInfo(expr, defFullTypeInfo in FEvalFlags, TypeInfoFlags);
13198      Result := FTypeInfo <> nil;
13199      if (not Result) then begin
13200        ParseLastError;
13201        exit;
13202      end;
13203
13204      if NoAddressOp
13205      then expr := QuoteExpr(expr)
13206      else expr := QuoteExpr(AddAddressOfToExpression(expr, FTypeInfo));
13207    end;
13208
13209  var
13210    ResultList: TGDBMINameValueList;
13211    R: TGDBMIExecResult;
13212    MemDump: TGDBMIMemoryDumpResultList;
13213    i, Size: integer;
13214    s: String;
13215  begin
13216    Result := False;
13217
13218    case FDisplayFormat of
13219      wdfStructure:
13220        begin
13221          Result := ExecuteCommand('-data-evaluate-expression %s', [Quote(AnExpression)], R);
13222          Result := Result and (R.State <> dsError);
13223          if (not Result) then begin
13224            ParseLastError;
13225            exit;
13226          end;
13227
13228          ResultList := TGDBMINameValueList.Create(R.Values);
13229          if Result
13230          then FTextValue := ResultList.Values['value']
13231          else FTextValue := ResultList.Values['msg'];
13232          FTextValue := DeleteEscapeChars(FTextValue);
13233          ResultList.Free;
13234
13235          if Result
13236          then begin
13237            FixUpResult(AnExpression);
13238            FValidity := ddsValid;
13239          end;
13240        end;
13241      wdfChar:
13242        begin
13243          Result := PrepareExpr(AnExpression);
13244          if not Result
13245          then exit;
13246          FValidity := ddsValid;
13247          FTextValue := GetChar(AnExpression, []);
13248          if LastExecResult.State = dsError
13249          then ParseLastError;
13250        end;
13251      wdfString:
13252        begin
13253          Result := PrepareExpr(AnExpression);
13254          if not Result
13255          then exit;
13256          FValidity := ddsValid;
13257          FTextValue := GetText(AnExpression, []); // GetText takes Addr
13258          if LastExecResult.State = dsError
13259          then ParseLastError;
13260        end;
13261      wdfDecimal:
13262        begin
13263          Result := PrepareExpr(AnExpression, True);
13264          if not Result
13265          then exit;
13266          FValidity := ddsValid;
13267          FTextValue := IntToStr(Int64(GetPtrValue(AnExpression, [], True)));
13268          if LastExecResult.State = dsError
13269          then ParseLastError;
13270        end;
13271      wdfUnsigned:
13272        begin
13273          Result := PrepareExpr(AnExpression, True);
13274          if not Result
13275          then exit;
13276          FValidity := ddsValid;
13277          FTextValue := IntToStr(GetPtrValue(AnExpression, [], True));
13278          if LastExecResult.State = dsError
13279          then ParseLastError;
13280        end;
13281      //wdfFloat:
13282      //  begin
13283      //    Result := PrepareExpr(AnExpression);
13284      //    if not Result
13285      //    then exit;
13286      //    FTextValue := GetFloat(AnExpression, []);  // GetFloat takes address
13287      //    if LastExecResult.State = dsError
13288      //    then FTextValue := '<error>';
13289      //  end;
13290      wdfHex:
13291        begin
13292          Result := PrepareExpr(AnExpression, True);
13293          if not Result
13294          then exit;
13295          FTextValue := IntToHex(GetPtrValue(AnExpression, [], True), 2);
13296          FValidity := ddsValid;
13297          if length(FTextValue) mod 2 = 1
13298          then FTextValue := '0'+FTextValue; // make it an even number of digets
13299          if LastExecResult.State = dsError
13300          then ParseLastError;
13301        end;
13302      wdfPointer:
13303        begin
13304          Result := PrepareExpr(AnExpression, True);
13305          if not Result
13306          then exit;
13307          FTextValue := PascalizePointer('0x' + IntToHex(GetPtrValue(AnExpression, [], True), TargetInfo^.TargetPtrSize*2));
13308          FValidity := ddsValid;
13309          if LastExecResult.State = dsError
13310          then FTextValue := '<error>';
13311        end;
13312      wdfMemDump:
13313        begin
13314          Result := PrepareExpr(AnExpression);
13315          if not Result
13316          then exit;
13317
13318          Result := False;
13319          Size := 256;
13320          if (FTypeInfo <> nil) and (saInternalPointer in FTypeInfo.Attributes) then begin
13321            Result := ExecuteCommand('-data-read-memory %s^ x 1 1 %u', [AnExpression, Size], R);
13322            Result := Result and (R.State <> dsError);
13323            // nil ?
13324            if (R.State = dsError) and (pos('Unable to read memory', R.Values) > 0) then
13325              Size := TargetInfo^.TargetPtrSize;
13326          end;
13327          if (not Result) then begin
13328            Result := ExecuteCommand('-data-read-memory %s x 1 1 %u', [AnExpression, Size], R);
13329            Result := Result and (R.State <> dsError);
13330          end;
13331          if (not Result) then begin
13332            ParseLastError;
13333            exit;
13334          end;
13335          MemDump := TGDBMIMemoryDumpResultList.Create(R);
13336          FValidity := ddsValid;
13337          FTextValue := MemDump.AsText(0, MemDump.Count, TargetInfo^.TargetPtrSize*2);
13338          MemDump.Free;
13339        end;
13340      wdfBinary:
13341        begin
13342          Result := PrepareExpr(AnExpression, True);
13343          if not Result
13344          then exit;
13345          FValidity := ddsValid;
13346          FTextValue := Concat('0b' + BinStr(GetPtrValue(AnExpression, [], True), TargetInfo^.TargetPtrSize*2));
13347          if LastExecResult.State = dsError
13348          then ParseLastError;
13349        end;
13350      else // wdfDefault
13351        begin
13352          Result := False;
13353          Assert(FTypeInfo = nil, 'Type info must be nil');
13354          i := 0;
13355          if FWatchValue <> nil then i := FWatchValue.RepeatCount;
13356          FTypeInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags,
13357            TypeInfoFlags + [gtcfExprEvaluate, gtcfExprEvalStrFixed], FDisplayFormat, i);
13358
13359          if (FTypeInfo = nil) or (dcsCanceled in SeenStates)
13360          then begin
13361            ParseLastError;
13362            exit;
13363          end;
13364          if FTypeInfo.HasExprEvaluatedAsText then begin
13365            FTextValue := FTypeInfo.ExprEvaluatedAsText;
13366            //FTextValue := DeleteEscapeChars(FTextValue); // TODO: move to FixUpResult / only if really needed
13367            FValidity := ddsValid;
13368            Result := True;
13369            FixUpResult(AnExpression, FTypeInfo);
13370
13371            if FTypeInfo.HasStringExprEvaluatedAsText then begin
13372              s := FTextValue;
13373              FTextValue := FTypeInfo.StringExprEvaluatedAsText;
13374              //FTextValue := DeleteEscapeChars(FTextValue); // TODO: move to FixUpResult / only if really needed
13375              FixUpResult(AnExpression, FTypeInfo);
13376              FTextValue := 'PCHAR: ' + s + LineEnding + 'STRING: ' + FTextValue;
13377            end;
13378
13379            exit;
13380          end;
13381
13382          debugln(DBG_WARNINGS, '############# Not expected to be here');
13383          FTextValue := '<ERROR>';
13384        end;
13385    end;
13386
13387  end;
13388
13389var
13390  S: String;
13391  ResultList: TGDBMINameValueList;
13392  frameidx: Integer;
13393  {$IFDEF DBG_WITH_GDB_WATCHES} R: TGDBMIExecResult; {$ENDIF}
13394begin
13395  SelectContext;
13396
13397  try
13398    FTextValue:='';
13399    FTypeInfo:=nil;
13400    TypeInfoFlags := [];
13401    if defClassAutoCast in FEvalFlags
13402    then include(TypeInfoFlags, gtcfAutoCastClass);
13403
13404
13405    S := StripExprNewlines(FExpression);
13406
13407    if S = '' then Exit(True);
13408
13409    {$IFDEF DBG_WITH_GDB_WATCHES}
13410    (* This code is experimental. No support will be provided.
13411       It is intended for people extending the GDBMI classes of the IDE, and requires deep knowledge on how the IDE works.
13412       WARNING:
13413        - This bypasses some of the internals of the debugger.
13414        - It does intentionally no check or validation
13415        - Using this feature without full knowledge of all internals of the debugger, can *HANG* or *CRASH* the debugger or the entire IDE.
13416    *)
13417    if S[1]='>' then begin // raw cli commands
13418      delete(S,1,1);
13419      Result := ExecuteCommand('%s', [S], R);
13420      Result := Result and (R.State <> dsError);
13421      if (not Result) then begin
13422        ParseLastError;
13423        exit(True);
13424      end;
13425      FValidity := ddsValid;
13426      FTextValue := UnEscapeBackslashed(R.Values, [uefNewLine, uefTab], 3);
13427      exit;
13428    end;
13429    {$ENDIF}
13430
13431    ResultList := TGDBMINameValueList.Create('');
13432    // keep the internal stackframe => same as requested by watch
13433    frameidx := ContextStackFrame;
13434    DefaultTimeOut := DebuggerProperties.TimeoutForEval;
13435    try
13436      repeat
13437        if TryExecute(S)
13438        then Break;
13439        FreeAndNil(FTypeInfo);
13440        if (dcsCanceled in SeenStates)
13441        then break;
13442      until not SelectParentFrame(frameidx); // may set FStackFrameChanged to force UnSelectContext()
13443
13444    finally
13445      DefaultTimeOut := -1;
13446      FreeAndNil(ResultList);
13447    end;
13448    Result := True;
13449  finally
13450    UnSelectContext;
13451    if FWatchValue <> nil then begin
13452      FWatchValue.Value := FTextValue;
13453      FWatchValue.TypeInfo := TypeInfo;
13454      FWatchValue.Validity := FValidity;
13455    end;
13456  end;
13457end;
13458
13459function TGDBMIDebuggerCommandEvaluate.SelectContext: Boolean;
13460begin
13461  Result := True;
13462  if FWatchValue = nil then begin
13463    CopyGlobalContextToLocal;
13464    exit;
13465  end;
13466
13467  FContext.ThreadContext := ccUseLocal;
13468  FContext.ThreadId := FWatchValue.ThreadId;
13469
13470  FContext.StackContext := ccUseLocal;
13471  FContext.StackFrame := FWatchValue.StackFrame;
13472end;
13473
13474procedure TGDBMIDebuggerCommandEvaluate.UnSelectContext;
13475begin
13476  FContext.ThreadContext := ccUseGlobal;
13477  FContext.StackContext := ccUseGlobal;
13478end;
13479
13480constructor TGDBMIDebuggerCommandEvaluate.Create(AOwner: TGDBMIDebugger; AExpression: String;
13481  ADisplayFormat: TWatchDisplayFormat);
13482begin
13483  inherited Create(AOwner);
13484  FWatchValue := nil;
13485  FExpression := AExpression;
13486  FDisplayFormat := ADisplayFormat;
13487  FTextValue := '';
13488  FTypeInfo:=nil;
13489  FEvalFlags := [];
13490  FTypeInfoAutoDestroy := True;
13491  FValidity := ddsValid;
13492  FLockFlag := False;
13493end;
13494
13495constructor TGDBMIDebuggerCommandEvaluate.Create(AOwner: TGDBMIDebugger;
13496  AWatchValue: TWatchValue);
13497begin
13498  Create(AOwner, AWatchValue.Watch.Expression, AWatchValue.DisplayFormat);
13499  EvalFlags := AWatchValue.EvaluateFlags;
13500  FWatchValue := AWatchValue;
13501  FWatchValue.AddFreeNotification(@DoWatchFreed);
13502end;
13503
13504destructor TGDBMIDebuggerCommandEvaluate.Destroy;
13505begin
13506  if FWatchValue <> nil
13507  then FWatchValue.RemoveFreeNotification(@DoWatchFreed);
13508  if FTypeInfoAutoDestroy
13509  then FreeAndNil(FTypeInfo);
13510  inherited Destroy;
13511end;
13512
13513function TGDBMIDebuggerCommandEvaluate.DebugText: String;
13514begin
13515  if FWatchValue <> nil
13516  then Result := Format('%s: %s Thread=%d, Frame=%d', [ClassName, FExpression, FWatchValue.ThreadId, FWatchValue.StackFrame])
13517  else Result := Format('%s: %s', [ClassName, FExpression]);
13518end;
13519
13520procedure Register;
13521begin
13522  RegisterDebugger(TGDBMIDebugger);
13523end;
13524
13525initialization
13526  DBGMI_QUEUE_DEBUG := DebugLogger.RegisterLogGroup('DBGMI_QUEUE_DEBUG' {$IFDEF DBGMI_QUEUE_DEBUG} , True {$ENDIF} );
13527  DBGMI_STRUCT_PARSER := DebugLogger.RegisterLogGroup('DBGMI_STRUCT_PARSER' {$IFDEF DBGMI_STRUCT_PARSER} , True {$ENDIF} );
13528  DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} );
13529  DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} );
13530  DBG_DISASSEMBLER := DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER' {$IFDEF DBG_DISASSEMBLER} , True {$ENDIF} );
13531  DBG_THREAD_AND_FRAME := DebugLogger.FindOrRegisterLogGroup('DBG_THREAD_AND_FRAME' {$IFDEF DBG_THREAD_AND_FRAME} , True {$ENDIF} );
13532
13533end.
13534