1{ $Id: dbgintfdebuggerbase.pp 63916 2020-09-24 05:28:24Z martin $ } 2{ ------------------------------------------- 3 DebuggerBase.pp - Debugger base classes 4 ------------------------------------------- 5 6 @author(Marc Weustink <marc@@dommelstein.net>) 7 @author(Martin Friebe) 8 9 This unit contains the base class definitions of the debugger. These 10 classes are only definitions. Implemented debuggers should be 11 derived from these. 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 DbgIntfDebuggerBase; 33 34{$mode objfpc}{$H+} 35 36{$ifndef VER2} 37 {$define disassemblernestedproc} 38{$endif VER2} 39 40{$ifdef disassemblernestedproc} 41 {$modeswitch nestedprocvars} 42{$endif disassemblernestedproc} 43 44interface 45 46uses 47 Classes, sysutils, math, contnrs, 48 // LCL 49 LCLProc, 50 // LazUtils 51 LazClasses, LazLoggerBase, LazFileUtils, Maps, LazMethodList, 52 // DebuggerIntf 53 DbgIntfBaseTypes, DbgIntfMiscClasses, DbgIntfPseudoTerminal; 54 55const 56 DebuggerIntfVersion = 0; 57 58type 59 EDebuggerException = class(Exception); 60 EDBGExceptions = class(EDebuggerException); 61 62 TDBGCommand = ( 63 dcRun, 64 dcPause, 65 dcStop, 66 dcStepOver, 67 dcStepInto, 68 dcStepOut, 69 dcRunTo, 70 dcJumpto, 71 dcAttach, 72 dcDetach, 73 dcBreak, 74 dcWatch, 75 dcLocal, 76 dcEvaluate, 77 dcModify, 78 dcEnvironment, 79 dcSetStackFrame, 80 dcDisassemble, 81 dcStepOverInstr, 82 dcStepIntoInstr, 83 dcSendConsoleInput 84 //, dcSendSignal 85 ); 86 TDBGCommands = set of TDBGCommand; 87 88 { Debugger states 89 -------------------------------------------------------------------------- 90 dsNone: 91 The debug object is created, but no instance of an external debugger 92 exists. 93 Initial state, leave with Init, enter with Done 94 95 dsIdle: 96 The external debugger is started, but no filename (or no other params 97 required to start) were given. 98 99 dsStop: 100 (Optional) The execution of the target is stopped 101 The external debugger is loaded and ready to (re)start the execution 102 of the target. 103 Breakpoints, watches etc can be defined 104 105 dsPause: 106 The debugger has paused the target. Target variables can be examined 107 108 dsInternalPause: 109 Pause, not visible to user. 110 For examble auto continue breakpoint: Allow collection of Snapshot data 111 112 dsInit: 113 (Optional, Internal) The debugger is about to run 114 115 dsRun: 116 The target is running. 117 118 dsError: 119 Something unforseen has happened. A shutdown of the debugger is in 120 most cases needed. 121 122 -dsDestroying 123 The debugger is about to be destroyed. 124 Should normally happen immediate on calling Release. 125 But the debugger may be in nested calls, and has to exit them first. 126 -------------------------------------------------------------------------- 127 } 128 TDBGState = ( 129 dsNone, 130 dsIdle, 131 dsStop, 132 dsPause, 133 dsInternalPause, 134 dsInit, 135 dsRun, 136 dsError, 137 dsDestroying 138 ); 139 140 TDBGLocationRec = record 141 Address: TDBGPtr; 142 FuncName: String; 143 SrcFile: String; 144 SrcFullName: String; 145 SrcLine: Integer; 146 end; 147 148 TDBGExceptionType = ( 149 deInternal, 150 deExternal, 151 deRunError 152 ); 153 154 TDebuggerDataState = (ddsUnknown, // 155 ddsRequested, ddsEvaluating, // 156 ddsValid, // Got a valid value 157 ddsInvalid, // Does not have a value 158 ddsError // Error, but got some Value to display (e.g. error msg) 159 ); 160 161 (* TValidState: State for breakpoints *) 162 TValidState = (vsUnknown, vsValid, vsInvalid, vsPending); 163 164const 165 DebuggerDataStateStr : array[TDebuggerDataState] of string = ( 166 'Unknown', 167 'Requested', 168 'Evaluating', 169 'Valid', 170 'Invalid', 171 'Error'); 172 173type 174 TDBGEvaluateFlag = 175 (defNoTypeInfo, // No Typeinfo object will be returned 176 defSimpleTypeInfo, // Returns: Kind (skSimple, skClass, ..); TypeName (but does make no attempt to avoid an alias) 177 defFullTypeInfo, // Get all typeinfo, resolve all anchestors 178 defClassAutoCast // Find real class of instance, and use, instead of declared class of variable 179 ); 180 TDBGEvaluateFlags = set of TDBGEvaluateFlag; 181 182 { TRunningProcessInfo 183 Used to enumerate running processes. 184 } 185 186 TRunningProcessInfo = class 187 public 188 PID: Cardinal; 189 ImageName: string; 190 constructor Create(APID: Cardinal; const AImageName: string); 191 end; 192 193 TRunningProcessInfoList = TObjectList; 194 195 (* TDebuggerDataMonitor / TDebuggerDataSupplier 196 - TDebuggerDataMonitor 197 used by the IDE to receive/request updates on all data objects 198 - TDebuggerDataSupplier 199 used by the debugger to provide updates on all data objects 200 *) 201 202 TDebuggerIntf = class; 203 TDebuggerDataSupplier = class; 204 205 { TDebuggerDataHandler } 206 207 TDebuggerDataHandler = class 208 private 209 FNotifiedState: TDBGState; 210 FOldState: TDBGState; 211 FUpdateCount: Integer; 212 protected 213 //procedure DoModified; virtual; // user-modified / xml-storable data modified 214 procedure DoStateEnterPause; virtual; 215 procedure DoStateLeavePause; virtual; 216 procedure DoStateLeavePauseClean; virtual; 217 procedure DoStateChangeEx(const AOldState, ANewState: TDBGState); virtual; 218 property NotifiedState: TDBGState read FNotifiedState; // The last state seen by DoStateChange 219 property OldState: TDBGState read FOldState; // The state before last DoStateChange 220 221 procedure DoBeginUpdate; virtual; 222 procedure DoEndUpdate; virtual; 223 public 224 //destructor Destroy; override; 225 procedure BeginUpdate; 226 procedure EndUpdate; 227 function IsUpdating: Boolean; 228 end; 229 230 { TDebuggerDataMonitor } 231 232 TDebuggerDataMonitor = class(TDebuggerDataHandler) 233 private 234 FSupplier: TDebuggerDataSupplier; 235 procedure SetSupplier(const AValue: TDebuggerDataSupplier); 236 protected 237 procedure DoModified; virtual; // user-modified / xml-storable data modified 238 procedure DoNewSupplier; virtual; 239 property Supplier: TDebuggerDataSupplier read FSupplier write SetSupplier; 240 public 241 destructor Destroy; override; 242 end; 243 244 { TDebuggerDataSupplier } 245 246 TDebuggerDataSupplier = class(TDebuggerDataHandler) 247 private 248 FDebugger: TDebuggerIntf; 249 FMonitor: TDebuggerDataMonitor; 250 procedure SetMonitor(const AValue: TDebuggerDataMonitor); 251 protected 252 procedure DoNewMonitor; virtual; 253 property Debugger: TDebuggerIntf read FDebugger write FDebugger; 254 protected 255 property Monitor: TDebuggerDataMonitor read FMonitor write SetMonitor; 256 257 procedure DoStateLeavePauseClean; override; 258 procedure DoStateChange(const AOldState: TDBGState); virtual; 259 260 property NotifiedState: TDBGState read FNotifiedState; // The last state seen by DoStateChange 261 property OldState: TDBGState read FOldState; // The state before last DoStateChange 262 procedure DoBeginUpdate; override; 263 procedure DoEndUpdate; override; 264 public 265 constructor Create(const ADebugger: TDebuggerIntf); 266 destructor Destroy; override; 267 end; 268 269{$region Breakpoints **********************************************************} 270(******************************************************************************) 271(** **) 272(** B R E A K P O I N T S **) 273(** **) 274(** Note: This part of the interface may/will still change to the **) 275(** monitor/supplier concept **) 276(** **) 277(******************************************************************************) 278(******************************************************************************) 279 280 TDBGBreakPointKind = ( 281 bpkSource, // source breakpoint 282 bpkAddress, // address breakpoint 283 bpkData // data/watchpoint 284 ); 285 286 TDBGWatchPointScope = ( 287 wpsLocal, 288 wpsGlobal 289 ); 290 291 TDBGWatchPointKind = ( 292 wpkWrite, 293 wpkRead, 294 wpkReadWrite 295 ); 296 297 { TBaseBreakPoint } 298 299 TBaseBreakPoint = class(TRefCountedColectionItem) 300 private 301 FAddress: TDBGPtr; 302 FEnabled: Boolean; 303 FInitialEnabled: Boolean; 304 FExpression: String; 305 FHitCount: Integer; // Current counter 306 FBreakHitCount: Integer; // The user configurable value 307 FKind: TDBGBreakPointKind; 308 protected // TODO: private 309 FWatchData: String; 310 FWatchScope: TDBGWatchPointScope; 311 FWatchKind: TDBGWatchPointKind; 312 FSource: String; 313 FLine: Integer; 314 FValid: TValidState; 315 protected 316 type 317 (* ciCreated will be called, as soon as any other property is set the first time (or at EndUpdate) 318 ciLocation includes Address, WatchData,Watch.... 319 *) 320 TDbgBpChangeIndicator = (ciCreated, ciDestroy, ciKind, ciLocation, ciEnabled, ciCondition, ciHitCount); 321 TDbgBpChangeIndicators = set of TDbgBpChangeIndicator; 322 // For the debugger backend to override 323 private 324 FPropertiesChanged: TDbgBpChangeIndicators; 325 FInPropertiesChanged: Boolean; 326 protected 327 procedure MarkPropertyChanged(AChanged: TDbgBpChangeIndicator); 328 procedure MarkPropertiesChanged(AChanged: TDbgBpChangeIndicators); 329 procedure DoPropertiesChanged(AChanged: TDbgBpChangeIndicators); virtual; 330 procedure DoExpressionChange; virtual; 331 procedure DoEnableChange; virtual; 332 // TODO: ClearPropertiesChanged, if needed inside DoPropertiesChanged 333 protected 334 procedure AssignLocationTo(Dest: TPersistent); virtual; 335 procedure AssignTo(Dest: TPersistent); override; 336 procedure DoHit(const ACount: Integer; var {%H-}AContinue: Boolean); virtual; 337 procedure SetHitCount(const AValue: Integer); 338 procedure SetValid(const AValue: TValidState); 339 protected 340 // virtual properties 341 function GetAddress: TDBGPtr; virtual; 342 function GetBreakHitCount: Integer; virtual; 343 function GetEnabled: Boolean; virtual; 344 function GetExpression: String; virtual; 345 function GetHitCount: Integer; virtual; 346 function GetKind: TDBGBreakPointKind; virtual; 347 function GetLine: Integer; virtual; 348 function GetSource: String; virtual; 349 function GetWatchData: String; virtual; 350 function GetWatchScope: TDBGWatchPointScope; virtual; 351 function GetWatchKind: TDBGWatchPointKind; virtual; 352 function GetValid: TValidState; virtual; 353 procedure DoEndUpdate; override; 354 355 procedure SetBreakHitCount(const AValue: Integer); virtual; 356 procedure SetEnabled(const AValue: Boolean); virtual; 357 procedure SetExpression(const AValue: String); virtual; 358 procedure SetInitialEnabled(const AValue: Boolean); virtual; 359 procedure SetKind(const AValue: TDBGBreakPointKind); 360 public 361 constructor Create(ACollection: TCollection); override; 362 destructor Destroy; override; 363 procedure SetPendingToValid(const AValue: TValidState); 364 // PublicProtectedFix ide/debugmanager.pas(867,32) Error: identifier idents no member "SetLocation" 365 property BreakHitCount: Integer read GetBreakHitCount write SetBreakHitCount; 366 property Enabled: Boolean read GetEnabled write SetEnabled; 367 property Expression: String read GetExpression write SetExpression; 368 property HitCount: Integer read GetHitCount; 369 property InitialEnabled: Boolean read FInitialEnabled write SetInitialEnabled; 370 property Kind: TDBGBreakPointKind read GetKind; 371 property Valid: TValidState read GetValid; 372 public 373 procedure SetAddress(const AValue: TDBGPtr); virtual; 374 procedure SetLocation(const ASource: String; const ALine: Integer); virtual; 375 procedure SetWatch(const AData: String; const AScope: TDBGWatchPointScope; 376 const AKind: TDBGWatchPointKind); virtual; 377 // bpkAddress 378 property Address: TDBGPtr read GetAddress write SetAddress; 379 // bpkSource 380 // TDBGBreakPoint: Line is the line-number as stored in the debug info 381 // TIDEBreakPoint: Line is the location in the Source (potentially modified Source) 382 property Line: Integer read GetLine; 383 property Source: String read GetSource; 384 // bpkData 385 property WatchData: String read GetWatchData; 386 property WatchScope: TDBGWatchPointScope read GetWatchScope; 387 property WatchKind: TDBGWatchPointKind read GetWatchKind; 388 end; 389 TBaseBreakPointClass = class of TBaseBreakPoint; 390 391 { TDBGBreakPoint } 392 393 TDBGBreakPoint = class(TBaseBreakPoint) 394 private 395 FSlave: TBaseBreakPoint; 396 function GetDebugger: TDebuggerIntf; 397 function GetDebuggerState: TDBGState; 398 procedure SetSlave(const ASlave : TBaseBreakPoint); 399 protected 400 procedure SetEnabled(const AValue: Boolean); override; // TODO: remove, currently used by WatchPoint, instead of vsInvalid 401 procedure DoChanged; override; 402 procedure DoStateChange(const AOldState: TDBGState); virtual; 403 property Debugger: TDebuggerIntf read GetDebugger; 404 property DebuggerState: TDBGState read GetDebuggerState; 405 public 406 constructor Create(ACollection: TCollection); override; 407 destructor Destroy; override; 408 procedure Hit(var ACanContinue: Boolean); 409 property Slave: TBaseBreakPoint read FSlave write SetSlave; 410 property Kind: TDBGBreakPointKind read GetKind write SetKind; // TODO: remove, used by TIDEBreakPoint.SetKind 411 412 procedure DoLogMessage(const AMessage: String); virtual; 413 procedure DoLogCallStack(const {%H-}Limit: Integer); virtual; 414 procedure DoLogExpression(const {%H-}AnExpression: String); virtual; // implemented in TGDBMIBreakpoint 415 end; 416 TDBGBreakPointClass = class of TDBGBreakPoint; 417 418 { TIdeBreakPointBase } 419 420 TIdeBreakPointBase = class(TBaseBreakPoint) 421 private 422 FMaster: TDBGBreakPoint; 423 procedure SetMaster(AValue: TDBGBreakPoint); 424 protected 425 procedure DoEndUpdate; override; 426 procedure ReleaseMaster; 427 property Master: TDBGBreakPoint read FMaster write SetMaster; 428 // TODO: move TBaseBreakPoint properties from IDE te IDEBase 429 public 430 destructor Destroy; override; 431 procedure BeginUpdate; override; 432 end; 433 434 { TBaseBreakPoints } 435 436 TBaseBreakPoints = class(TCollection) 437 private 438 protected 439 public 440 constructor Create(const ABreakPointClass: TBaseBreakPointClass); 441 destructor Destroy; override; 442 procedure Clear; reintroduce; 443 function Add(const ASource: String; const ALine: Integer; AnUpdating: Boolean = False): TBaseBreakPoint; overload; 444 function Add(const AAddress: TDBGPtr; AnUpdating: Boolean = False): TBaseBreakPoint; overload; 445 function Add(const AData: String; const AScope: TDBGWatchPointScope; 446 const AKind: TDBGWatchPointKind; AnUpdating: Boolean = False): TBaseBreakPoint; overload; 447 function Find(const ASource: String; const ALine: Integer): TBaseBreakPoint; overload; 448 function Find(const ASource: String; const ALine: Integer; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; 449 function Find(const AAddress: TDBGPtr): TBaseBreakPoint; overload; 450 function Find(const AAddress: TDBGPtr; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; 451 function Find(const AData: String; const AScope: TDBGWatchPointScope; 452 const AKind: TDBGWatchPointKind): TBaseBreakPoint; overload; 453 function Find(const AData: String; const AScope: TDBGWatchPointScope; 454 const AKind: TDBGWatchPointKind; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; 455 // no items property needed, it is "overridden" anyhow 456 end; 457 458 { TDBGBreakPoints } 459 460 TDBGBreakPoints = class(TBaseBreakPoints) 461 private 462 FDebugger: TDebuggerIntf; // reference to our debugger 463 function GetItem(const AnIndex: Integer): TDBGBreakPoint; 464 procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint); 465 protected 466 procedure DoStateChange(const AOldState: TDBGState); virtual; 467 property Debugger: TDebuggerIntf read FDebugger write FDebugger; 468 public 469 constructor Create(const ADebugger: TDebuggerIntf; 470 const ABreakPointClass: TDBGBreakPointClass); 471 function Add(const ASource: String; const ALine: Integer; AnUpdating: Boolean = False): TDBGBreakPoint; overload; reintroduce; 472 function Add(const AAddress: TDBGPtr; AnUpdating: Boolean = False): TDBGBreakPoint; overload; reintroduce; 473 function Add(const AData: String; const AScope: TDBGWatchPointScope; 474 const AKind: TDBGWatchPointKind; AnUpdating: Boolean = False): TDBGBreakPoint; overload; reintroduce; 475 function Find(const ASource: String; const ALine: Integer): TDBGBreakPoint; overload; 476 function Find(const ASource: String; const ALine: Integer; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; 477 function Find(const AAddress: TDBGPtr): TDBGBreakPoint; overload; 478 function Find(const AAddress: TDBGPtr; const {%H-}AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; 479 function Find(const AData: String; const AScope: TDBGWatchPointScope; 480 const AKind: TDBGWatchPointKind): TDBGBreakPoint; overload; 481 function Find(const AData: String; const AScope: TDBGWatchPointScope; 482 const AKind: TDBGWatchPointKind; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; 483 484 property Items[const AnIndex: Integer]: TDBGBreakPoint read GetItem write SetItem; default; 485 end; 486 487{%endregion ^^^^^ Breakpoints ^^^^^ } 488 489{$region Debug Info ***********************************************************} 490(******************************************************************************) 491(** **) 492(** D E B U G I N F O R M A T I O N **) 493(** **) 494(** Note: This part of the interface may/will still change. **) 495(** **) 496(******************************************************************************) 497(******************************************************************************) 498 499 TDBGSymbolAttribute = (saRefParam, // var, const, constref passed by reference 500 saInternalPointer, // PointerToObject 501 saArray, saDynArray 502 ); 503 TDBGSymbolAttributes = set of TDBGSymbolAttribute; 504 TDBGFieldLocation = (flPrivate, flProtected, flPublic, flPublished); 505 TDBGFieldFlag = (ffVirtual,ffConstructor,ffDestructor); 506 TDBGFieldFlags = set of TDBGFieldFlag; 507 508 TDBGType = class; 509 510 TDBGValue = record 511 AsString: ansistring; 512 case integer of 513 0: (As8Bits: BYTE); 514 1: (As16Bits: WORD); 515 2: (As32Bits: DWORD); 516 3: (As64Bits: QWORD); 517 4: (AsSingle: Single); 518 5: (AsDouble: Double); 519 6: (AsPointer: Pointer); 520 end; 521 522 { TDBGField } 523 524 TDBGField = class(TObject) 525 private 526 FRefCount: Integer; 527 protected 528 FName: String; 529 FFlags: TDBGFieldFlags; 530 FLocation: TDBGFieldLocation; 531 FDBGType: TDBGType; 532 FClassName: String; 533 procedure IncRefCount; 534 procedure DecRefCount; 535 property RefCount: Integer read FRefCount; 536 public 537 constructor Create(const AName: String; ADBGType: TDBGType; 538 ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags = []; 539 AClassName: String = ''); 540 destructor Destroy; override; 541 property Name: String read FName write FName; 542 property DBGType: TDBGType read FDBGType; 543 property Location: TDBGFieldLocation read FLocation; 544 property Flags: TDBGFieldFlags read FFlags; 545 property ClassName: String read FClassName write FClassName; // the class in which the field was declared 546 end; 547 548 { TDBGFields } 549 550 TDBGFields = class(TObject) 551 private 552 FList: TList; 553 function GetField(const AIndex: Integer): TDBGField; 554 function GetCount: Integer; 555 protected 556 public 557 constructor Create; 558 destructor Destroy; override; 559 property Count: Integer read GetCount; 560 property Items[const AIndex: Integer]: TDBGField read GetField; default; 561 procedure Add(const AField: TDBGField); 562 end; 563 564 TDBGTypes = class(TObject) 565 private 566 function GetType(const AIndex: Integer): TDBGType; 567 function GetCount: Integer; 568 protected 569 FList: TList; 570 public 571 constructor Create; 572 destructor Destroy; override; 573 property Count: Integer read GetCount; 574 property Items[const AIndex: Integer]: TDBGType read GetType; default; 575 end; 576 577 { TDBGType } 578 579 TDBGType = class(TObject) 580 private 581 function GetFields: TDBGFields; 582 protected 583 FAncestor: String; 584 FResult: TDBGType; 585 FResultString: String; 586 FArguments: TDBGTypes; 587 FAttributes: TDBGSymbolAttributes; 588 FFields: TDBGFields; 589 FKind: TDBGSymbolKind; 590 FMembers: TStrings; 591 FTypeName: String; 592 FTypeDeclaration: String; 593 FDBGValue: TDBGValue; 594 FBoundHigh: Integer; 595 FBoundLow: Integer; 596 FLen: Integer; 597 procedure Init; virtual; 598 public 599 Value: TDBGValue; 600 constructor Create(AKind: TDBGSymbolKind; const ATypeName: String); 601 constructor Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType = nil); 602 destructor Destroy; override; 603 property Ancestor: String read FAncestor write FAncestor; 604 property Arguments: TDBGTypes read FArguments; 605 property Fields: TDBGFields read GetFields; 606 property Kind: TDBGSymbolKind read FKind; 607 property Attributes: TDBGSymbolAttributes read FAttributes; 608 property TypeName: String read FTypeName; // Name/Alias as in type section. One pascal token, or empty 609 property TypeDeclaration: String read FTypeDeclaration; // Declaration (for array, set, enum, ..) 610 property Members: TStrings read FMembers; // Set & ENUM 611 property Len: Integer read FLen; // Array 612 property BoundLow: Integer read FBoundLow; // Array 613 property BoundHigh: Integer read FBoundHigh; // Array 614 property Result: TDBGType read FResult; 615 end; 616 617{%endregion ^^^^^ Debug Info ^^^^^ } 618 619{%region Watches ************************************************************** 620 ****************************************************************************** 621 ** ** 622 ** W A T C H E S ** 623 ** ** 624 ****************************************************************************** 625 ******************************************************************************} 626 627 TWatchDisplayFormat = 628 (wdfDefault, 629 wdfStructure, 630 wdfChar, wdfString, 631 wdfDecimal, wdfUnsigned, wdfFloat, wdfHex, 632 wdfPointer, 633 wdfMemDump, wdfBinary 634 ); 635 636 TWatch = class; 637 TWatchesMonitor = class; 638 639 { TWatchValue } 640 641 TWatchValue = class(TFreeNotifyingObject) 642 private 643 FTypeInfo: TDBGType; 644 FValue: String; 645 FValidity: TDebuggerDataState; 646 FWatch: TWatch; 647 648 procedure SetValidity(AValue: TDebuggerDataState); virtual; 649 procedure SetValue(AValue: String); 650 procedure SetTypeInfo(AValue: TDBGType); 651 function GetWatch: TWatch; 652 protected 653 FDisplayFormat: TWatchDisplayFormat; 654 FEvaluateFlags: TDBGEvaluateFlags; 655 FRepeatCount: Integer; 656 FStackFrame: Integer; 657 FThreadId: Integer; 658 procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; 659 660 function GetExpression: String; virtual; 661 function GetTypeInfo: TDBGType; virtual; 662 function GetValue: String; virtual; 663 public 664 constructor Create(AOwnerWatch: TWatch); 665 destructor Destroy; override; 666 procedure Assign(AnOther: TWatchValue); virtual; 667 property DisplayFormat: TWatchDisplayFormat read FDisplayFormat; 668 property EvaluateFlags: TDBGEvaluateFlags read FEvaluateFlags; 669 property RepeatCount: Integer read FRepeatCount; 670 property ThreadId: Integer read FThreadId; 671 property StackFrame: Integer read FStackFrame; 672 property Expression: String read GetExpression; 673 property Watch: TWatch read GetWatch; 674 public 675 property Validity: TDebuggerDataState read FValidity write SetValidity; 676 property Value: String read GetValue write SetValue; 677 property TypeInfo: TDBGType read GetTypeInfo write SetTypeInfo; 678 end; 679 680 { TWatchValueList } 681 682 TWatchValueList = class 683 private 684 FList: TList; 685 FWatch: TWatch; 686 function GetEntry(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; 687 function GetEntryByIdx(AnIndex: integer): TWatchValue; 688 protected 689 function CreateEntry(const {%H-}AThreadId: Integer; const {%H-}AStackFrame: Integer): TWatchValue; virtual; 690 function CopyEntry(AnEntry: TWatchValue): TWatchValue; virtual; 691 public 692 procedure Assign(AnOther: TWatchValueList); 693 constructor Create(AOwnerWatch: TWatch); 694 destructor Destroy; override; 695 procedure Add(AnEntry: TWatchValue); 696 procedure Clear; 697 function Count: Integer; 698 property EntriesByIdx[AnIndex: integer]: TWatchValue read GetEntryByIdx; 699 property Entries[const AThreadId: Integer; const AStackFrame: Integer]: TWatchValue 700 read GetEntry; default; 701 property Watch: TWatch read FWatch; 702 end; 703 704 { TWatch } 705 706 TWatch = class(TDelayedUdateItem) 707 private 708 709 procedure SetDisplayFormat(AValue: TWatchDisplayFormat); 710 procedure SetEnabled(AValue: Boolean); 711 procedure SetEvaluateFlags(AValue: TDBGEvaluateFlags); 712 procedure SetExpression(AValue: String); 713 procedure SetRepeatCount(AValue: Integer); 714 function GetValue(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; 715 protected 716 FEnabled: Boolean; 717 FEvaluateFlags: TDBGEvaluateFlags; 718 FExpression: String; 719 FDisplayFormat: TWatchDisplayFormat; 720 FRepeatCount: Integer; 721 FValueList: TWatchValueList; 722 723 procedure DoModified; virtual; // user-storable data: expression, enabled, display-format 724 procedure DoEnableChange; virtual; 725 procedure DoExpressionChange; virtual; 726 procedure DoDisplayFormatChanged; virtual; 727 procedure AssignTo(Dest: TPersistent); override; 728 function CreateValueList: TWatchValueList; virtual; 729 public 730 constructor Create(ACollection: TCollection); override; 731 destructor Destroy; override; 732 procedure ClearValues; virtual; 733 public 734 property Enabled: Boolean read FEnabled write SetEnabled; 735 property Expression: String read FExpression write SetExpression; 736 property DisplayFormat: TWatchDisplayFormat read FDisplayFormat write SetDisplayFormat; 737 property EvaluateFlags: TDBGEvaluateFlags read FEvaluateFlags write SetEvaluateFlags; 738 property RepeatCount: Integer read FRepeatCount write SetRepeatCount; 739 property Values[const AThreadId: Integer; const AStackFrame: Integer]: TWatchValue 740 read GetValue; 741 end; 742 TWatchClass = class of TWatch; 743 744 { TWatches } 745 746 TWatches = class(TCollection) 747 protected 748 function GetItemBase(const AnIndex: Integer): TWatch; 749 procedure SetItemBase(const AnIndex: Integer; const AValue: TWatch); 750 function WatchClass: TWatchClass; virtual; 751 public 752 constructor Create; 753 procedure ClearValues; 754 function Find(const AExpression: String): TWatch; 755 property Items[const AnIndex: Integer]: TWatch read GetItemBase write SetItemBase; default; 756 end; 757 758 { TWatchesSupplier } 759 760 TWatchesSupplier = class(TDebuggerDataSupplier) 761 private 762 function GetCurrentWatches: TWatches; 763 function GetMonitor: TWatchesMonitor; 764 procedure SetMonitor(AValue: TWatchesMonitor); 765 protected 766 procedure DoStateChange(const AOldState: TDBGState); override; // workaround for state changes during TWatchValue.GetValue 767 procedure InternalRequestData(AWatchValue: TWatchValue); virtual; 768 public 769 constructor Create(const ADebugger: TDebuggerIntf); 770 procedure RequestData(AWatchValue: TWatchValue); 771 property CurrentWatches: TWatches read GetCurrentWatches; 772 property Monitor: TWatchesMonitor read GetMonitor write SetMonitor; 773 end; 774 775 { TWatchesMonitor } 776 777 TWatchesMonitor = class(TDebuggerDataMonitor) 778 private 779 FWatches: TWatches; 780 function GetSupplier: TWatchesSupplier; 781 procedure SetSupplier(AValue: TWatchesSupplier); 782 protected 783 function CreateWatches: TWatches; virtual; 784 public 785 constructor Create; 786 destructor Destroy; override; 787 property Watches: TWatches read FWatches; 788 property Supplier: TWatchesSupplier read GetSupplier write SetSupplier; 789 end; 790 791{%endregion ^^^^^ Watches ^^^^^ } 792 793{%region Locals *************************************************************** 794 ****************************************************************************** 795 ** ** 796 ** L O C A L S ** 797 ** ** 798 ****************************************************************************** 799 ******************************************************************************} 800 801 // TODO: a more watch-like value object 802 TLocalsMonitor = class; 803 804 { TLocalsValue } 805 806 TLocalsValue = class(TDbgEntityValue) 807 private 808 FName: String; 809 FValue: String; 810 protected 811 procedure DoAssign(AnOther: TDbgEntityValue); override; 812 public 813 property Name: String read FName; 814 property Value: String read FValue; 815 end; 816 817 { TLocals } 818 819 TLocals = class(TDbgEntityValuesList) 820 private 821 function GetEntry(AnIndex: Integer): TLocalsValue; 822 function GetName(const AnIndex: Integer): String; 823 function GetValue(const AnIndex: Integer): String; 824 protected 825 function CreateEntry: TDbgEntityValue; override; 826 public 827 procedure Add(const AName, AValue: String); 828 procedure SetDataValidity({%H-}AValidity: TDebuggerDataState); virtual; 829 public 830 function Count: Integer;reintroduce; virtual; 831 property Entries[AnIndex: Integer]: TLocalsValue read GetEntry; 832 property Names[const AnIndex: Integer]: String read GetName; 833 property Values[const AnIndex: Integer]: String read GetValue; 834 end; 835 836 { TLocalsList } 837 838 TLocalsList = class(TDbgEntitiesThreadStackList) 839 private 840 function GetEntry(AThreadId, AStackFrame: Integer): TLocals; 841 function GetEntryByIdx(AnIndex: Integer): TLocals; 842 protected 843 //function CreateEntry(AThreadId, AStackFrame: Integer): TDbgEntityValuesList; override; 844 public 845 property EntriesByIdx[AnIndex: Integer]: TLocals read GetEntryByIdx; 846 property Entries[AThreadId, AStackFrame: Integer]: TLocals read GetEntry; default; 847 end; 848 849 { TLocalsSupplier } 850 851 TLocalsSupplier = class(TDebuggerDataSupplier) 852 private 853 function GetCurrentLocalsList: TLocalsList; 854 function GetMonitor: TLocalsMonitor; 855 procedure SetMonitor(AValue: TLocalsMonitor); 856 protected 857 public 858 procedure RequestData(ALocals: TLocals); virtual; 859 property CurrentLocalsList: TLocalsList read GetCurrentLocalsList; 860 property Monitor: TLocalsMonitor read GetMonitor write SetMonitor; 861 end; 862 863 { TLocalsMonitor } 864 865 TLocalsMonitor = class(TDebuggerDataMonitor) 866 private 867 FLocalsList: TLocalsList; 868 function GetSupplier: TLocalsSupplier; 869 procedure SetSupplier(AValue: TLocalsSupplier); 870 protected 871 function CreateLocalsList: TLocalsList; virtual; 872 public 873 constructor Create; 874 destructor Destroy; override; 875 property LocalsList: TLocalsList read FLocalsList; 876 property Supplier: TLocalsSupplier read GetSupplier write SetSupplier; 877 end; 878 879{%endregion ^^^^^ Locals ^^^^^ } 880 881{%region Line Info ************************************************************ 882 ****************************************************************************** 883 ** ** 884 ** L I N E I N F O ** 885 ** ** 886 ****************************************************************************** 887 ******************************************************************************} 888 889 TIDELineInfoEvent = procedure(const ASender: TObject; const ASource: String) of object; 890 891 { TBaseLineInfo } 892 893 TBaseLineInfo = class(TObject) 894 protected 895 function GetSource(const {%H-}AnIndex: integer): String; virtual; 896 public 897 constructor Create; 898 function Count: Integer; virtual; 899 function HasAddress(const AIndex: Integer; const ALine: Integer): Boolean; virtual; 900 function HasAddress(const ASource: String; const ALine: Integer): Boolean; 901 function GetInfo({%H-}AAddress: TDbgPtr; out {%H-}ASource, {%H-}ALine, {%H-}AOffset: Integer): Boolean; virtual; 902 function IndexOf(const {%H-}ASource: String): integer; virtual; 903 procedure Request(const {%H-}ASource: String); virtual; 904 procedure Cancel(const {%H-}ASource: String); virtual; 905 public 906 property Sources[const AnIndex: Integer]: String read GetSource; 907 end; 908 909 { TDBGLineInfo } 910 911 TDBGLineInfo = class(TBaseLineInfo) 912 private 913 FDebugger: TDebuggerIntf; // reference to our debugger 914 FOnChange: TIDELineInfoEvent; 915 protected 916 procedure Changed(ASource: String); virtual; 917 procedure DoChange(ASource: String); 918 procedure DoStateChange(const {%H-}AOldState: TDBGState); virtual; 919 property Debugger: TDebuggerIntf read FDebugger write FDebugger; 920 public 921 constructor Create(const ADebugger: TDebuggerIntf); 922 property OnChange: TIDELineInfoEvent read FOnChange write FOnChange; 923 end; 924 925{%endregion ^^^^^ Line Info ^^^^^ } 926 927{%region Register ************************************************************* 928 ****************************************************************************** 929 ** ** 930 ** R E G I S T E R S ** 931 ** ** 932 ****************************************************************************** 933 ******************************************************************************} 934 935 TRegisterDisplayFormat = (rdDefault, rdHex, rdBinary, rdOctal, rdDecimal, rdRaw); 936 TRegisterDisplayFormats = set of TRegisterDisplayFormat; 937 TRegistersMonitor = class; 938 939 { TRegisterDisplayValue } 940 941 TRegisterDisplayValue = class // Only created if ddsValid 942 private 943 FStringValue: String; // default, rdRaw is always in FStringValue 944 FNumValue: QWord; 945 FSize: Integer; // 2, 4 or 8 bytes 946 FFlags: set of (rdvHasNum); // Calculate numeric values. 947 FSupportedDispFormats: TRegisterDisplayFormats; 948 function GetValue(ADispFormat: TRegisterDisplayFormat): String; 949 public 950 procedure Assign(AnOther: TRegisterDisplayValue); 951 procedure SetAsNum(AValue: QWord; ASize: Integer); 952 procedure SetAsText(AValue: String); 953 procedure AddFormats(AFormats: TRegisterDisplayFormats); 954 property SupportedDispFormats: TRegisterDisplayFormats read FSupportedDispFormats; 955 property Value[ADispFormat: TRegisterDisplayFormat]: String read GetValue; 956 end; 957 958 { TRegisterValue } 959 960 TRegisterValue = class(TDbgEntityValue) 961 private 962 FDataValidity: TDebuggerDataState; 963 FDisplayFormat: TRegisterDisplayFormat; 964 FModified: Boolean; 965 FName: String; 966 FValues: Array of TRegisterDisplayValue; 967 function GetHasValue: Boolean; 968 function GetHasValueFormat(ADispFormat: TRegisterDisplayFormat): Boolean; 969 function GetValue: String; 970 function GetValueObj: TRegisterDisplayValue; 971 function GetValueObjFormat(ADispFormat: TRegisterDisplayFormat): TRegisterDisplayValue; 972 procedure SetDisplayFormat(AValue: TRegisterDisplayFormat); 973 procedure SetValue(AValue: String); 974 function GetValueObject(ACreateNew: Boolean = False): TRegisterDisplayValue; 975 function GetValueObject(ADispFormat: TRegisterDisplayFormat; ACreateNew: Boolean = False): TRegisterDisplayValue; 976 procedure SetDataValidity(AValidity: TDebuggerDataState); 977 procedure ClearDispValues; 978 protected 979 procedure DoAssign(AnOther: TDbgEntityValue); override; 980 procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; 981 procedure DoDisplayFormatChanged({%H-}AnOldFormat: TRegisterDisplayFormat); virtual; 982 procedure DoValueNotEvaluated; virtual; 983 public 984 destructor Destroy; override; 985 property Name: String read FName; 986 property Value: String read GetValue write SetValue; 987 property DisplayFormat: TRegisterDisplayFormat read FDisplayFormat write SetDisplayFormat; 988 property Modified: Boolean read FModified write FModified; 989 property DataValidity: TDebuggerDataState read FDataValidity write SetDataValidity; 990 property ValueObj: TRegisterDisplayValue read GetValueObj; // Will create the object for current DispFormat. Only use for setting data. 991 property HasValue: Boolean read GetHasValue; 992 property ValueObjFormat[ADispFormat: TRegisterDisplayFormat]: TRegisterDisplayValue read GetValueObjFormat; // Will create the object for current DispFormat. Only use for setting data. 993 property HasValueFormat[ADispFormat: TRegisterDisplayFormat]: Boolean read GetHasValueFormat; 994 end; 995 996 { TRegisters } 997 998 TRegisters = class(TDbgEntityValuesList) 999 private 1000 FDataValidity: TDebuggerDataState; 1001 function GetEntry(AnIndex: Integer): TRegisterValue; 1002 function GetEntryByName(const AName: String): TRegisterValue; 1003 procedure SetDataValidity(AValue: TDebuggerDataState); 1004 protected 1005 function CreateEntry: TDbgEntityValue; override; 1006 procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; 1007 public 1008 function Count: Integer; reintroduce; virtual; 1009 property Entries[AnIndex: Integer]: TRegisterValue read GetEntry; default; 1010 property EntriesByName[const AName: String]: TRegisterValue read GetEntryByName; // autocreate 1011 property DataValidity: TDebuggerDataState read FDataValidity write SetDataValidity; 1012 end; 1013 1014 { TRegistersList } 1015 1016 TRegistersList = class(TDbgEntitiesThreadStackList) 1017 private 1018 function GetEntry(AThreadId, AStackFrame: Integer): TRegisters; 1019 function GetEntryByIdx(AnIndex: Integer): TRegisters; 1020 protected 1021 public 1022 property EntriesByIdx[AnIndex: Integer]: TRegisters read GetEntryByIdx; 1023 property Entries[AThreadId, AStackFrame: Integer]: TRegisters read GetEntry; default; 1024 end; 1025 1026 { TRegisterSupplier } 1027 1028 TRegisterSupplier = class(TDebuggerDataSupplier) 1029 private 1030 function GetCurrentRegistersList: TRegistersList; 1031 function GetMonitor: TRegistersMonitor; 1032 procedure SetMonitor(AValue: TRegistersMonitor); 1033 protected 1034 public 1035 procedure RequestData(ARegisters: TRegisters); virtual; 1036 property CurrentRegistersList: TRegistersList read GetCurrentRegistersList; 1037 property Monitor: TRegistersMonitor read GetMonitor write SetMonitor; 1038 end; 1039 1040 { TRegistersMonitor } 1041 1042 TRegistersMonitor = class(TDebuggerDataMonitor) 1043 private 1044 FRegistersList: TRegistersList; 1045 function GetSupplier: TRegisterSupplier; 1046 procedure SetSupplier(AValue: TRegisterSupplier); 1047 protected 1048 function CreateRegistersList: TRegistersList; virtual; 1049 public 1050 constructor Create; 1051 destructor Destroy; override; 1052 property RegistersList: TRegistersList read FRegistersList; 1053 property Supplier: TRegisterSupplier read GetSupplier write SetSupplier; 1054 end; 1055 1056{%endregion ^^^^^ Register ^^^^^ } 1057 1058{%region Callstack ************************************************************ 1059 ****************************************************************************** 1060 ** ** 1061 ** C A L L S T A C K ** 1062 ** ** 1063 ****************************************************************************** 1064 ****************************************************************************** 1065 * The entries for the callstack are created on demand. This way when the * 1066 * first entry is needed, it isn't required to create the whole stack * 1067 * * 1068 * TCallStackEntry needs to stay a readonly object so its data can be shared * 1069 ******************************************************************************} 1070 1071 TCallStackMonitor = class; 1072 1073 { TCallStackEntryBase } 1074 1075 TCallStackEntry = class(TObject) 1076 private 1077 FValidity: TDebuggerDataState; 1078 FIndex: Integer; 1079 FAddress: TDbgPtr; 1080 FFunctionName: String; 1081 FLine: Integer; 1082 FArguments: TStrings; 1083 protected 1084 //// for use in TThreadEntry ONLY 1085 //function GetThreadId: Integer; virtual; abstract; 1086 //function GetThreadName: String; virtual; abstract; 1087 //function GetThreadState: String; virtual; abstract; 1088 //procedure SetThreadState(AValue: String); virtual; abstract; 1089 function GetArgumentCount: Integer; 1090 function GetArgumentName(const AnIndex: Integer): String; 1091 function GetArgumentValue(const AnIndex: Integer): String; 1092 protected 1093 property Arguments: TStrings read FArguments; 1094 function GetFunctionName: String; virtual; 1095 function GetSource: String; virtual; 1096 function GetValidity: TDebuggerDataState; virtual; 1097 procedure SetValidity(AValue: TDebuggerDataState); virtual; 1098 procedure InitFields(const AIndex:Integer; const AnAddress: TDbgPtr; 1099 const AnArguments: TStrings; const AFunctionName: String; 1100 const ALine: Integer; AValidity: TDebuggerDataState); 1101 public 1102 constructor Create; 1103 function CreateCopy: TCallStackEntry; virtual; 1104 destructor Destroy; override; 1105 procedure Assign(AnOther: TCallStackEntry); virtual; 1106 procedure Init(const AnAddress: TDbgPtr; 1107 const AnArguments: TStrings; const AFunctionName: String; 1108 const {%H-}AUnitName, {%H-}AClassName, {%H-}AProcName, {%H-}AFunctionArgs: String; 1109 const ALine: Integer; AState: TDebuggerDataState = ddsValid); virtual; 1110 procedure Init(const AnAddress: TDbgPtr; 1111 const AnArguments: TStrings; const AFunctionName: String; 1112 const {%H-}FileName, {%H-}FullName: String; 1113 const ALine: Integer; AState: TDebuggerDataState = ddsValid); virtual; 1114 procedure ClearLocation; virtual; // TODO need a way to call Changed on TCallStack or TThreads // corrently done in SetThreadState 1115 function GetFunctionWithArg: String; 1116 //function IsCurrent: Boolean; 1117 //procedure MakeCurrent; 1118 property Address: TDbgPtr read FAddress; 1119 property ArgumentCount: Integer read GetArgumentCount; 1120 property ArgumentNames[const AnIndex: Integer]: String read GetArgumentName; 1121 property ArgumentValues[const AnIndex: Integer]: String read GetArgumentValue; 1122 property FunctionName: String read FFunctionName; 1123 property Index: Integer read FIndex; 1124 property Line: Integer read FLine; 1125 property Source: String read GetSource; 1126 property Validity: TDebuggerDataState read GetValidity write SetValidity; 1127 public 1128 //// for use in TThreadEntry ONLY 1129 //property ThreadId: Integer read GetThreadId; 1130 //property ThreadName: String read GetThreadName; 1131 //property ThreadState: String read GetThreadState write SetThreadState; 1132 end; 1133 1134 { TCallStackBase } 1135 1136 TCallStackBase = class(TFreeNotifyingObject) 1137 protected 1138 FCurrent: Integer; 1139 FThreadId: Integer; 1140 function GetNewCurrentIndex: Integer; virtual; 1141 function GetEntryBase(AIndex: Integer): TCallStackEntry; virtual; abstract; 1142 function GetCount: Integer; virtual; 1143 procedure SetCount(AValue: Integer); virtual; abstract; 1144 function GetCurrent: Integer; virtual; 1145 procedure SetCurrent(AValue: Integer); virtual; 1146 function GetHighestUnknown: Integer; virtual; 1147 function GetLowestUnknown: Integer; virtual; 1148 function GetRawEntries: TMap; virtual; abstract; 1149 public 1150 constructor Create; 1151 function CreateCopy: TCallStackBase; virtual; 1152 procedure Assign(AnOther: TCallStackBase); virtual; 1153 1154 procedure PrepareRange({%H-}AIndex, {%H-}ACount: Integer); virtual; abstract; 1155 procedure DoEntriesCreated; virtual; abstract; 1156 procedure DoEntriesUpdated; virtual; abstract; 1157 procedure SetCountValidity({%H-}AValidity: TDebuggerDataState); virtual; 1158 procedure SetHasAtLeastCountInfo({%H-}AValidity: TDebuggerDataState; {%H-}AMinCount: Integer = -1); virtual; 1159 procedure SetCurrentValidity({%H-}AValidity: TDebuggerDataState); virtual; 1160 function CountLimited(ALimit: Integer): Integer; virtual; abstract; 1161 property Count: Integer read GetCount write SetCount; 1162 property CurrentIndex: Integer read GetCurrent write SetCurrent; 1163 property Entries[AIndex: Integer]: TCallStackEntry read GetEntryBase; 1164 property ThreadId: Integer read FThreadId write FThreadId; 1165 property NewCurrentIndex: Integer read GetNewCurrentIndex; 1166 1167 property RawEntries: TMap read GetRawEntries; 1168 property LowestUnknown: Integer read GetLowestUnknown; 1169 property HighestUnknown: Integer read GetHighestUnknown; 1170 end; 1171 1172 { TCallStackListBase } 1173 1174 TCallStackList = class 1175 private 1176 FList: TList; 1177 function GetEntry(const AIndex: Integer): TCallStackBase; 1178 function GetEntryForThread(const AThreadId: Integer): TCallStackBase; 1179 protected 1180 function NewEntryForThread(const {%H-}AThreadId: Integer): TCallStackBase; virtual; 1181 public 1182 constructor Create; 1183 destructor Destroy; override; 1184 procedure Assign(AnOther: TCallStackList); virtual; 1185 procedure Add(ACallStack: TCallStackBase); 1186 procedure Clear; virtual; 1187 function Count: Integer; virtual; // Count of already requested CallStacks (via ThreadId) 1188 property Entries[const AIndex: Integer]: TCallStackBase read GetEntry; default; 1189 property EntriesForThreads[const AThreadId: Integer]: TCallStackBase read GetEntryForThread; 1190 end; 1191 1192 { TCallStackSupplier } 1193 1194 TCallStackSupplier = class(TDebuggerDataSupplier) 1195 private 1196 function GetCurrentCallStackList: TCallStackList; 1197 function GetMonitor: TCallStackMonitor; 1198 procedure SetMonitor(AValue: TCallStackMonitor); 1199 protected 1200 //procedure CurrentChanged; 1201 procedure Changed; 1202 public 1203 procedure RequestCount(ACallstack: TCallStackBase); virtual; 1204 procedure RequestAtLeastCount(ACallstack: TCallStackBase; {%H-}ARequiredMinCount: Integer); virtual; 1205 procedure RequestCurrent(ACallstack: TCallStackBase); virtual; 1206 procedure RequestEntries(ACallstack: TCallStackBase); virtual; 1207 procedure UpdateCurrentIndex; virtual; 1208 property CurrentCallStackList: TCallStackList read GetCurrentCallStackList; 1209 property Monitor: TCallStackMonitor read GetMonitor write SetMonitor; 1210 end; 1211 1212 { TCallStackMonitor } 1213 1214 TCallStackMonitor = class(TDebuggerDataMonitor) 1215 private 1216 FCallStackList: TCallStackList; 1217 function GetSupplier: TCallStackSupplier; 1218 procedure SetSupplier(AValue: TCallStackSupplier); 1219 protected 1220 function CreateCallStackList: TCallStackList; virtual; 1221 public 1222 constructor Create; 1223 destructor Destroy; override; 1224 property CallStackList: TCallStackList read FCallStackList; 1225 property Supplier: TCallStackSupplier read GetSupplier write SetSupplier; 1226 end; 1227 1228{%endregion ^^^^^ Callstack ^^^^^ } 1229 1230{%region ***** Disassembler ***** } 1231(******************************************************************************) 1232(******************************************************************************) 1233(** **) 1234(** D I S A S S E M B L E R **) 1235(** **) 1236(******************************************************************************) 1237(******************************************************************************) 1238 1239(* Some values to calculate how many bytes to disassemble for a given amount of lines 1240 Those values are only guesses *) 1241const 1242 // DAssBytesPerCommandAvg: Average len: Used for LinesBefore/LinesAfter. 1243 // (should rather be to big than to small) 1244 DAssBytesPerCommandAvg = 8; 1245 // If we have a range with more then DAssRangeOverFuncTreshold * DAssBytesPerCommandAvg 1246 // then prefer the Range-end as start, rather than the known func start 1247 // (otherwhise re-dissassemble the whole function, including the part already known) 1248 // The assumption is, that no single *source* statement starting before this range, 1249 // will ever reach into the next statement (where the next statement already started / mixed addresses) 1250 DAssRangeOverFuncTreshold = 15; 1251 // Never dis-assemble more bytes in a single go (actually, max-offset before requested addr) 1252 DAssMaxRangeSize = 4096; 1253 1254type 1255 PDisassemblerEntry = ^TDisassemblerEntry; 1256 TDisassemblerEntry = record 1257 Addr: TDbgPtr; // Address 1258 Dump: String; // Raw Data 1259 Statement: String; // Asm 1260 FuncName: String; // Function, if avail 1261 Offset: Integer; // Byte-Offest in Fonction 1262 SrcFileName: String; // SrcFile if avail 1263 SrcFileLine: Integer; // Line in SrcFile 1264 SrcStatementIndex: SmallInt; // Index of Statement, within list of Stmnt of the same SrcLine 1265 SrcStatementCount: SmallInt; // Count of Statements for this SrcLine 1266 end; 1267 1268 TDisassemblerAddressValidity = 1269 (avFoundFunction, avFoundRange, avFoundStatement, // known address 1270 avGuessed, // guessed 1271 avExternRequest, // As requested by external caller 1272 avPadded // Padded, because address was not known for sure 1273 ); 1274 TDisassemblerAddress = record 1275 Value, GuessedValue: TDBGPtr; 1276 Offset: Integer; 1277 Validity: TDisassemblerAddressValidity; 1278 end; 1279 1280 1281 { TBaseDisassembler } 1282 1283 TBaseDisassembler = class(TObject) 1284 private 1285 FBaseAddr: TDbgPtr; 1286 FCountAfter: Integer; 1287 FCountBefore: Integer; 1288 FChangedLockCount: Integer; 1289 FIsChanged: Boolean; 1290 function GetEntryPtr(AIndex: Integer): PDisassemblerEntry; 1291 procedure IndexError(AIndex: Integer); 1292 function GetEntry(AIndex: Integer): TDisassemblerEntry; 1293 protected 1294 function InternalGetEntry({%H-}AIndex: Integer): TDisassemblerEntry; virtual; 1295 function InternalGetEntryPtr({%H-}AIndex: Integer): PDisassemblerEntry; virtual; 1296 procedure DoChanged; virtual; 1297 procedure Changed; 1298 procedure LockChanged; 1299 procedure UnlockChanged; 1300 procedure InternalIncreaseCountBefore(ACount: Integer); 1301 procedure InternalIncreaseCountAfter(ACount: Integer); 1302 procedure SetCountBefore(ACount: Integer); 1303 procedure SetCountAfter(ACount: Integer); 1304 procedure SetBaseAddr(AnAddr: TDbgPtr); 1305 public 1306 constructor Create; 1307 destructor Destroy; override; 1308 procedure Clear; virtual; 1309 // Returns "True", if the range is valid, if not a ChangeNotification will be triggered later 1310 function PrepareRange({%H-}AnAddr: TDbgPtr; {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): Boolean; virtual; 1311 property BaseAddr: TDbgPtr read FBaseAddr; 1312 property CountAfter: Integer read FCountAfter; 1313 property CountBefore: Integer read FCountBefore; 1314 property Entries[AIndex: Integer]: TDisassemblerEntry read GetEntry; 1315 property EntriesPtr[Index: Integer]: PDisassemblerEntry read GetEntryPtr; 1316 end; 1317 1318 { TDBGDisassemblerEntryRange } 1319 1320 TDBGDisassemblerEntryRange = class 1321 private 1322 FCount: Integer; 1323 FEntries: array of TDisassemblerEntry; 1324 FLastEntryEndAddr: TDBGPtr; 1325 FRangeEndAddr: TDBGPtr; 1326 FRangeStartAddr: TDBGPtr; 1327 function GetCapacity: Integer; 1328 function GetEntry(Index: Integer): TDisassemblerEntry; 1329 function GetEntryPtr(Index: Integer): PDisassemblerEntry; 1330 procedure SetCapacity(const AValue: Integer); 1331 procedure SetCount(const AValue: Integer); 1332 public 1333 procedure Clear; 1334 function Append(const AnEntryPtr: PDisassemblerEntry): Integer; 1335 procedure Merge(const AnotherRange: TDBGDisassemblerEntryRange); 1336 // Actual addresses on the ranges 1337 function FirstAddr: TDbgPtr; 1338 function LastAddr: TDbgPtr; 1339 function ContainsAddr(const AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): Boolean; 1340 function IndexOfAddr(const AnAddr: TDbgPtr): Integer; 1341 function IndexOfAddrWithOffs(const AnAddr: TDbgPtr): Integer; 1342 function IndexOfAddrWithOffs(const AnAddr: TDbgPtr; out AOffs: Integer): Integer; 1343 property Count: Integer read FCount write SetCount; 1344 property Capacity: Integer read GetCapacity write SetCapacity; 1345 property Entries[Index: Integer]: TDisassemblerEntry read GetEntry; 1346 property EntriesPtr[Index: Integer]: PDisassemblerEntry read GetEntryPtr; 1347 // The first address behind last entry 1348 property LastEntryEndAddr: TDBGPtr read FLastEntryEndAddr write FLastEntryEndAddr; 1349 // The addresses for which the range was requested 1350 // The range may bo more, than the entries, if there a gaps that cannot be retrieved. 1351 property RangeStartAddr: TDBGPtr read FRangeStartAddr write FRangeStartAddr; 1352 property RangeEndAddr: TDBGPtr read FRangeEndAddr write FRangeEndAddr; 1353 end; 1354 1355 { TDBGDisassemblerEntryMap } 1356 1357 TDBGDisassemblerEntryMapMergeEvent 1358 = procedure(MergeReceiver, MergeGiver: TDBGDisassemblerEntryRange) of object; 1359 1360 { TDBGDisassemblerEntryMapIterator } 1361 TDBGDisassemblerEntryMap = class; 1362 1363 TDBGDisassemblerEntryMapIterator = class(TMapIterator) 1364 public 1365 function GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; 1366 function NextRange: TDBGDisassemblerEntryRange; 1367 function PreviousRange: TDBGDisassemblerEntryRange; 1368 end; 1369 1370 TDBGDisassemblerEntryMap = class(TMap) 1371 private 1372 FIterator: TDBGDisassemblerEntryMapIterator; 1373 FOnDelete: TNotifyEvent; 1374 FOnMerge: TDBGDisassemblerEntryMapMergeEvent; 1375 FFreeItemLock: Boolean; 1376 protected 1377 procedure ReleaseData(ADataPtr: Pointer); override; 1378 public 1379 constructor Create(AIdType: TMapIdType; ADataSize: Cardinal); 1380 destructor Destroy; override; 1381 // AddRange, may destroy the object 1382 procedure AddRange(const ARange: TDBGDisassemblerEntryRange); // Arange may be freed 1383 function GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; 1384 property OnDelete: TNotifyEvent read FOnDelete write FOnDelete; 1385 property OnMerge: TDBGDisassemblerEntryMapMergeEvent 1386 read FOnMerge write FOnMerge; 1387 end; 1388 1389 { TDBGDisassemblerRangeExtender } 1390 1391 TDoDisassembleRangeProc = function(AnEntryRanges: TDBGDisassemblerEntryMap; AFirstAddr, ALastAddr: TDisassemblerAddress; StopAfterAddress: TDBGPtr; StopAfterNumLines: Integer): Boolean {$ifdef disassemblernestedproc} is nested {$else} of object{$endif}; 1392 TDisassembleCancelProc = function(): Boolean {$ifdef disassemblernestedproc} is nested {$else} of object {$endif}; 1393 TDisassembleAdjustToKnowFunctionStart = function (var AStartAddr: TDisassemblerAddress): Boolean {$ifdef disassemblernestedproc} is nested {$else} of object {$endif}; 1394 1395 TDBGDisassemblerRangeExtender = class 1396 private 1397 FOnAdjustToKnowFunctionStart: TDisassembleAdjustToKnowFunctionStart; 1398 FOnCheckCancel: TDisassembleCancelProc; 1399 FOnDoDisassembleRange: TDoDisassembleRangeProc; 1400 1401 FEntryRangeMap: TDBGDisassemblerEntryMap; 1402 FRangeIterator: TDBGDisassemblerEntryMapIterator; 1403 function CheckIfCancelled: boolean; 1404 function AdjustToRangeOrKnowFunctionStart(var AStartAddr: TDisassemblerAddress; 1405 ARangeBefore: TDBGDisassemblerEntryRange): Boolean; 1406 function InitAddress(AValue: TDBGPtr; AValidity: TDisassemblerAddressValidity; 1407 AnOffset: Integer = -1): TDisassemblerAddress; 1408 public 1409 constructor Create(AnEntryRangeMap: TDBGDisassemblerEntryMap); 1410 destructor Destroy; override; 1411 function DisassembleRange(ALinesBefore, 1412 ALinesAfter: integer; AStartAddr: TDBGPtr; AnEndAddr: TDBGPtr): boolean; 1413 property OnDoDisassembleRange: TDoDisassembleRangeProc read FOnDoDisassembleRange write FOnDoDisassembleRange; 1414 property OnCheckCancel: TDisassembleCancelProc read FOnCheckCancel write FOnCheckCancel; 1415 property OnAdjustToKnowFunctionStart: TDisassembleAdjustToKnowFunctionStart read FOnAdjustToKnowFunctionStart write FOnAdjustToKnowFunctionStart; 1416 end; 1417 1418 { TDBGDisassembler } 1419 1420 TDBGDisassembler = class(TBaseDisassembler) 1421 private 1422 FDebugger: TDebuggerIntf; 1423 FOnChange: TNotifyEvent; 1424 1425 FEntryRanges: TDBGDisassemblerEntryMap; 1426 FCurrentRange: TDBGDisassemblerEntryRange; 1427 procedure EntryRangesOnDelete(Sender: TObject); 1428 procedure EntryRangesOnMerge(MergeReceiver, MergeGiver: TDBGDisassemblerEntryRange); 1429 function FindRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; 1430 protected 1431 procedure DoChanged; override; 1432 procedure DoStateChange(const AOldState: TDBGState); virtual; 1433 function InternalGetEntry(AIndex: Integer): TDisassemblerEntry; override; 1434 function InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; override; 1435 // PrepareEntries returns True, if it already added some entries 1436 function PrepareEntries({%H-}AnAddr: TDbgPtr; {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): boolean; virtual; 1437 function HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;{%H-}AnAddr: 1438 TDbgPtr; var {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): boolean; virtual; 1439 property Debugger: TDebuggerIntf read FDebugger write FDebugger; 1440 property EntryRanges: TDBGDisassemblerEntryMap read FEntryRanges; 1441 public 1442 constructor Create(const ADebugger: TDebuggerIntf); 1443 destructor Destroy; override; 1444 procedure Clear; override; 1445 function PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override; 1446 property OnChange: TNotifyEvent read FOnChange write FOnChange; 1447 end; 1448 1449{%endregion ^^^^^ Disassembler ^^^^^ } 1450 1451{%region Threads ************************************************************** 1452 ****************************************************************************** 1453 ** ** 1454 ** T H R E A D S ** 1455 ** ** 1456 ****************************************************************************** 1457 ******************************************************************************} 1458 1459 TThreadsMonitor = class; 1460 1461 { TThreadEntry } 1462 1463 TThreadEntry = class(TObject) 1464 private 1465 FTopFrame: TCallStackEntry; 1466 protected 1467 FThreadId: Integer; 1468 FThreadName: String; 1469 FThreadState: String; 1470 procedure SetThreadState(AValue: String); virtual; 1471 function CreateStackEntry: TCallStackEntry; virtual; 1472 public 1473 constructor Create; 1474 constructor Create(const AnAdress: TDbgPtr; 1475 const AnArguments: TStrings; const AFunctionName: String; 1476 const FileName, FullName: String; 1477 const ALine: Integer; 1478 const AThreadId: Integer; const AThreadName: String; 1479 const AThreadState: String; 1480 AState: TDebuggerDataState = ddsValid); 1481 function CreateCopy: TThreadEntry; virtual; 1482 destructor Destroy; override; 1483 procedure Assign(AnOther: TThreadEntry); virtual; 1484 published 1485 property ThreadId: Integer read FThreadId; 1486 property ThreadName: String read FThreadName; 1487 property ThreadState: String read FThreadState write SetThreadState; 1488 property TopFrame: TCallStackEntry read FTopFrame; 1489 end; 1490 1491 { TThreadsBase } 1492 1493 TThreads = class(TObject) 1494 private 1495 FCurrentThreadId: Integer; 1496 FList: TList; 1497 function GetEntry(const AnIndex: Integer): TThreadEntry; 1498 function GetEntryById(const AnID: Integer): TThreadEntry; 1499 protected 1500 procedure SetCurrentThreadId(AValue: Integer); virtual; 1501 property List: TList read FList; 1502 public 1503 constructor Create; 1504 destructor Destroy; override; 1505 procedure Assign(AnOther: TThreads); virtual; 1506 function Count: Integer; virtual; 1507 procedure Clear; virtual; 1508 procedure Add(AThread: TThreadEntry); virtual; 1509 procedure Remove(AThread: TThreadEntry); virtual; 1510 function CreateEntry(const AnAdress: TDbgPtr; 1511 const AnArguments: TStrings; const AFunctionName: String; 1512 const FileName, FullName: String; 1513 const ALine: Integer; 1514 const AThreadId: Integer; const AThreadName: String; 1515 const AThreadState: String; 1516 AState: TDebuggerDataState = ddsValid): TThreadEntry; virtual; 1517 procedure SetValidity({%H-}AValidity: TDebuggerDataState); virtual; 1518 property Entries[const AnIndex: Integer]: TThreadEntry read GetEntry; default; 1519 property EntryById[const AnID: Integer]: TThreadEntry read GetEntryById; 1520 property CurrentThreadId: Integer read FCurrentThreadId write SetCurrentThreadId; 1521 end; 1522 1523 { TThreadsSupplier } 1524 1525 TThreadsSupplier = class(TDebuggerDataSupplier) 1526 private 1527 function GetCurrentThreads: TThreads; 1528 function GetMonitor: TThreadsMonitor; 1529 procedure SetMonitor(AValue: TThreadsMonitor); 1530 protected 1531 procedure DoStateChange(const AOldState: TDBGState); override; 1532 procedure DoStateLeavePauseClean; override; 1533 procedure DoCleanAfterPause; virtual; 1534 public 1535 procedure RequestMasterData; virtual; 1536 procedure ChangeCurrentThread({%H-}ANewId: Integer); virtual; 1537 procedure Changed; // TODO: needed because entries can not notify the monitor 1538 property CurrentThreads: TThreads read GetCurrentThreads; 1539 property Monitor: TThreadsMonitor read GetMonitor write SetMonitor; 1540 end; 1541 1542 { TThreadsMonitor } 1543 1544 TThreadsMonitor = class(TDebuggerDataMonitor) 1545 private 1546 FThreads: TThreads; 1547 function GetSupplier: TThreadsSupplier; 1548 procedure SetSupplier(AValue: TThreadsSupplier); 1549 protected 1550 function CreateThreads: TThreads; virtual; 1551 public 1552 constructor Create; 1553 destructor Destroy; override; 1554 property Threads: TThreads read FThreads; 1555 property Supplier: TThreadsSupplier read GetSupplier write SetSupplier; 1556 end; 1557 1558{%endregion ^^^^^ Threads ^^^^^ } 1559 1560{%region Signals / Exceptions *************************************************} 1561(******************************************************************************) 1562(** **) 1563(** S I G N A L S and E X C E P T I O N S **) 1564(** **) 1565(******************************************************************************) 1566(******************************************************************************) 1567 1568 { TBaseSignal } 1569 1570 TBaseSignal = class(TDelayedUdateItem) 1571 private 1572 FHandledByDebugger: Boolean; 1573 FID: Integer; 1574 FName: String; 1575 FResumeHandled: Boolean; 1576 protected 1577 procedure AssignTo(Dest: TPersistent); override; 1578 procedure SetHandledByDebugger(const AValue: Boolean); virtual; 1579 procedure SetID(const AValue: Integer); virtual; 1580 procedure SetName(const AValue: String); virtual; 1581 procedure SetResumeHandled(const AValue: Boolean); virtual; 1582 public 1583 constructor Create(ACollection: TCollection); override; 1584 property ID: Integer read FID write SetID; 1585 property Name: String read FName write SetName; 1586 property HandledByDebugger: Boolean read FHandledByDebugger write SetHandledByDebugger; 1587 property ResumeHandled: Boolean read FResumeHandled write SetResumeHandled; 1588 end; 1589 TBaseSignalClass = class of TBaseSignal; 1590 1591 { TDBGSignal } 1592 1593 TDBGSignal = class(TBaseSignal) 1594 private 1595 function GetDebugger: TDebuggerIntf; 1596 protected 1597 property Debugger: TDebuggerIntf read GetDebugger; 1598 public 1599 end; 1600 TDBGSignalClass = class of TDBGSignal; 1601 1602 { TBaseSignals } 1603 TBaseSignals = class(TCollection) 1604 private 1605 protected 1606 public 1607 constructor Create(const AItemClass: TBaseSignalClass); 1608 procedure Reset; virtual; 1609 function Add(const AName: String; AID: Integer): TBaseSignal; 1610 function Find(const AName: String): TBaseSignal; 1611 end; 1612 1613 { TDBGSignals } 1614 1615 TDBGSignals = class(TBaseSignals) 1616 private 1617 FDebugger: TDebuggerIntf; // reference to our debugger 1618 function GetItem(const AIndex: Integer): TDBGSignal; 1619 procedure SetItem(const AIndex: Integer; const AValue: TDBGSignal); 1620 protected 1621 public 1622 constructor Create(const ADebugger: TDebuggerIntf; 1623 const ASignalClass: TDBGSignalClass); 1624 function Add(const AName: String; AID: Integer): TDBGSignal; 1625 function Find(const AName: String): TDBGSignal; 1626 public 1627 property Items[const AIndex: Integer]: TDBGSignal read GetItem 1628 write SetItem; default; 1629 end; 1630 1631 1632 1633 { TBaseException } 1634 TBaseException = class(TDelayedUdateItem) 1635 private 1636 procedure SetEnabled(AValue: Boolean); 1637 protected 1638 FEnabled: Boolean; 1639 FName: String; 1640 procedure AssignTo(Dest: TPersistent); override; 1641 procedure SetName(const AValue: String); virtual; 1642 public 1643 constructor Create(ACollection: TCollection); override; 1644 public 1645 property Name: String read FName write SetName; 1646 property Enabled: Boolean read FEnabled write SetEnabled; // ignored if enabled 1647 end; 1648 TBaseExceptionClass = class of TBaseException; 1649 1650 { TDBGException } 1651 TDBGException = class(TBaseException) 1652 private 1653 protected 1654 public 1655 end; 1656 TDBGExceptionClass = class of TDBGException; 1657 1658 { TBaseExceptions } 1659 TBaseExceptions = class(TCollection) 1660 private 1661 function GetItem(const AIndex: Integer): TBaseException; 1662 procedure SetItem(const AIndex: Integer; AValue: TBaseException); 1663 protected 1664 FIgnoreAll: Boolean; 1665 procedure AssignTo(Dest: TPersistent); override; 1666 procedure ClearExceptions; virtual; 1667 procedure SetIgnoreAll(const AValue: Boolean); virtual; 1668 public 1669 constructor Create(const AItemClass: TBaseExceptionClass); 1670 destructor Destroy; override; 1671 procedure Reset; virtual; 1672 function Add(const AName: String): TBaseException; 1673 function Find(const AName: String): TBaseException; 1674 property IgnoreAll: Boolean read FIgnoreAll write SetIgnoreAll; 1675 property Items[const AIndex: Integer]: TBaseException read GetItem 1676 write SetItem; default; 1677 end; 1678 1679 1680{%endregion ^^^^^ Signals / Exceptions ^^^^^ } 1681 1682(******************************************************************************) 1683(******************************************************************************) 1684(** **) 1685(** D E B U G G E R **) 1686(** **) 1687(******************************************************************************) 1688(******************************************************************************) 1689 1690 TDBGEventCategory = ( 1691 ecBreakpoint, // Breakpoint hit 1692 ecProcess, // Process start, process stop 1693 ecThread, // Thread creation, destruction, start, etc. 1694 ecModule, // Library load and unload 1695 ecOutput, // DebugOutput calls 1696 ecWindows, // Windows events 1697 ecDebugger); // debugger errors and warnings 1698 TDBGEventCategories = set of TDBGEventCategory; 1699 1700 TDBGEventType = ( 1701 etDefault, 1702 // ecBreakpoint category 1703 etBreakpointEvaluation, 1704 etBreakpointHit, 1705 etBreakpointMessage, 1706 etBreakpointStackDump, 1707 etExceptionRaised, 1708 // ecModule category 1709 etModuleLoad, 1710 etModuleUnload, 1711 // ecOutput category 1712 etOutputDebugString, 1713 // ecProcess category 1714 etProcessExit, 1715 etProcessStart, 1716 // ecThread category 1717 etThreadExit, 1718 etThreadStart, 1719 // ecWindows category 1720 etWindowsMessagePosted, 1721 etWindowsMessageSent 1722 ); 1723 1724 TDebugCompilerRequirement = (dcrNoExternalDbgInfo, dcrExternalDbgInfoOnly, dcrDwarfOnly); 1725 TDebugCompilerRequirements = set of TDebugCompilerRequirement; 1726 1727 TDBGFeedbackType = (ftInformation, ftWarning, ftError); 1728 TDBGFeedbackResult = (frOk, frStop); 1729 TDBGFeedbackResults = set of TDBGFeedbackResult; 1730 1731 TDBGEventNotify = procedure(Sender: TObject; 1732 const ACategory: TDBGEventCategory; 1733 const AEventType: TDBGEventType; 1734 const AText: String) of object; 1735 1736 TDebuggerStateChangedEvent = procedure(ADebugger: TDebuggerIntf; 1737 AOldState: TDBGState) of object; 1738 TDebuggerBreakPointHitEvent = procedure(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint; 1739 var ACanContinue: Boolean) of object; 1740 TDBGOutputEvent = procedure(Sender: TObject; const AText: String) of object; 1741 TDBGCurrentLineEvent = procedure(Sender: TObject; 1742 const ALocation: TDBGLocationRec) of object; 1743 TDBGExceptionEvent = procedure(Sender: TObject; const AExceptionType: TDBGExceptionType; 1744 const AExceptionClass: String; 1745 const AExceptionLocation: TDBGLocationRec; 1746 const AExceptionText: String; 1747 out AContinue: Boolean) of object; 1748 1749 TDBGFeedbackEvent = function(Sender: TObject; const AText, AInfo: String; 1750 AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults 1751 ): TDBGFeedbackResult of object; 1752 1753 TDBGEvaluateResultCallback = procedure(Sender: TObject; ASuccess: Boolean; ResultText: String; 1754 ResultDBGType: TDBGType) of object; 1755 1756 TDebuggerNotifyReason = (dnrDestroy); 1757 1758 { TDebuggerProperties } 1759 1760 TDebuggerProperties = class(TPersistent) 1761 private 1762 public 1763 constructor Create; virtual; 1764 procedure Assign({%H-}Source: TPersistent); override; 1765 published 1766 end; 1767 TDebuggerPropertiesClass= class of TDebuggerProperties; 1768 1769 1770 {$INTERFACES CORBA} // no ref counting needed 1771 1772 { TDebuggerEventLogInterface 1773 Methods for the EventLogger that a debugger may call 1774 } 1775 //TODO: remove TDebuggerIntf.OnEvent 1776 1777 TDebuggerEventLogInterface = interface 1778 procedure LogCustomEvent(const ACategory: TDBGEventCategory; 1779 const AEventType: TDBGEventType; const AText: String); 1780 procedure LogEventBreakPointHit(const ABreakpoint: TDBGBreakPoint; const ALocation: TDBGLocationRec); 1781 procedure LogEventWatchPointTriggered(const ABreakpoint: TDBGBreakPoint; 1782 const ALocation: TDBGLocationRec; const AOldWatchedVal, ANewWatchedVal: String); 1783 procedure LogEventWatchPointScope(const ABreakpoint: TDBGBreakPoint; 1784 const ALocation: TDBGLocationRec); 1785 end; 1786 1787 //TDebuggerActionInterface = interface 1788 // // prompt user 1789 //end; 1790 1791 { TDebuggerIntf } 1792 1793 TDebuggerIntf = class 1794 private 1795 FArguments: String; 1796 FBreakPoints: TDBGBreakPoints; 1797 FDebuggerEnvironment: TStrings; 1798 FCurEnvironment: TStrings; 1799 FDisassembler: TDBGDisassembler; 1800 FEnvironment: TStrings; 1801 FErrorStateInfo: String; 1802 FErrorStateMessage: String; 1803 FExceptions: TBaseExceptions; 1804 FExitCode: Integer; 1805 FExternalDebugger: String; 1806 FFileName: String; 1807 FIsInReset: Boolean; 1808 FLocals: TLocalsSupplier; 1809 FLineInfo: TDBGLineInfo; 1810 //FUnitInfoProvider, FInternalUnitInfoProvider: TDebuggerUnitInfoProvider; 1811 FOnBeforeState: TDebuggerStateChangedEvent; 1812 FOnConsoleOutput: TDBGOutputEvent; 1813 FOnFeedback: TDBGFeedbackEvent; 1814 FOnIdle: TNotifyEvent; 1815 FRegisters: TRegisterSupplier; 1816 FShowConsole: Boolean; 1817 FSignals: TDBGSignals; 1818 FState: TDBGState; 1819 FCallStack: TCallStackSupplier; 1820 FWatches: TWatchesSupplier; 1821 FThreads: TThreadsSupplier; 1822 FEventLogHandler: TDebuggerEventLogInterface; 1823 FOnCurrent: TDBGCurrentLineEvent; 1824 FOnException: TDBGExceptionEvent; 1825 FOnOutput: TDBGOutputEvent; 1826 FOnDbgOutput: TDBGOutputEvent; 1827 FOnDbgEvent: TDBGEventNotify; 1828 FOnState: TDebuggerStateChangedEvent; 1829 FOnBreakPointHit: TDebuggerBreakPointHitEvent; 1830 FWorkingDir: String; 1831 FDestroyNotificationList: array [TDebuggerNotifyReason] of TMethodList; 1832 FReleaseLock: Integer; 1833 procedure DebuggerEnvironmentChanged(Sender: TObject); 1834 procedure EnvironmentChanged(Sender: TObject); 1835 //function GetUnitInfoProvider: TDebuggerUnitInfoProvider; 1836 function GetState: TDBGState; 1837 function ReqCmd(const ACommand: TDBGCommand; 1838 const AParams: array of const): Boolean; overload; 1839 function ReqCmd(const ACommand: TDBGCommand; 1840 const AParams: array of const; 1841 const ACallback: TMethod): Boolean; 1842 procedure SetDebuggerEnvironment (const AValue: TStrings ); overload; 1843 procedure SetEnvironment(const AValue: TStrings); 1844 procedure SetFileName(const AValue: String); 1845 protected 1846 procedure ResetStateToIdle; virtual; 1847 function CreateBreakPoints: TDBGBreakPoints; virtual; 1848 function CreateLocals: TLocalsSupplier; virtual; 1849 function CreateLineInfo: TDBGLineInfo; virtual; 1850 function CreateRegisters: TRegisterSupplier; virtual; 1851 function CreateCallStack: TCallStackSupplier; virtual; 1852 function CreateDisassembler: TDBGDisassembler; virtual; 1853 function CreateWatches: TWatchesSupplier; virtual; 1854 function CreateThreads: TThreadsSupplier; virtual; 1855 function CreateSignals: TDBGSignals; virtual; 1856 procedure DoCurrent(const ALocation: TDBGLocationRec); 1857 procedure DoDbgOutput(const AText: String); 1858 procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String); 1859 deprecated 'swich to EventLogHandler'; 1860 procedure DoException(const AExceptionType: TDBGExceptionType; 1861 const AExceptionClass: String; 1862 const AExceptionLocation: TDBGLocationRec; 1863 const AExceptionText: String; 1864 out AContinue: Boolean); 1865 procedure DoOutput(const AText: String); 1866 procedure DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); 1867 procedure DoBeforeState(const OldState: TDBGState); virtual; 1868 procedure DoState(const OldState: TDBGState); virtual; 1869 function ChangeFileName: Boolean; virtual; 1870 function GetCommands: TDBGCommands; virtual; 1871 function GetSupportedCommands: TDBGCommands; virtual; 1872 function GetTargetWidth: Byte; virtual; 1873 function GetWaiting: Boolean; virtual; 1874 function GetIsIdle: Boolean; virtual; 1875 function RequestCommand(const ACommand: TDBGCommand; 1876 const AParams: array of const; 1877 const ACallback: TMethod): Boolean; 1878 virtual; abstract; // True if succesful 1879 procedure SetExitCode(const AValue: Integer); 1880 procedure SetState(const AValue: TDBGState); 1881 procedure SetErrorState(const AMsg: String; const AInfo: String = ''); 1882 procedure DoRelease; virtual; 1883 // prevent destruction while nested in any call 1884 procedure LockRelease; virtual; 1885 procedure UnlockRelease; virtual; 1886 function GetPseudoTerminal: TPseudoTerminal; virtual; 1887 public 1888 class function Caption: String; virtual; // The name of the debugger as shown in the debuggeroptions 1889 class function ExePaths: String; virtual; // The default locations of the exe 1890 class function HasExePath: boolean; virtual; deprecated; // use NeedsExePath instead 1891 class function NeedsExePath: boolean; virtual; // If the debugger needs to have an exe path 1892 class function RequiredCompilerOpts(ATargetCPU, ATargetOS: String): TDebugCompilerRequirements; virtual; 1893 1894 // debugger properties 1895 class function CreateProperties: TDebuggerProperties; virtual; // Creates debuggerproperties 1896 class function GetProperties: TDebuggerProperties; // Get the current properties 1897 class procedure SetProperties(const AProperties: TDebuggerProperties); // Set the current properties 1898 1899 (* TODO: 1900 This method is a workaround for http://bugs.freepascal.org/view.php?id=21834 1901 See main.pp 12188 function TMainIDE.DoInitProjectRun: TModalResult; 1902 See debugmanager function TDebugManager.InitDebugger: Boolean; 1903 Checks could be performed in SetFileName, invalidating debuggerstate 1904 Errors should also be reported by debugger 1905 *) 1906 class function RequiresLocalExecutable: Boolean; virtual; 1907 procedure TestCmd(const ACommand: String); virtual;// For internal debugging purposes 1908 public 1909 constructor Create(const AExternalDebugger: String); virtual; 1910 destructor Destroy; override; 1911 1912 procedure Init; virtual; // Initializes the debugger 1913 procedure Done; virtual; // Kills the debugger 1914 procedure Release; // Free/Destroy self 1915 procedure Run; // Starts / continues debugging 1916 procedure Pause; // Stops running 1917 procedure Stop; // quit debugging 1918 procedure StepOver; 1919 procedure StepInto; 1920 procedure StepOverInstr; 1921 procedure StepIntoInstr; 1922 procedure StepOut; 1923 procedure RunTo(const ASource: String; const ALine: Integer); // Executes til a certain point 1924 procedure JumpTo(const ASource: String; const ALine: Integer); // No execute, only set exec point 1925 procedure Attach(AProcessID: String); 1926 procedure Detach; 1927 procedure SendConsoleInput(AText: String); 1928 function Evaluate(const AExpression: String; ACallback: TDBGEvaluateResultCallback; 1929 EvalFlags: TDBGEvaluateFlags = []): Boolean; // Evaluates the given expression, returns true if valid 1930 function GetProcessList({%H-}AList: TRunningProcessInfoList): boolean; virtual; 1931 function Modify(const AExpression, AValue: String): Boolean; // Modifies the given expression, returns true if valid 1932 function Disassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr; 1933 out ADump, AStatement, AFile: String; out ALine: Integer): Boolean; deprecated; 1934 function GetLocation: TDBGLocationRec; virtual; 1935 procedure LockCommandProcessing; virtual; 1936 procedure UnLockCommandProcessing; virtual; 1937 procedure BeginReset; virtual; 1938 function NeedReset: Boolean; virtual; 1939 property IsInReset: Boolean read FIsInReset; 1940 procedure AddNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); 1941 procedure RemoveNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); 1942 public 1943 property Arguments: String read FArguments write FArguments; // Arguments feed to the program 1944 property BreakPoints: TDBGBreakPoints read FBreakPoints; // list of all breakpoints 1945 property CallStack: TCallStackSupplier read FCallStack; 1946 property Disassembler: TDBGDisassembler read FDisassembler; 1947 property Commands: TDBGCommands read GetCommands; // All current available commands of the debugger 1948 property DebuggerEnvironment: TStrings read FDebuggerEnvironment 1949 write SetDebuggerEnvironment; // The environment passed to the debugger process 1950 property Environment: TStrings read FEnvironment write SetEnvironment; // The environment passed to the debuggee 1951 property Exceptions: TBaseExceptions read FExceptions write FExceptions; // A list of exceptions we should ignore 1952 property ExitCode: Integer read FExitCode; 1953 property ExternalDebugger: String read FExternalDebugger; // The name of the debugger executable 1954 property FileName: String read FFileName write SetFileName; // The name of the exe to be debugged 1955 property Locals: TLocalsSupplier read FLocals; // list of all localvars etc 1956 property LineInfo: TDBGLineInfo read FLineInfo; // list of all source LineInfo 1957 property Registers: TRegisterSupplier read FRegisters; // list of all registers 1958 property Signals: TDBGSignals read FSignals; // A list of actions for signals we know 1959 property ShowConsole: Boolean read FShowConsole write FShowConsole; // Indicates if the debugger should create a console for the debuggee 1960 property PseudoTerminal: TPseudoTerminal read GetPseudoTerminal; experimental; // 'may be replaced with a more general API'; 1961 property State: TDBGState read FState; // The current state of the debugger 1962 property SupportedCommands: TDBGCommands read GetSupportedCommands; // All available commands of the debugger 1963 property TargetWidth: Byte read GetTargetWidth; // Currently only 32 or 64 1964 //property Waiting: Boolean read GetWaiting; // Set when the debugger is wating for a command to complete 1965 property Watches: TWatchesSupplier read FWatches; // list of all watches etc 1966 property Threads: TThreadsSupplier read FThreads; 1967 property WorkingDir: String read FWorkingDir write FWorkingDir; // The working dir of the exe being debugged 1968 property IsIdle: Boolean read GetIsIdle; // Nothing queued 1969 property ErrorStateMessage: String read FErrorStateMessage; 1970 property ErrorStateInfo: String read FErrorStateInfo; 1971 //property UnitInfoProvider: TDebuggerUnitInfoProvider // Provided by DebugBoss, to map files to packages or project 1972 // read GetUnitInfoProvider write FUnitInfoProvider; 1973 // Events 1974 property EventLogHandler: TDebuggerEventLogInterface read FEventLogHandler write FEventLogHandler; 1975 property OnCurrent: TDBGCurrentLineEvent read FOnCurrent write FOnCurrent; // Passes info about the current line being debugged 1976 property OnDbgOutput: TDBGOutputEvent read FOnDbgOutput write FOnDbgOutput; // Passes all debuggeroutput 1977 property OnDbgEvent: TDBGEventNotify read FOnDbgEvent write FOnDbgEvent; // Passes recognized debugger events, like library load or unload 1978 deprecated 'swich to EventLogHandler'; 1979 property OnException: TDBGExceptionEvent read FOnException write FOnException; // Fires when the debugger received an ecxeption 1980 property OnOutput: TDBGOutputEvent read FOnOutput write FOnOutput; // Passes all output of the debugged target 1981 property OnBeforeState: TDebuggerStateChangedEvent read FOnBeforeState write FOnBeforeState; // Fires when the current state of the debugger changes 1982 property OnState: TDebuggerStateChangedEvent read FOnState write FOnState; // Fires when the current state of the debugger changes 1983 property OnBreakPointHit: TDebuggerBreakPointHitEvent read FOnBreakPointHit write FOnBreakPointHit; // Fires when the program is paused at a breakpoint 1984 property OnConsoleOutput: TDBGOutputEvent read FOnConsoleOutput write FOnConsoleOutput; // Passes Application Console Output 1985 property OnFeedback: TDBGFeedbackEvent read FOnFeedback write FOnFeedback; 1986 property OnIdle: TNotifyEvent read FOnIdle write FOnIdle; // Called if all outstanding requests are processed (queue empty) 1987 end; 1988 TDebuggerClass = class of TDebuggerIntf; 1989 1990 TBaseDebugManagerIntf = class(TComponent) 1991 public type 1992 TStringFunction = function(const aValue: string): string; 1993 private 1994 FValueFormatterList: TStringList; 1995 1996 function ValueFormatterKey(const aSymbolKind: TDBGSymbolKind; 1997 const aTypeName: string): string; 1998 protected 1999 function GetDebuggerClass(const AIndex: Integer): TDebuggerClass; 2000 function FindDebuggerClass(const Astring: String): TDebuggerClass; 2001 public 2002 function DebuggerCount: Integer; 2003 2004 procedure RegisterValueFormatter(const aSymbolKind: TDBGSymbolKind; 2005 const aTypeName: string; const aFunc: TStringFunction); 2006 function FormatValue(const aSymbolKind: TDBGSymbolKind; 2007 const aTypeName, aValue: string): string; 2008 function FormatValue(const aDBGType: TDBGType; 2009 const aValue: string): string; 2010 public 2011 constructor Create(AOwner: TComponent); override; 2012 destructor Destroy; override; 2013 end; 2014 2015procedure RegisterDebugger(const ADebuggerClass: TDebuggerClass); 2016function MinDbgPtr(a, b: TDBGPtr): TDBGPtr;inline; overload; 2017 2018function dbgs(AState: TDBGState): String; overload; 2019function dbgs(ADataState: TDebuggerDataState): String; overload; 2020function dbgs(AKind: TDBGSymbolKind): String; overload; 2021function dbgs(AnAttribute: TDBGSymbolAttribute): String; overload; 2022function dbgs(AnAttributes: TDBGSymbolAttributes): String; overload; 2023function dbgs(ADisassRange: TDBGDisassemblerEntryRange): String; overload; 2024function dbgs(const AnAddr: TDisassemblerAddress): string; overload; 2025function dbgs(ACategory: TDBGEventCategory): String; overload; 2026function dbgs(AFlag: TDBGEvaluateFlag): String; overload; 2027function dbgs(AFlags: TDBGEvaluateFlags): String; overload; 2028function dbgs(AName: TDBGCommand): String; overload; 2029 2030var 2031 DbgStateChangeCounter: Integer = 0; // workaround for state changes during TWatchValue.GetValue 2032 DebugBossManager: TBaseDebugManagerIntf; 2033 2034implementation 2035 2036var 2037 DBG_STATE, DBG_EVENTS, DBG_STATE_EVENT, DBG_DATA_MONITORS, 2038 DBG_VERBOSE, DBG_WARNINGS, DBG_DISASSEMBLER: PLazLoggerLogGroup; 2039 2040const 2041 COMMANDMAP: array[TDBGState] of TDBGCommands = ( 2042 {dsNone } [], 2043 {dsIdle } [dcEnvironment], 2044 {dsStop } [dcRun, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, 2045 dcAttach, dcBreak, dcWatch, dcEvaluate, dcEnvironment, 2046 dcSendConsoleInput], 2047 {dsPause} [dcRun, dcStop, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, 2048 dcStepOut, dcRunTo, dcJumpto, dcDetach, dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, 2049 dcEnvironment, dcSetStackFrame, dcDisassemble, dcSendConsoleInput {, dcSendSignal}], 2050 {dsInternalPause} // same as run, so not really used 2051 [dcStop, dcBreak, dcWatch, dcEnvironment, dcSendConsoleInput{, dcSendSignal}], 2052 {dsInit } [], 2053 {dsRun } [dcPause, dcStop, dcDetach, dcBreak, dcWatch, dcEnvironment, dcSendConsoleInput{, dcSendSignal}], 2054 {dsError} [dcStop], 2055 {dsDestroying} [] 2056 ); 2057 2058var 2059 MDebuggerPropertiesList: TStringlist = nil; 2060 MDebuggerClasses: TStringList; 2061 2062procedure RegisterDebugger(const ADebuggerClass: TDebuggerClass); 2063begin 2064 MDebuggerClasses.AddObject(ADebuggerClass.ClassName, TObject(Pointer(ADebuggerClass))); 2065end; 2066 2067function MinDbgPtr(a, b: TDBGPtr): TDBGPtr; 2068begin 2069 if a < b then 2070 Result := a 2071 else 2072 Result := b; 2073end; 2074 2075procedure DoFinalization; 2076var 2077 n: Integer; 2078begin 2079 if MDebuggerPropertiesList <> nil 2080 then begin 2081 for n := 0 to MDebuggerPropertiesList.Count - 1 do 2082 MDebuggerPropertiesList.Objects[n].Free; 2083 FreeAndNil(MDebuggerPropertiesList); 2084 end; 2085end; 2086 2087function dbgs(AState: TDBGState): String; overload; 2088begin 2089 Result := ''; 2090 WriteStr(Result, AState); 2091end; 2092 2093function dbgs(ADataState: TDebuggerDataState): String; 2094begin 2095 writestr(Result{%H-}, ADataState); 2096end; 2097 2098function dbgs(AKind: TDBGSymbolKind): String; 2099begin 2100 writestr(Result{%H-}, AKind); 2101end; 2102 2103function dbgs(AnAttribute: TDBGSymbolAttribute): String; 2104begin 2105 writestr(Result{%H-}, AnAttribute); 2106end; 2107 2108function dbgs(AnAttributes: TDBGSymbolAttributes): String; 2109var 2110 i: TDBGSymbolAttribute; 2111begin 2112 Result:=''; 2113 for i := low(TDBGSymbolAttributes) to high(TDBGSymbolAttributes) do 2114 if i in AnAttributes then begin 2115 if Result <> '' then Result := Result + ', '; 2116 Result := Result + dbgs(i); 2117 end; 2118 if Result <> '' then Result := '[' + Result + ']'; 2119end; 2120 2121function dbgs(ACategory: TDBGEventCategory): String; 2122begin 2123 writestr(Result{%H-}, ACategory); 2124end; 2125 2126function dbgs(AFlag: TDBGEvaluateFlag): String; 2127begin 2128 Result := ''; 2129 WriteStr(Result, AFlag); 2130end; 2131 2132function dbgs(AFlags: TDBGEvaluateFlags): String; 2133var 2134 i: TDBGEvaluateFlag; 2135begin 2136 Result:=''; 2137 for i := low(TDBGEvaluateFlags) to high(TDBGEvaluateFlags) do 2138 if i in AFlags then begin 2139 if Result <> '' then Result := Result + ', '; 2140 Result := Result + dbgs(i); 2141 end; 2142 Result := '[' + Result + ']'; 2143end; 2144 2145function dbgs(AName: TDBGCommand): String; 2146begin 2147 Result := ''; 2148 WriteStr(Result, AName); 2149end; 2150 2151function dbgs(ADisassRange: TDBGDisassemblerEntryRange): String; overload; 2152var 2153 fo: Integer; 2154begin 2155 if (ADisassRange = nil) 2156 then begin 2157 Result := 'Range(nil)' 2158 end 2159 else begin 2160 if (ADisassRange.Count > 0) 2161 then fo := ADisassRange.EntriesPtr[0]^.Offset 2162 else fo := 0; 2163 {$PUSH}{$RANGECHECKS OFF} 2164 with ADisassRange do 2165 Result := Format('Range(%u)=[[ Cnt=%d, Capac=%d, [0].Addr=%u, RFirst=%u, [Cnt].Addr=%u, RLast=%u, REnd=%u, FirstOfs=%d ]]', 2166 [PtrUInt(ADisassRange), Count, Capacity, FirstAddr, RangeStartAddr, LastAddr, RangeEndAddr, LastEntryEndAddr, fo]); 2167 {$POP} 2168 end; 2169end; 2170 2171function Dbgs(const AnAddr: TDisassemblerAddress): string; 2172const 2173 ValidityName: array [TDisassemblerAddressValidity] of string = 2174 ('FoundFunction', 'FoundRange', 'FoundStatemnet', 'Guessed', 'ExternRequest', 'Padded'); 2175begin 2176 Result := Format('[[ Value=%u, Guessed=%u, Offset=%d, Validity=%s ]]', 2177 [AnAddr.Value, AnAddr.GuessedValue, AnAddr.Offset, ValidityName[AnAddr.Validity]]); 2178end; 2179 2180{ TDBGDisassemblerRangeExtender } 2181 2182function TDBGDisassemblerRangeExtender.InitAddress(AValue: TDBGPtr; 2183 AValidity: TDisassemblerAddressValidity; AnOffset: Integer): TDisassemblerAddress; 2184begin 2185 Result.Value := AValue; 2186 Result.GuessedValue := AValue;; 2187 Result.Offset := AnOffset; 2188 Result.Validity := AValidity; 2189end; 2190 2191constructor TDBGDisassemblerRangeExtender.Create(AnEntryRangeMap: TDBGDisassemblerEntryMap); 2192begin 2193 FEntryRangeMap := AnEntryRangeMap; 2194 FRangeIterator:= TDBGDisassemblerEntryMapIterator.Create(FEntryRangeMap); 2195end; 2196 2197destructor TDBGDisassemblerRangeExtender.Destroy; 2198begin 2199 FRangeIterator.Free; 2200 inherited; 2201end; 2202 2203function TDBGDisassemblerRangeExtender.CheckIfCancelled: boolean; 2204begin 2205 result := assigned(FOnCheckCancel) and FOnCheckCancel(); 2206end; 2207 2208// Set Value, based on GuessedValue 2209function TDBGDisassemblerRangeExtender.AdjustToRangeOrKnowFunctionStart(var AStartAddr: TDisassemblerAddress; 2210 ARangeBefore: TDBGDisassemblerEntryRange): Boolean; 2211begin 2212 Result := False; 2213 AStartAddr.Offset := -1; 2214 AStartAddr.Validity := avGuessed; 2215 if OnAdjustToKnowFunctionStart(AStartAddr) 2216 then begin 2217 // funtion found, check for range 2218 if (ARangeBefore <> nil) and (ARangeBefore.LastAddr > AStartAddr.Value) 2219 and (ARangeBefore.Count > DAssRangeOverFuncTreshold) 2220 and (ARangeBefore.EntriesPtr[ARangeBefore.Count - 1]^.Offset > DAssRangeOverFuncTreshold * DAssBytesPerCommandAvg) 2221 then begin 2222 // got a big overlap, don't redo the whole function 2223 debugln(DBG_DISASSEMBLER, ['INFO: Restarting inside previous range for known function-start=', Dbgs(AStartAddr),' and ARangeBefore=', dbgs(ARangeBefore)]); 2224 // redo one statement 2225 {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur 2226 AStartAddr.Value := ARangeBefore.EntriesPtr[ARangeBefore.Count - 1]^.Addr; 2227 AStartAddr.Offset := ARangeBefore.EntriesPtr[ARangeBefore.Count - 1]^.Offset; 2228 AStartAddr.Validity := avFoundRange; 2229 //AStartAddr - ARangeBefore.EntriesPtr[ARangeBefore.Count - DAssRangeOverFuncTreshold]^.Addr ; 2230 {$POP} 2231 end 2232 end 2233 else begin 2234 debugln(DBG_DISASSEMBLER, ['INFO: No known function-start for ', Dbgs(AStartAddr),' ARangeBefore=', dbgs(ARangeBefore)]); 2235 // no function found // check distance to previous range 2236 // The distance of range before has been checked by the caller 2237 if (ARangeBefore <> nil) 2238 then begin 2239 {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur 2240 AStartAddr.Value := ARangeBefore.EntriesPtr[ARangeBefore.Count - 1]^.Addr; 2241 AStartAddr.Offset := ARangeBefore.EntriesPtr[ARangeBefore.Count - 1]^.Offset; 2242 AStartAddr.Validity := avFoundRange; 2243 {$POP} 2244 end 2245 else begin 2246 AStartAddr.Value := AStartAddr.GuessedValue; 2247 AStartAddr.Offset := -1; 2248 AStartAddr.Validity := avGuessed; 2249 end; 2250 end; 2251end; 2252 2253function TDBGDisassemblerRangeExtender.DisassembleRange(ALinesBefore, 2254 ALinesAfter: integer; AStartAddr: TDBGPtr; AnEndAddr: TDBGPtr): boolean; 2255var 2256 TryStartAt, TryEndAt: TDisassemblerAddress; 2257 TmpAddr: TDBGPtr; 2258 GotCnt, LastGotCnt: Integer; 2259 RngBefore, RngAfter: TDBGDisassemblerEntryRange; 2260begin 2261 result := true; 2262 (* Try to find the boundaries for the unknown range containing FStartAddr 2263 If FStartAddr already has known disassembler data, then this will return 2264 the boundaries of the 1ast unknown section after FStartAddr 2265 *) 2266 // Guess the maximum Addr-Range which needs to be disassembled 2267 TryStartAt := InitAddress(AStartAddr, avExternRequest, -1); 2268 // Find the begin of the function at TryStartAt 2269 // or the rng before (if not to far back) 2270 2271 RngBefore := FRangeIterator.GetRangeForAddr(AStartAddr, True); 2272 {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur 2273 if (RngBefore <> nil) 2274 and (TryStartAt.Value > RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr) 2275 and (TryStartAt.Value - RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr > ALinesBefore * DAssBytesPerCommandAvg) 2276 then RngBefore := nil; 2277 {$POP} 2278 TmpAddr := AStartAddr - Min(ALinesBefore * DAssBytesPerCommandAvg, DAssMaxRangeSize); 2279 TryStartAt.GuessedValue := TmpAddr; 2280 AdjustToRangeOrKnowFunctionStart(TryStartAt, RngBefore); 2281 // check max size 2282 if (TryStartAt.Value < AStartAddr - MinDbgPtr(AStartAddr, DAssMaxRangeSize)) 2283 then begin 2284 DebugLn(DBG_DISASSEMBLER, ['INFO: Limit Range for Disass: FStartAddr=', AStartAddr, ' TryStartAt.Value=', TryStartAt.Value ]); 2285 TryStartAt := InitAddress(TmpAddr, avGuessed); 2286 end; 2287 2288 // Guess Maximum, will adjust later 2289 if TryStartAt.Value > AnEndAddr then begin 2290 if (RngBefore <> nil) then begin 2291 GotCnt := RngBefore.IndexOfAddr(AnEndAddr); 2292 LastGotCnt := RngBefore.IndexOfAddr(TryStartAt.Value); 2293 if (GotCnt >= 0) and (LastGotCnt >= 0) and (LastGotCnt > GotCnt) then 2294 ALinesAfter := Max(ALinesAfter - (LastGotCnt - GotCnt), 1); 2295 end; 2296 AnEndAddr := TryStartAt.Value; // WARNING: modifying FEndAddr 2297 end; 2298 2299 TryEndAt := InitAddress(AnEndAddr + ALinesAfter * DAssBytesPerCommandAvg, avGuessed); 2300 2301 // Read as many unknown ranges, until LinesAfter is met 2302 GotCnt := -1; 2303 while(True) 2304 do begin 2305 // check if we need any LinesAfter 2306 if CheckIfCancelled then break; 2307 LastGotCnt:= GotCnt; 2308 GotCnt := 0; 2309 TmpAddr := AnEndAddr; 2310 if TryStartAt.Value > AnEndAddr 2311 then 2312 TmpAddr := TryStartAt.Value; 2313 if RngBefore <> nil 2314 then begin 2315 TmpAddr := RngBefore.RangeEndAddr; 2316 if RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr > TmpAddr 2317 then TmpAddr := RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr; 2318 GotCnt := RngBefore.IndexOfAddrWithOffs(AnEndAddr); 2319 if GotCnt >= 0 then begin 2320 GotCnt := RngBefore.Count - 1 - GotCnt; // the amount of LinesAfter, that are already known 2321 if (GotCnt >= ALinesAfter) 2322 then break; 2323 // adjust end address 2324 TryEndAt := InitAddress(RngBefore.RangeEndAddr + (ALinesAfter-GotCnt) * DAssBytesPerCommandAvg, avGuessed); 2325 end 2326 else GotCnt := 0; 2327 end; 2328 if LastGotCnt >= GotCnt 2329 then begin 2330 debugln(['Disassembler: *** Failure to get any more lines while scanning forward LastGotCnt=',LastGotCnt, ' now GotCnt=',GotCnt, ' Requested=',ALinesAfter]); 2331 break; 2332 end; 2333 2334 if CheckIfCancelled then break; 2335 RngAfter := FRangeIterator.NextRange; 2336 // adjust TryEndAt 2337 if (RngAfter <> nil) and (TryEndAt.Value >= RngAfter.RangeStartAddr) 2338 then begin 2339 TryEndAt.Value := RngAfter.RangeStartAddr; 2340 TryEndAt.Validity := avFoundRange; 2341 end; 2342 2343 if CheckIfCancelled then break; 2344 // Try to disassemble the range 2345 if not OnDoDisassembleRange(FEntryRangeMap, TryStartAt, TryEndAt, TmpAddr, ALinesAfter-GotCnt) 2346 then begin 2347 // disassemble failed 2348 debugln(['ERROR: Failed to disassemble from ', Dbgs(TryStartAt),' to ', Dbgs(TryEndAt)]); 2349 break; 2350 end; 2351 2352 // prepare the next range 2353 RngBefore := FRangeIterator.GetRangeForAddr(AStartAddr, True); 2354 if (RngBefore = nil) 2355 then begin 2356 debugln(['INTERNAL ERROR: (linesafter) Missing the data, that was just disassembled: from ', Dbgs(TryStartAt),' to ', Dbgs(TryEndAt)]); 2357 break; 2358 end; 2359 2360 TryStartAt.Value := RngBefore.RangeEndAddr; 2361 TryStartAt.Validity := avFoundRange; 2362 TryEndAt := InitAddress(AnEndAddr + ALinesAfter * DAssBytesPerCommandAvg, avGuessed); 2363 end; 2364 2365 // Find LinesBefore 2366 RngAfter := FRangeIterator.GetRangeForAddr(AStartAddr, True); 2367 GotCnt := -1; 2368 while(True) 2369 do begin 2370 if CheckIfCancelled then break; 2371 LastGotCnt:= GotCnt; 2372 if (RngAfter = nil) 2373 then begin 2374 debugln(['INTERNAL ERROR: (linesbefore) Missing the data, that was disassembled: from ', Dbgs(TryStartAt),' to ', Dbgs(TryEndAt)]); 2375 break; 2376 end; 2377 2378 GotCnt := RngAfter.IndexOfAddrWithOffs(AStartAddr); // already known before 2379 if GotCnt >= ALinesBefore 2380 then break; 2381 if LastGotCnt >= GotCnt 2382 then begin 2383 debugln(['Disassembler: *** Failure to get any more lines while scanning backward LastGotCnt=',LastGotCnt, ' now GotCnt=',GotCnt, ' Requested=',ALinesBefore]); 2384 break; 2385 end; 2386 2387 TryEndAt := InitAddress(RngAfter.RangeStartAddr, avFoundRange); 2388 TmpAddr := TryEndAt.Value - Min((ALinesBefore - GotCnt) * DAssBytesPerCommandAvg, DAssMaxRangeSize); 2389 TryStartAt := InitAddress(TryEndAt.Value - 1, avGuessed); 2390 TryStartAt.GuessedValue := TmpAddr; 2391 // and adjust 2392 RngBefore := FRangeIterator.PreviousRange; 2393 {$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur 2394 if (RngBefore <> nil) 2395 and (TryStartAt.Value > RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr) 2396 and (TryStartAt.Value - RngBefore.EntriesPtr[RngBefore.Count - 1]^.Addr > (ALinesBefore - GotCnt) * DAssBytesPerCommandAvg) 2397 then RngBefore := nil; 2398 {$POP} 2399 AdjustToRangeOrKnowFunctionStart(TryStartAt, RngBefore); 2400 if (TryStartAt.Value < TryEndAt.Value - MinDbgPtr(TryEndAt.Value, DAssMaxRangeSize)) 2401 then begin 2402 DebugLn(DBG_DISASSEMBLER, ['INFO: Limit Range for Disass: TryEndAt.Value=', TryEndAt.Value, ' TryStartAt.Value=', TryStartAt.Value ]); 2403 TryStartAt := InitAddress(TmpAddr, avGuessed); 2404 end; 2405 2406 if CheckIfCancelled then break; 2407 // Try to disassemble the range 2408 if not OnDoDisassembleRange(FEntryRangeMap, TryStartAt, TryEndAt, 0, -1) 2409 then begin 2410 // disassemble failed 2411 debugln(['ERROR: Failed to disassemble from ', Dbgs(TryStartAt),' to ', Dbgs(TryEndAt)]); 2412 break; 2413 end; 2414 2415 RngAfter := FRangeIterator.GetRangeForAddr(AStartAddr, True); 2416 end; 2417end; 2418 2419{ TThreadEntry } 2420 2421procedure TThreadEntry.SetThreadState(AValue: String); 2422begin 2423 if FThreadState = AValue then Exit; 2424 FThreadState := AValue; 2425end; 2426 2427function TThreadEntry.CreateStackEntry: TCallStackEntry; 2428begin 2429 Result := TCallStackEntry.Create; 2430end; 2431 2432constructor TThreadEntry.Create; 2433begin 2434 FTopFrame := CreateStackEntry; 2435 inherited Create; 2436end; 2437 2438constructor TThreadEntry.Create(const AnAdress: TDbgPtr; const AnArguments: TStrings; 2439 const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; 2440 const AThreadId: Integer; const AThreadName: String; const AThreadState: String; 2441 AState: TDebuggerDataState); 2442begin 2443 Create; 2444 TopFrame.Init(AnAdress, AnArguments, AFunctionName, FileName, FullName, ALine, AState); 2445 FThreadId := AThreadId; 2446 FThreadName := AThreadName; 2447 FThreadState := AThreadState; 2448end; 2449 2450function TThreadEntry.CreateCopy: TThreadEntry; 2451begin 2452 Result := TThreadEntry.Create; 2453 Result.Assign(Self); 2454end; 2455 2456destructor TThreadEntry.Destroy; 2457begin 2458 inherited Destroy; 2459 FreeAndNil(FTopFrame); 2460end; 2461 2462procedure TThreadEntry.Assign(AnOther: TThreadEntry); 2463begin 2464 FTopFrame.Free; 2465 FTopFrame := AnOther.TopFrame.CreateCopy; 2466 FThreadId := AnOther.FThreadId; 2467 FThreadName := AnOther.FThreadName; 2468 FThreadState := AnOther.FThreadState; 2469end; 2470 2471{ TThreads } 2472 2473function TThreads.GetEntry(const AnIndex: Integer): TThreadEntry; 2474begin 2475 if (AnIndex < 0) or (AnIndex >= Count) then exit(nil); 2476 Result := TThreadEntry(FList[AnIndex]); 2477end; 2478 2479function TThreads.GetEntryById(const AnID: Integer): TThreadEntry; 2480var 2481 i: Integer; 2482begin 2483 i := Count - 1; 2484 while i >= 0 do begin 2485 Result := Entries[i]; 2486 if Result.ThreadId = AnID then 2487 exit; 2488 dec(i); 2489 end; 2490 Result := nil; 2491end; 2492 2493procedure TThreads.SetCurrentThreadId(AValue: Integer); 2494begin 2495 if FCurrentThreadId = AValue then exit; 2496 FCurrentThreadId := AValue; 2497end; 2498 2499constructor TThreads.Create; 2500begin 2501 FList := TList.Create; 2502end; 2503 2504destructor TThreads.Destroy; 2505begin 2506 Clear; 2507 FreeAndNil(FList); 2508 inherited Destroy; 2509end; 2510 2511procedure TThreads.Assign(AnOther: TThreads); 2512var 2513 i: Integer; 2514begin 2515 Clear; 2516 FCurrentThreadId := AnOther.FCurrentThreadId; 2517 for i := 0 to AnOther.FList.Count-1 do 2518 FList.Add(TThreadEntry(AnOther.FList[i]).CreateCopy); 2519end; 2520 2521function TThreads.Count: Integer; 2522begin 2523 Result := FList.Count; 2524end; 2525 2526procedure TThreads.Clear; 2527begin 2528 while FList.Count > 0 do begin 2529 TThreadEntry(Flist[0]).Free; 2530 FList.Delete(0); 2531 end; 2532end; 2533 2534procedure TThreads.Add(AThread: TThreadEntry); 2535begin 2536 FList.Add(AThread.CreateCopy); 2537 if FList.Count = 1 then 2538 FCurrentThreadId := AThread.ThreadId; // TODO: this should never be needed? 2539end; 2540 2541procedure TThreads.Remove(AThread: TThreadEntry); 2542begin 2543 FList.Remove(AThread); 2544 if FCurrentThreadId = AThread.ThreadId then begin 2545 if FList.Count > 0 then 2546 FCurrentThreadId := Entries[0].ThreadId 2547 else 2548 FCurrentThreadId := 0; 2549 end; 2550 AThread.Free; 2551end; 2552 2553function TThreads.CreateEntry(const AnAdress: TDbgPtr; const AnArguments: TStrings; 2554 const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; 2555 const AThreadId: Integer; const AThreadName: String; const AThreadState: String; 2556 AState: TDebuggerDataState): TThreadEntry; 2557begin 2558 Result := TThreadEntry.Create(AnAdress, AnArguments, AFunctionName, FileName, 2559 FullName, ALine, AThreadId, AThreadName, AThreadState, AState); 2560end; 2561 2562procedure TThreads.SetValidity(AValidity: TDebuggerDataState); 2563begin 2564 // 2565end; 2566 2567{ TThreadsMonitor } 2568 2569function TThreadsMonitor.GetSupplier: TThreadsSupplier; 2570begin 2571 Result := TThreadsSupplier(inherited Supplier); 2572end; 2573 2574procedure TThreadsMonitor.SetSupplier(AValue: TThreadsSupplier); 2575begin 2576 inherited Supplier := AValue; 2577end; 2578 2579function TThreadsMonitor.CreateThreads: TThreads; 2580begin 2581 Result := TThreads.Create; 2582end; 2583 2584constructor TThreadsMonitor.Create; 2585begin 2586 FThreads := CreateThreads; 2587 inherited Create; 2588end; 2589 2590destructor TThreadsMonitor.Destroy; 2591begin 2592 inherited Destroy; 2593 FreeAndNil(FThreads); 2594end; 2595 2596{ TRegistersMonitor } 2597 2598function TRegistersMonitor.GetSupplier: TRegisterSupplier; 2599begin 2600 Result := TRegisterSupplier(inherited Supplier); 2601end; 2602 2603procedure TRegistersMonitor.SetSupplier(AValue: TRegisterSupplier); 2604begin 2605 inherited Supplier := AValue; 2606end; 2607 2608function TRegistersMonitor.CreateRegistersList: TRegistersList; 2609begin 2610 Result := TRegistersList.Create; 2611end; 2612 2613constructor TRegistersMonitor.Create; 2614begin 2615 inherited Create; 2616 FRegistersList := CreateRegistersList; 2617 FRegistersList.AddReference; 2618end; 2619 2620destructor TRegistersMonitor.Destroy; 2621begin 2622 inherited Destroy; 2623 ReleaseRefAndNil(FRegistersList); 2624end; 2625 2626{ TDebuggerDataHandler } 2627 2628procedure TDebuggerDataHandler.DoStateEnterPause; 2629begin 2630 // 2631end; 2632 2633procedure TDebuggerDataHandler.DoStateLeavePause; 2634begin 2635 // 2636end; 2637 2638procedure TDebuggerDataHandler.DoStateLeavePauseClean; 2639begin 2640 // 2641end; 2642 2643procedure TDebuggerDataHandler.DoStateChangeEx(const AOldState, ANewState: TDBGState); 2644begin 2645 FNotifiedState := ANewState; 2646 FOldState := AOldState; 2647 DebugLnEnter(DBG_DATA_MONITORS, [ClassName, ': >>ENTER: ', ClassName, '.DoStateChange New-State=', dbgs(FNotifiedState)]); 2648 2649 if FNotifiedState in [dsPause, dsInternalPause] 2650 then begin 2651 // typical: Clear and reload data 2652 if not(AOldState in [dsPause, dsInternalPause] ) 2653 then DoStateEnterPause; 2654 end 2655 else 2656 if (AOldState in [dsPause, dsInternalPause, dsNone] ) 2657 then begin 2658 // dsIdle happens after dsStop 2659 if (FNotifiedState in [dsRun, dsInit, dsIdle]) or (AOldState = dsNone) 2660 then begin 2661 // typical: finalize snapshot and clear data. 2662 DoStateLeavePauseClean; 2663 end 2664 else begin 2665 // typical: finalize snapshot 2666 // Do *not* clear data. Objects may be in use (e.g. dsError) 2667 DoStateLeavePause; 2668 end; 2669 end 2670 else 2671 if (AOldState in [dsStop]) and (FNotifiedState = dsIdle) 2672 then begin 2673 // stopped // typical: finalize snapshot and clear data. 2674 DoStateLeavePauseClean; 2675 end; 2676 DebugLnExit(DBG_DATA_MONITORS, [ClassName, ': <<EXIT: ', ClassName, '.DoStateChange']); 2677end; 2678 2679procedure TDebuggerDataHandler.DoBeginUpdate; 2680begin 2681 // 2682end; 2683 2684procedure TDebuggerDataHandler.DoEndUpdate; 2685begin 2686 // 2687end; 2688 2689procedure TDebuggerDataHandler.BeginUpdate; 2690begin 2691 inc(FUpdateCount); 2692 if FUpdateCount = 1 then 2693 DoBeginUpdate; 2694end; 2695 2696procedure TDebuggerDataHandler.EndUpdate; 2697begin 2698 assert(FUpdateCount > 0, 'TDebuggerDataMonitor.EndUpdate: FUpdateCount > 0'); 2699 dec(FUpdateCount); 2700 if FUpdateCount = 0 then 2701 DoEndUpdate; 2702end; 2703 2704function TDebuggerDataHandler.IsUpdating: Boolean; 2705begin 2706 Result := FUpdateCount > 0; 2707end; 2708 2709{ TWatchValue } 2710 2711procedure TWatchValue.SetValidity(AValue: TDebuggerDataState); 2712var 2713 OldValidity: TDebuggerDataState; 2714begin 2715 if FValidity = AValue then exit; 2716 //DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TWatchValue.SetValidity: FThreadId=', FThreadId, ' FStackFrame=',FStackFrame, ' Expr=', Expression, ' AValidity=',dbgs(AValue)]); 2717 DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TWatchValue.SetValidity: Expr=', Expression, ' AValidity=',dbgs(AValue)]); 2718 OldValidity := FValidity; 2719 FValidity := AValue; 2720 DoDataValidityChanged(OldValidity); 2721end; 2722 2723procedure TWatchValue.SetValue(AValue: String); 2724begin 2725 if FValue = AValue then exit; 2726 //asser not immutable 2727 FValue := AValue; 2728end; 2729 2730procedure TWatchValue.SetTypeInfo(AValue: TDBGType); 2731begin 2732 //assert(Self is TCurrentWatchValue, 'TWatchValue.SetTypeInfo'); 2733 FreeAndNil(FTypeInfo); 2734 FTypeInfo := AValue; 2735end; 2736 2737procedure TWatchValue.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); 2738begin 2739 2740end; 2741 2742function TWatchValue.GetExpression: String; 2743begin 2744 Result := FWatch.Expression; 2745end; 2746 2747function TWatchValue.GetTypeInfo: TDBGType; 2748begin 2749 Result := FTypeInfo; 2750end; 2751 2752function TWatchValue.GetValue: String; 2753begin 2754 Result := FValue; 2755end; 2756 2757constructor TWatchValue.Create(AOwnerWatch: TWatch); 2758begin 2759 FWatch := AOwnerWatch; 2760 inherited Create; 2761end; 2762 2763function TWatchValue.GetWatch: TWatch; 2764begin 2765 Result := FWatch; 2766end; 2767 2768destructor TWatchValue.Destroy; 2769begin 2770 inherited Destroy; 2771 FreeAndNil(FTypeInfo); 2772end; 2773 2774procedure TWatchValue.Assign(AnOther: TWatchValue); 2775begin 2776 FreeAndNil(FTypeInfo); 2777 //FTypeInfo := TWatchValue(AnOther).FTypeInfo.cre; 2778 FValue := AnOther.FValue; 2779 FValidity := AnOther.FValidity; 2780end; 2781 2782{ TWatch } 2783 2784procedure TWatch.SetDisplayFormat(AValue: TWatchDisplayFormat); 2785begin 2786 if AValue = FDisplayFormat then exit; 2787 FDisplayFormat := AValue; 2788 DoDisplayFormatChanged; 2789end; 2790 2791procedure TWatch.SetEnabled(AValue: Boolean); 2792begin 2793 if FEnabled <> AValue 2794 then begin 2795 FEnabled := AValue; 2796 DoEnableChange; 2797 end; 2798end; 2799 2800procedure TWatch.SetEvaluateFlags(AValue: TDBGEvaluateFlags); 2801begin 2802 if FEvaluateFlags = AValue then Exit; 2803 FEvaluateFlags := AValue; 2804 Changed; 2805 DoModified; 2806end; 2807 2808procedure TWatch.SetExpression(AValue: String); 2809begin 2810 if AValue <> FExpression 2811 then begin 2812 FExpression := AValue; 2813 FValueList.Clear; 2814 DoExpressionChange; 2815 end; 2816end; 2817 2818procedure TWatch.SetRepeatCount(AValue: Integer); 2819begin 2820 if FRepeatCount = AValue then Exit; 2821 FRepeatCount := AValue; 2822 Changed; 2823 DoModified; 2824end; 2825 2826function TWatch.GetValue(const AThreadId: Integer; 2827 const AStackFrame: Integer): TWatchValue; 2828begin 2829 Result := FValueList[AThreadId, AStackFrame]; 2830end; 2831 2832procedure TWatch.DoModified; 2833begin 2834 // 2835end; 2836 2837procedure TWatch.DoEnableChange; 2838begin 2839 // 2840end; 2841 2842procedure TWatch.DoExpressionChange; 2843begin 2844 // 2845end; 2846 2847procedure TWatch.DoDisplayFormatChanged; 2848begin 2849 // 2850end; 2851 2852procedure TWatch.AssignTo(Dest: TPersistent); 2853begin 2854 if Dest is TWatch 2855 then begin 2856 TWatch(Dest).FExpression := FExpression; 2857 TWatch(Dest).FEnabled := FEnabled; 2858 TWatch(Dest).FDisplayFormat := FDisplayFormat; 2859 TWatch(Dest).FRepeatCount := FRepeatCount; 2860 TWatch(Dest).FEvaluateFlags := FEvaluateFlags; 2861 TWatch(Dest).FValueList.Assign(FValueList); 2862 end 2863 else inherited; 2864end; 2865 2866function TWatch.CreateValueList: TWatchValueList; 2867begin 2868 Result := TWatchValueList.Create(Self); 2869end; 2870 2871constructor TWatch.Create(ACollection: TCollection); 2872begin 2873 FEnabled := False; 2874 FValueList := CreateValueList; 2875 inherited Create(ACollection); 2876end; 2877 2878destructor TWatch.Destroy; 2879begin 2880 FValueList.Clear; 2881 inherited Destroy; 2882 FreeAndNil(FValueList); 2883end; 2884 2885procedure TWatch.ClearValues; 2886begin 2887 FValueList.Clear; 2888end; 2889 2890{ TWatchValueList } 2891 2892function TWatchValueList.GetEntry(const AThreadId: Integer; 2893 const AStackFrame: Integer): TWatchValue; 2894var 2895 i: Integer; 2896begin 2897 i := FList.Count - 1; 2898 while i >= 0 do begin 2899 Result := TWatchValue(FList[i]); 2900 if (Result.ThreadId = AThreadId) and (Result.StackFrame = AStackFrame) and 2901 (Result.DisplayFormat = FWatch.DisplayFormat) and 2902 (Result.RepeatCount = FWatch.RepeatCount) and 2903 (Result.EvaluateFlags = FWatch.EvaluateFlags) 2904 then 2905 exit; 2906 dec(i); 2907 end; 2908 Result := CreateEntry(AThreadId, AStackFrame); 2909end; 2910 2911function TWatchValueList.GetEntryByIdx(AnIndex: integer): TWatchValue; 2912begin 2913 Result := TWatchValue(FList[AnIndex]); 2914end; 2915 2916function TWatchValueList.CreateEntry(const AThreadId: Integer; 2917 const AStackFrame: Integer): TWatchValue; 2918begin 2919 Result := nil; 2920end; 2921 2922function TWatchValueList.CopyEntry(AnEntry: TWatchValue): TWatchValue; 2923begin 2924 Result := TWatchValue.Create(FWatch); 2925 Result.Assign(AnEntry); 2926end; 2927 2928procedure TWatchValueList.Assign(AnOther: TWatchValueList); 2929var 2930 i: Integer; 2931begin 2932 Clear; 2933 for i := 0 to AnOther.FList.Count - 1 do begin 2934 FList.Add(CopyEntry(TWatchValue(AnOther.FList[i]))); 2935 end; 2936end; 2937 2938constructor TWatchValueList.Create(AOwnerWatch: TWatch); 2939begin 2940 assert(AOwnerWatch <> nil, 'TWatchValueList.Create without owner'); 2941 FList := TList.Create; 2942 FWatch := AOwnerWatch; 2943 inherited Create; 2944end; 2945 2946destructor TWatchValueList.Destroy; 2947begin 2948 Clear; 2949 inherited Destroy; 2950 FreeAndNil(FList); 2951end; 2952 2953procedure TWatchValueList.Add(AnEntry: TWatchValue); 2954begin 2955 Flist.Add(AnEntry); 2956end; 2957 2958procedure TWatchValueList.Clear; 2959begin 2960 while FList.Count > 0 do begin 2961 TObject(FList[0]).Free; 2962 FList.Delete(0); 2963 end; 2964end; 2965 2966function TWatchValueList.Count: Integer; 2967begin 2968 Result := FList.Count; 2969end; 2970 2971{ TRegisterSupplier } 2972 2973function TRegisterSupplier.GetCurrentRegistersList: TRegistersList; 2974begin 2975 Result := nil; 2976 if Monitor <> nil then 2977 Result := Monitor.RegistersList; 2978end; 2979 2980function TRegisterSupplier.GetMonitor: TRegistersMonitor; 2981begin 2982 Result := TRegistersMonitor(inherited Monitor); 2983end; 2984 2985procedure TRegisterSupplier.SetMonitor(AValue: TRegistersMonitor); 2986begin 2987 inherited Monitor := AValue; 2988end; 2989 2990procedure TRegisterSupplier.RequestData(ARegisters: TRegisters); 2991begin 2992 ARegisters.SetDataValidity(ddsInvalid); 2993end; 2994 2995{ TLocalsValue } 2996 2997procedure TLocalsValue.DoAssign(AnOther: TDbgEntityValue); 2998begin 2999 inherited DoAssign(AnOther); 3000 FName := TLocalsValue(AnOther).FName; 3001 FValue := TLocalsValue(AnOther).FValue; 3002end; 3003 3004{ TLocalsListBase } 3005 3006function TLocalsList.GetEntry(AThreadId, AStackFrame: Integer): TLocals; 3007begin 3008 Result := TLocals(inherited Entries[AThreadId, AStackFrame]); 3009end; 3010 3011function TLocalsList.GetEntryByIdx(AnIndex: Integer): TLocals; 3012begin 3013 Result := TLocals(inherited EntriesByIdx[AnIndex]); 3014end; 3015 3016{ TLocalsBase } 3017 3018function TLocals.GetEntry(AnIndex: Integer): TLocalsValue; 3019begin 3020 Result := TLocalsValue(inherited Entries[AnIndex]); 3021end; 3022 3023function TLocals.GetName(const AnIndex: Integer): String; 3024begin 3025 Result := Entries[AnIndex].Name; 3026end; 3027 3028function TLocals.GetValue(const AnIndex: Integer): String; 3029begin 3030 Result := Entries[AnIndex].Value; 3031end; 3032 3033function TLocals.CreateEntry: TDbgEntityValue; 3034begin 3035 Result := TLocalsValue.Create; 3036end; 3037 3038procedure TLocals.Add(const AName, AValue: String); 3039var 3040 v: TLocalsValue; 3041begin 3042 assert(not Immutable, 'TLocalsBase.Add Immutable'); 3043 v := TLocalsValue(CreateEntry); 3044 v.FName := AName; 3045 v.FValue := AValue; 3046 inherited Add(v); 3047end; 3048 3049procedure TLocals.SetDataValidity(AValidity: TDebuggerDataState); 3050begin 3051 // 3052end; 3053 3054function TLocals.Count: Integer; 3055begin 3056 Result := inherited Count; 3057end; 3058 3059{ TRegisterDisplayValue } 3060 3061function TRegisterDisplayValue.GetValue(ADispFormat: TRegisterDisplayFormat): String; 3062const Digits = '01234567'; 3063 function IntToBase(Val, Base: QWord): String; 3064 var 3065 M: Integer; 3066 begin 3067 Result := ''; 3068 case Base of 3069 2: M := 1; 3070 8: M := 7; 3071 end; 3072 while Val > 0 do begin 3073 Result := Digits[1 + (Val and m)] + Result; 3074 Val := Val div Base; 3075 end; 3076 end; 3077begin 3078 Result := ''; 3079 if not(ADispFormat in FSupportedDispFormats) then exit; 3080 if (ADispFormat in [rdDefault, rdRaw]) or not (rdvHasNum in FFlags) then begin 3081 Result := FStringValue; 3082 exit; 3083 end; 3084 case ADispFormat of 3085 rdHex: Result := IntToHex(FNumValue, FSize * 2); 3086 rdBinary: Result := IntToBase(FNumValue, 2); 3087 rdOctal: Result := IntToBase(FNumValue, 8); 3088 rdDecimal: Result := IntToStr(FNumValue); 3089 end; 3090end; 3091 3092procedure TRegisterDisplayValue.Assign(AnOther: TRegisterDisplayValue); 3093begin 3094 FStringValue := AnOther.FStringValue; 3095 FNumValue := AnOther.FNumValue; 3096 FFlags := AnOther.FFlags; 3097 FSize := AnOther.FSize; 3098 FSupportedDispFormats := AnOther.FSupportedDispFormats; 3099end; 3100 3101procedure TRegisterDisplayValue.SetAsNum(AValue: QWord; ASize: Integer); 3102begin 3103 if FNumValue = AValue then Exit; 3104 FNumValue := AValue; 3105 FSize := ASize; 3106 Include(FFlags, rdvHasNum); 3107end; 3108 3109procedure TRegisterDisplayValue.SetAsText(AValue: String); 3110begin 3111 FStringValue := AValue; 3112end; 3113 3114procedure TRegisterDisplayValue.AddFormats(AFormats: TRegisterDisplayFormats); 3115begin 3116 FSupportedDispFormats := FSupportedDispFormats + AFormats; 3117end; 3118 3119{ TRegisterValue } 3120 3121function TRegisterValue.GetValue: String; 3122var 3123 v: TRegisterDisplayValue; 3124begin 3125 v := GetValueObject(); 3126 if v <> nil then begin 3127 Result := v.Value[FDisplayFormat]; 3128 exit; 3129 end; 3130 3131 Result := ''; 3132 DoValueNotEvaluated; 3133end; 3134 3135function TRegisterValue.GetHasValue: Boolean; 3136begin 3137 Result := GetValueObject <> nil; 3138end; 3139 3140function TRegisterValue.GetHasValueFormat(ADispFormat: TRegisterDisplayFormat): Boolean; 3141begin 3142 Result := GetValueObject(ADispFormat) <> nil; 3143end; 3144 3145function TRegisterValue.GetValueObj: TRegisterDisplayValue; 3146begin 3147 Result := GetValueObject(True); 3148end; 3149 3150function TRegisterValue.GetValueObjFormat(ADispFormat: TRegisterDisplayFormat): TRegisterDisplayValue; 3151begin 3152 Result := GetValueObject(ADispFormat, True); 3153end; 3154 3155procedure TRegisterValue.SetDisplayFormat(AValue: TRegisterDisplayFormat); 3156var 3157 Old: TRegisterDisplayFormat; 3158begin 3159 assert(not Immutable, 'TRegisterValue.SetDisplayFormat: not Immutable'); 3160 if FDisplayFormat = AValue then Exit; 3161 Old := FDisplayFormat; 3162 FDisplayFormat := AValue; 3163 DoDisplayFormatChanged(Old); 3164end; 3165 3166procedure TRegisterValue.SetValue(AValue: String); 3167var 3168 v: TRegisterDisplayValue; 3169begin 3170 assert(not Immutable, 'TRegisterValue.SetValue: not Immutable'); 3171 v := GetValueObject(True); 3172 v.FStringValue := AValue; 3173end; 3174 3175function TRegisterValue.GetValueObject(ACreateNew: Boolean): TRegisterDisplayValue; 3176begin 3177 Result := GetValueObject(FDisplayFormat, ACreateNew); 3178end; 3179 3180function TRegisterValue.GetValueObject(ADispFormat: TRegisterDisplayFormat; 3181 ACreateNew: Boolean): TRegisterDisplayValue; 3182var 3183 i: Integer; 3184begin 3185 for i := 0 to length(FValues) - 1 do 3186 if ADispFormat in FValues[i].SupportedDispFormats then begin 3187 Result := FValues[i]; 3188 exit; 3189 end; 3190 3191 if not ACreateNew then begin 3192 Result := nil; 3193 exit; 3194 end; 3195 3196 assert(not Immutable, 'TRegisterValue.GetValueObject: not Immutable'); 3197 Result := TRegisterDisplayValue.Create; 3198 Result.FSupportedDispFormats := [ADispFormat]; 3199 i := length(FValues); 3200 SetLength(FValues, i + 1); 3201 FValues[i] := Result; 3202end; 3203 3204procedure TRegisterValue.SetDataValidity(AValidity: TDebuggerDataState); 3205var 3206 Old: TDebuggerDataState; 3207begin 3208 assert(not Immutable, 'TRegisterValue.SetDataValidity: not Immutable'); 3209 if FDataValidity = AValidity then exit; 3210 Old := FDataValidity; 3211 FDataValidity := AValidity; 3212 DoDataValidityChanged(Old); 3213end; 3214 3215procedure TRegisterValue.ClearDispValues; 3216var 3217 i: Integer; 3218begin 3219 for i := 0 to Length(FValues) - 1 do 3220 FValues[i].Free; 3221 FValues := nil; 3222end; 3223 3224procedure TRegisterValue.DoAssign(AnOther: TDbgEntityValue); 3225var 3226 i: Integer; 3227begin 3228 inherited DoAssign(AnOther); 3229 FDataValidity := TRegisterValue(AnOther).FDataValidity; 3230 FDisplayFormat := TRegisterValue(AnOther).FDisplayFormat; 3231 FName := TRegisterValue(AnOther).FName; 3232 SetLength(FValues, length(TRegisterValue(AnOther).FValues)); 3233 for i := 0 to length(TRegisterValue(AnOther).FValues) - 1 do begin 3234 FValues[i] := TRegisterDisplayValue.Create; 3235 FValues[i].Assign(TRegisterValue(AnOther).FValues[i]); 3236 end; 3237end; 3238 3239procedure TRegisterValue.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); 3240begin 3241 // 3242end; 3243 3244procedure TRegisterValue.DoDisplayFormatChanged(AnOldFormat: TRegisterDisplayFormat); 3245begin 3246 // 3247end; 3248 3249procedure TRegisterValue.DoValueNotEvaluated; 3250begin 3251 // 3252end; 3253 3254destructor TRegisterValue.Destroy; 3255begin 3256 inherited Destroy; 3257 ClearDispValues; 3258end; 3259 3260{ TRegisters } 3261 3262function TRegisters.GetEntry(AnIndex: Integer): TRegisterValue; 3263begin 3264 Result := TRegisterValue(inherited Entries[AnIndex]); 3265end; 3266 3267function TRegisters.GetEntryByName(const AName: String): TRegisterValue; 3268var 3269 i: Integer; 3270begin 3271 for i := 0 to Count - 1 do begin 3272 Result := Entries[i]; 3273 if Result.Name = AName then 3274 exit; 3275 end; 3276 3277 assert(not Immutable, 'TRegisters.GetEntryByName: not Immutable'); 3278 Result := TRegisterValue(CreateEntry); 3279 Result.FName := AName; 3280 Add(Result); 3281end; 3282 3283procedure TRegisters.SetDataValidity(AValue: TDebuggerDataState); 3284var 3285 Old: TDebuggerDataState; 3286begin 3287 assert(not Immutable, 'TRegisters.SetDataValidity: not Immutable'); 3288 if FDataValidity = AValue then Exit; 3289 Old := FDataValidity; 3290 FDataValidity := AValue; 3291 DoDataValidityChanged(Old); 3292end; 3293 3294function TRegisters.CreateEntry: TDbgEntityValue; 3295begin 3296 assert(not Immutable, 'TRegisters.CreateEntry: not Immutable'); 3297 Result := TRegisterValue.Create; 3298end; 3299 3300procedure TRegisters.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); 3301begin 3302 // 3303end; 3304 3305function TRegisters.Count: Integer; 3306begin 3307 if FDataValidity = ddsValid then 3308 Result := inherited Count 3309 else 3310 Result := 0; 3311end; 3312 3313{ TRegistersList } 3314 3315function TRegistersList.GetEntry(AThreadId, AStackFrame: Integer): TRegisters; 3316begin 3317 Result := TRegisters(inherited Entries[AThreadId, AStackFrame]); 3318end; 3319 3320function TRegistersList.GetEntryByIdx(AnIndex: Integer): TRegisters; 3321begin 3322 Result := TRegisters(inherited EntriesByIdx[AnIndex]); 3323end; 3324 3325{ TWatchesBase } 3326 3327function TWatches.GetItemBase(const AnIndex: Integer): TWatch; 3328begin 3329 Result := TWatch(inherited Items[AnIndex]); 3330end; 3331 3332procedure TWatches.SetItemBase(const AnIndex: Integer; const AValue: TWatch); 3333begin 3334 inherited Items[AnIndex] := AValue; 3335end; 3336 3337function TWatches.WatchClass: TWatchClass; 3338begin 3339 Result := TWatch; 3340end; 3341 3342constructor TWatches.Create; 3343begin 3344 inherited Create(WatchClass); 3345end; 3346 3347procedure TWatches.ClearValues; 3348var 3349 n: Integer; 3350begin 3351 for n := 0 to Count - 1 do 3352 Items[n].ClearValues; 3353end; 3354 3355function TWatches.Find(const AExpression: String): TWatch; 3356var 3357 n: Integer; 3358 S: String; 3359begin 3360 S := UpperCase(AExpression); 3361 for n := 0 to Count - 1 do 3362 begin 3363 Result := TWatch(GetItem(n)); 3364 if UpperCase(Result.Expression) = S 3365 then Exit; 3366 end; 3367 Result := nil; 3368end; 3369 3370{ TCallStackBase } 3371 3372function TCallStackBase.GetNewCurrentIndex: Integer; 3373begin 3374 Result := 0; 3375end; 3376 3377function TCallStackBase.GetCount: Integer; 3378begin 3379 Result := 0; 3380end; 3381 3382function TCallStackBase.GetCurrent: Integer; 3383begin 3384 Result := FCurrent; 3385end; 3386 3387procedure TCallStackBase.SetCurrent(AValue: Integer); 3388begin 3389 FCurrent := AValue; 3390end; 3391 3392function TCallStackBase.GetHighestUnknown: Integer; 3393begin 3394 Result := -1; 3395end; 3396 3397function TCallStackBase.GetLowestUnknown: Integer; 3398begin 3399 Result := 0; 3400end; 3401 3402constructor TCallStackBase.Create; 3403begin 3404 FThreadId := -1; 3405 FCurrent := -1; 3406 inherited; 3407end; 3408 3409function TCallStackBase.CreateCopy: TCallStackBase; 3410begin 3411 Result := TCallStackBase.Create; 3412 Result.Assign(Self); 3413end; 3414 3415procedure TCallStackBase.Assign(AnOther: TCallStackBase); 3416begin 3417 ThreadId := AnOther.ThreadId; 3418 FCurrent := AnOther.FCurrent; 3419end; 3420 3421procedure TCallStackBase.SetCountValidity(AValidity: TDebuggerDataState); 3422begin 3423 // 3424end; 3425 3426procedure TCallStackBase.SetHasAtLeastCountInfo(AValidity: TDebuggerDataState; 3427 AMinCount: Integer); 3428begin 3429 // 3430end; 3431 3432procedure TCallStackBase.SetCurrentValidity(AValidity: TDebuggerDataState); 3433begin 3434 // 3435end; 3436 3437{ TRunningProcessInfo } 3438 3439constructor TRunningProcessInfo.Create(APID: Cardinal; const AImageName: string); 3440begin 3441 self.PID := APID; 3442 self.ImageName := AImageName; 3443end; 3444 3445{ TDebuggerDataMonitor } 3446 3447procedure TDebuggerDataMonitor.SetSupplier(const AValue: TDebuggerDataSupplier); 3448begin 3449 if FSupplier = AValue then exit; 3450 Assert((FSupplier=nil) or (AValue=nil), 'TDebuggerDataMonitor.Supplier already set'); 3451 if FSupplier <> nil then FSupplier.Monitor := nil; 3452 FSupplier := AValue; 3453 if FSupplier <> nil then FSupplier.Monitor:= self; 3454 3455 DoNewSupplier; 3456end; 3457 3458procedure TDebuggerDataMonitor.DoModified; 3459begin 3460 // 3461end; 3462 3463procedure TDebuggerDataMonitor.DoNewSupplier; 3464begin 3465 // 3466end; 3467 3468destructor TDebuggerDataMonitor.Destroy; 3469begin 3470 Supplier := nil; 3471 inherited Destroy; 3472end; 3473 3474{ TDebuggerDataSupplier } 3475 3476procedure TDebuggerDataSupplier.SetMonitor(const AValue: TDebuggerDataMonitor); 3477begin 3478 if FMonitor = AValue then exit; 3479 Assert((FMonitor=nil) or (AValue=nil), 'TDebuggerDataSupplier.Monitor already set'); 3480 FMonitor := AValue; 3481 DoNewMonitor; 3482end; 3483 3484procedure TDebuggerDataSupplier.DoNewMonitor; 3485begin 3486 // 3487end; 3488 3489procedure TDebuggerDataSupplier.DoStateLeavePauseClean; 3490begin 3491 DoStateLeavePause; 3492end; 3493 3494procedure TDebuggerDataSupplier.DoStateChange(const AOldState: TDBGState); 3495begin 3496 if (Debugger = nil) then Exit; 3497 DoStateChangeEx(AOldState, Debugger.State); 3498 if Monitor <> nil then 3499 Monitor.DoStateChangeEx(AOldState, FDebugger.State); 3500end; 3501 3502constructor TDebuggerDataSupplier.Create(const ADebugger: TDebuggerIntf); 3503begin 3504 FDebugger := ADebugger; 3505 inherited Create; 3506end; 3507 3508destructor TDebuggerDataSupplier.Destroy; 3509begin 3510 if FMonitor <> nil then FMonitor.Supplier := nil; 3511 inherited Destroy; 3512end; 3513 3514procedure TDebuggerDataSupplier.DoBeginUpdate; 3515begin 3516 FMonitor.BeginUpdate; 3517end; 3518 3519procedure TDebuggerDataSupplier.DoEndUpdate; 3520begin 3521 FMonitor.EndUpdate; 3522end; 3523 3524{ =========================================================================== 3525 TBaseBreakPoint 3526 =========================================================================== } 3527 3528function TBaseBreakPoint.GetAddress: TDBGPtr; 3529begin 3530 Result := FAddress; 3531end; 3532 3533function TBaseBreakPoint.GetKind: TDBGBreakPointKind; 3534begin 3535 Result := FKind; 3536end; 3537 3538procedure TBaseBreakPoint.SetKind(const AValue: TDBGBreakPointKind); 3539begin 3540 if FKind <> AValue 3541 then begin 3542 FKind := AValue; 3543 Changed; 3544 MarkPropertyChanged(ciKind); 3545 end; 3546end; 3547 3548procedure TBaseBreakPoint.SetAddress(const AValue: TDBGPtr); 3549begin 3550 if FAddress <> AValue then 3551 begin 3552 FAddress := AValue; 3553 Changed; 3554 MarkPropertyChanged(ciLocation); 3555 end; 3556end; 3557 3558function TBaseBreakPoint.GetWatchData: String; 3559begin 3560 Result := FWatchData; 3561end; 3562 3563function TBaseBreakPoint.GetWatchScope: TDBGWatchPointScope; 3564begin 3565 Result := FWatchScope; 3566end; 3567 3568function TBaseBreakPoint.GetWatchKind: TDBGWatchPointKind; 3569begin 3570 Result := FWatchKind; 3571end; 3572 3573procedure TBaseBreakPoint.AssignLocationTo(Dest: TPersistent); 3574var 3575 DestBreakPoint: TBaseBreakPoint absolute Dest; 3576begin 3577 DestBreakPoint.SetLocation(FSource, FLine); 3578end; 3579 3580procedure TBaseBreakPoint.AssignTo(Dest: TPersistent); 3581var 3582 DestBreakPoint: TBaseBreakPoint absolute Dest; 3583begin 3584 // updatelock is set in source.assignto 3585 if Dest is TBaseBreakPoint 3586 then begin 3587 DestBreakPoint.SetKind(FKind); 3588 DestBreakPoint.SetWatch(FWatchData, FWatchScope, FWatchKind); 3589 DestBreakPoint.SetAddress(FAddress); 3590 AssignLocationTo(DestBreakPoint); 3591 DestBreakPoint.SetBreakHitCount(FBreakHitCount); 3592 DestBreakPoint.SetExpression(FExpression); 3593 DestBreakPoint.SetEnabled(FEnabled); 3594 DestBreakPoint.InitialEnabled := FInitialEnabled; 3595 end 3596 else inherited; 3597end; 3598 3599constructor TBaseBreakPoint.Create(ACollection: TCollection); 3600begin 3601 FPropertiesChanged := [ciCreated]; 3602 FAddress := 0; 3603 FSource := ''; 3604 FLine := -1; 3605 FValid := vsUnknown; 3606 FEnabled := False; 3607 FHitCount := 0; 3608 FBreakHitCount := 0; 3609 FExpression := ''; 3610 FInitialEnabled := False; 3611 FKind := bpkSource; 3612 inherited Create(ACollection); 3613 AddReference; 3614end; 3615 3616destructor TBaseBreakPoint.Destroy; 3617begin 3618 FPropertiesChanged := []; // Do not sent old changes 3619 if not IsUpdating then 3620 MarkPropertyChanged(ciDestroy); 3621 inherited Destroy; 3622end; 3623 3624procedure TBaseBreakPoint.SetPendingToValid(const AValue: TValidState); 3625begin 3626 assert(Valid = vsPending, 'Can only change state if pending'); 3627 SetValid(AValue); 3628end; 3629 3630procedure TBaseBreakPoint.MarkPropertyChanged(AChanged: TDbgBpChangeIndicator); 3631begin 3632 MarkPropertiesChanged([AChanged]); 3633end; 3634 3635procedure TBaseBreakPoint.MarkPropertiesChanged(AChanged: TDbgBpChangeIndicators 3636 ); 3637var 3638 c: TDbgBpChangeIndicators; 3639begin 3640 FPropertiesChanged := FPropertiesChanged + AChanged; 3641 if IsUpdating or FInPropertiesChanged then 3642 exit; 3643 FInPropertiesChanged := True; 3644 try 3645 while FPropertiesChanged <> [] do begin 3646 c := FPropertiesChanged; 3647 FPropertiesChanged := []; 3648 DoPropertiesChanged(c); 3649 end; 3650 finally 3651 FInPropertiesChanged := False; 3652 end; 3653end; 3654 3655procedure TBaseBreakPoint.DoPropertiesChanged(AChanged: TDbgBpChangeIndicators); 3656begin 3657 if ciEnabled in AChanged then 3658 DoEnableChange; 3659 if ciCondition in AChanged then 3660 DoExpressionChange; 3661end; 3662 3663procedure TBaseBreakPoint.DoEnableChange; 3664begin 3665 Changed; 3666end; 3667 3668procedure TBaseBreakPoint.DoExpressionChange; 3669begin 3670 Changed; 3671end; 3672 3673procedure TBaseBreakPoint.DoHit(const ACount: Integer; var AContinue: Boolean ); 3674begin 3675 SetHitCount(ACount); 3676end; 3677 3678function TBaseBreakPoint.GetBreakHitCount: Integer; 3679begin 3680 Result := FBreakHitCount; 3681end; 3682 3683function TBaseBreakPoint.GetEnabled: Boolean; 3684begin 3685 Result := FEnabled; 3686end; 3687 3688function TBaseBreakPoint.GetExpression: String; 3689begin 3690 Result := FExpression; 3691end; 3692 3693function TBaseBreakPoint.GetHitCount: Integer; 3694begin 3695 Result := FHitCount; 3696end; 3697 3698function TBaseBreakPoint.GetLine: Integer; 3699begin 3700 Result := FLine; 3701end; 3702 3703function TBaseBreakPoint.GetSource: String; 3704begin 3705 Result := FSource; 3706end; 3707 3708function TBaseBreakPoint.GetValid: TValidState; 3709begin 3710 Result := FValid; 3711end; 3712 3713procedure TBaseBreakPoint.DoEndUpdate; 3714begin 3715 inherited DoEndUpdate; 3716 MarkPropertiesChanged([]); 3717end; 3718 3719procedure TBaseBreakPoint.SetBreakHitCount(const AValue: Integer); 3720begin 3721 if FBreakHitCount <> AValue 3722 then begin 3723 FBreakHitCount := AValue; 3724 Changed; 3725 MarkPropertyChanged(ciHitCount); 3726 end; 3727end; 3728 3729procedure TBaseBreakPoint.SetEnabled (const AValue: Boolean ); 3730begin 3731 if FEnabled <> AValue 3732 then begin 3733 FEnabled := AValue; 3734 MarkPropertyChanged(ciEnabled); 3735 end; 3736end; 3737 3738procedure TBaseBreakPoint.SetExpression (const AValue: String ); 3739begin 3740 if FExpression <> AValue 3741 then begin 3742 FExpression := AValue; 3743 MarkPropertyChanged(ciCondition); 3744 end; 3745end; 3746 3747procedure TBaseBreakPoint.SetHitCount (const AValue: Integer ); 3748begin 3749 if FHitCount <> AValue 3750 then begin 3751 FHitCount := AValue; 3752 Changed; 3753 end; 3754end; 3755 3756procedure TBaseBreakPoint.SetInitialEnabled(const AValue: Boolean); 3757begin 3758 if FInitialEnabled=AValue then exit; 3759 FInitialEnabled:=AValue; 3760end; 3761 3762procedure TBaseBreakPoint.SetLocation (const ASource: String; const ALine: Integer ); 3763begin 3764 if (FSource = ASource) and (FLine = ALine) then exit; 3765 FSource := ASource; 3766 FLine := ALine; 3767 Changed; 3768 MarkPropertyChanged(ciLocation); 3769end; 3770 3771procedure TBaseBreakPoint.SetWatch(const AData: String; const AScope: TDBGWatchPointScope; 3772 const AKind: TDBGWatchPointKind); 3773begin 3774 if (AData = FWatchData) and (AScope = FWatchScope) and (AKind = FWatchKind) then exit; 3775 FWatchData := AData; 3776 FWatchScope := AScope; 3777 FWatchKind := AKind; 3778 Changed; 3779 MarkPropertyChanged(ciLocation); 3780end; 3781 3782procedure TBaseBreakPoint.SetValid(const AValue: TValidState ); 3783begin 3784 if FValid <> AValue 3785 then begin 3786 FValid := AValue; 3787 Changed; 3788 end; 3789end; 3790 3791{ =========================================================================== } 3792{ TDBGBreakPoint } 3793{ =========================================================================== } 3794 3795constructor TDBGBreakPoint.Create (ACollection: TCollection ); 3796begin 3797 FSlave := nil; 3798 inherited Create(ACollection); 3799end; 3800 3801destructor TDBGBreakPoint.Destroy; 3802var 3803 SBP: TBaseBreakPoint; 3804begin 3805 SBP := FSlave; 3806 FSlave := nil; 3807 if SBP <> nil 3808 then SBP.DoChanged; // In case UpdateCount 0 3809 3810 inherited Destroy; 3811end; 3812 3813procedure TDBGBreakPoint.Hit(var ACanContinue: Boolean); 3814var 3815 cnt: Integer; 3816begin 3817 cnt := HitCount + 1; 3818 if BreakHitcount > 0 3819 then ACanContinue := cnt < BreakHitcount; 3820 DoHit(cnt, ACanContinue); 3821 if Assigned(FSlave) 3822 then FSlave.DoHit(cnt, ACanContinue); 3823 Debugger.DoBreakpointHit(Self, ACanContinue) 3824end; 3825 3826procedure TDBGBreakPoint.DoChanged; 3827begin 3828 inherited DoChanged; 3829 if FSlave <> nil 3830 then FSlave.Changed; 3831end; 3832 3833procedure TDBGBreakPoint.DoStateChange(const AOldState: TDBGState); 3834begin 3835 if Debugger.State <> dsStop then Exit; 3836 if not (AOldState in [dsIdle, dsNone]) then Exit; 3837 3838 BeginUpdate; 3839 try 3840 SetLocation(FSource, Line); 3841 Enabled := InitialEnabled; 3842 SetHitCount(0); 3843 finally 3844 EndUpdate; 3845 end; 3846end; 3847 3848procedure TDBGBreakPoint.DoLogMessage(const AMessage: String); 3849begin 3850 Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, 'Breakpoint Message: ' + AMessage); 3851end; 3852 3853procedure TDBGBreakPoint.DoLogCallStack(const Limit: Integer); 3854const 3855 Spacing = ' '; 3856var 3857 CallStack: TCallStackBase; 3858 I, Count: Integer; 3859 Entry: TCallStackEntry; 3860 StackString: String; 3861begin 3862 Debugger.SetState(dsInternalPause); 3863 CallStack := Debugger.CallStack.CurrentCallStackList.EntriesForThreads[Debugger.Threads.CurrentThreads.CurrentThreadId]; 3864 if Limit = 0 then 3865 begin 3866 Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, 'Breakpoint Call Stack: Log all stack frames'); 3867 Count := CallStack.Count; 3868 CallStack.PrepareRange(0, Count); 3869 end 3870 else 3871 begin 3872 Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, Format('Breakpoint Call Stack: Log %d stack frames', [Limit])); 3873 Count := CallStack.CountLimited(Limit); 3874 CallStack.PrepareRange(0, Count); 3875 end; 3876 3877 for I := 0 to Count - 1 do 3878 begin 3879 Entry := CallStack.Entries[I]; 3880 StackString := Spacing + Entry.Source; 3881 if Entry.Source = '' then // we do not have a source file => just show an adress 3882 StackString := Spacing + ':' + IntToHex(Entry.Address, 8); 3883 StackString := StackString + ' ' + Entry.GetFunctionWithArg; 3884 if line > 0 then 3885 StackString := StackString + ' line ' + IntToStr(Entry.Line); 3886 3887 Debugger.DoDbgEvent(ecBreakpoint, etBreakpointStackDump, StackString); 3888 end; 3889end; 3890 3891procedure TDBGBreakPoint.DoLogExpression(const AnExpression: String); 3892begin 3893 // will be called while Debgger.State = dsRun => can not call Evaluate 3894end; 3895 3896function TDBGBreakPoint.GetDebugger: TDebuggerIntf; 3897begin 3898 Result := TDBGBreakPoints(Collection).FDebugger; 3899end; 3900 3901function TDBGBreakPoint.GetDebuggerState: TDBGState; 3902begin 3903 if Debugger <> nil then 3904 Result := Debugger.State 3905 else 3906 Result := dsNone; 3907end; 3908 3909procedure TDBGBreakPoint.SetSlave(const ASlave : TBaseBreakPoint); 3910begin 3911 Assert((FSlave = nil) or (ASlave = nil), 'TDBGBreakPoint.SetSlave already has a slave'); 3912 FSlave := ASlave; 3913end; 3914 3915procedure TDBGBreakPoint.SetEnabled(const AValue: Boolean); 3916begin 3917 if Enabled = AValue then exit; 3918 inherited SetEnabled(AValue); 3919 // feedback to IDEBreakPoint 3920 if FSlave <> nil then FSlave.Enabled := AValue; 3921end; 3922 3923{ TIdeBreakPointBase } 3924 3925procedure TIdeBreakPointBase.SetMaster(AValue: TDBGBreakPoint); 3926begin 3927 if FMaster = AValue then Exit; 3928 if (FMaster <> nil) and IsUpdating then FMaster.EndUpdate; 3929 FMaster := AValue; 3930 if (FMaster <> nil) and IsUpdating then FMaster.BeginUpdate; 3931end; 3932 3933procedure TIdeBreakPointBase.BeginUpdate; 3934begin 3935 if (not IsUpdating) and (FMaster <> nil) then FMaster.BeginUpdate; 3936 inherited BeginUpdate; 3937end; 3938 3939procedure TIdeBreakPointBase.DoEndUpdate; 3940begin 3941 inherited DoEndUpdate; 3942 if FMaster <> nil then FMaster.EndUpdate; 3943end; 3944 3945procedure TIdeBreakPointBase.ReleaseMaster; 3946begin 3947 if FMaster <> nil 3948 then begin 3949 FMaster.Slave := nil; 3950 ReleaseRefAndNil(FMaster); 3951 end; 3952end; 3953 3954destructor TIdeBreakPointBase.Destroy; 3955begin 3956 ReleaseMaster; 3957 inherited Destroy; 3958end; 3959 3960{ =========================================================================== } 3961{ TBaseBreakPoints } 3962{ =========================================================================== } 3963 3964function TBaseBreakPoints.Add(const ASource: String; const ALine: Integer; 3965 AnUpdating: Boolean): TBaseBreakPoint; 3966begin 3967 Result := TBaseBreakPoint(inherited Add); 3968 Result.BeginUpdate; 3969 Result.SetKind(bpkSource); 3970 Result.SetLocation(ASource, ALine); 3971 if not AnUpdating then 3972 Result.EndUpdate; 3973end; 3974 3975function TBaseBreakPoints.Add(const AAddress: TDBGPtr; AnUpdating: Boolean 3976 ): TBaseBreakPoint; 3977begin 3978 Result := TBaseBreakPoint(inherited Add); 3979 Result.BeginUpdate; 3980 Result.SetKind(bpkAddress); 3981 Result.SetAddress(AAddress); 3982 if not AnUpdating then 3983 Result.EndUpdate; 3984end; 3985 3986function TBaseBreakPoints.Add(const AData: String; 3987 const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; 3988 AnUpdating: Boolean): TBaseBreakPoint; 3989begin 3990 Result := TBaseBreakPoint(inherited Add); 3991 Result.BeginUpdate; 3992 Result.SetKind(bpkData); 3993 Result.SetWatch(AData, AScope, AKind); 3994 if not AnUpdating then 3995 Result.EndUpdate; 3996end; 3997 3998constructor TBaseBreakPoints.Create(const ABreakPointClass: TBaseBreakPointClass); 3999begin 4000 inherited Create(ABreakPointClass); 4001end; 4002 4003destructor TBaseBreakPoints.Destroy; 4004begin 4005 Clear; 4006 inherited Destroy; 4007end; 4008 4009procedure TBaseBreakPoints.Clear; 4010begin 4011 while Count > 0 do TBaseBreakPoint(GetItem(0)).ReleaseReference; 4012end; 4013 4014function TBaseBreakPoints.Find(const ASource: String; const ALine: Integer): TBaseBreakPoint; 4015begin 4016 Result := Find(ASource, ALine, nil); 4017end; 4018 4019function TBaseBreakPoints.Find(const ASource: String; const ALine: Integer; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; 4020var 4021 n: Integer; 4022begin 4023 for n := 0 to Count - 1 do 4024 begin 4025 Result := TBaseBreakPoint(GetItem(n)); 4026 if (Result.Kind = bpkSource) 4027 and (Result.Line = ALine) 4028 and (AIgnore <> Result) 4029 and (CompareFilenames(Result.Source, ASource) = 0) 4030 then Exit; 4031 end; 4032 Result := nil; 4033end; 4034 4035function TBaseBreakPoints.Find(const AAddress: TDBGPtr): TBaseBreakPoint; 4036begin 4037 Result := Find(AAddress, nil); 4038end; 4039 4040function TBaseBreakPoints.Find(const AAddress: TDBGPtr; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; 4041var 4042 n: Integer; 4043begin 4044 for n := 0 to Count - 1 do 4045 begin 4046 Result := TBaseBreakPoint(GetItem(n)); 4047 if (Result.Kind = bpkAddress) 4048 and (Result.Address = AAddress) 4049 and (AIgnore <> Result) 4050 then Exit; 4051 end; 4052 Result := nil; 4053end; 4054 4055function TBaseBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; 4056 const AKind: TDBGWatchPointKind): TBaseBreakPoint; 4057begin 4058 Result := Find(AData, AScope, AKind, nil); 4059end; 4060 4061function TBaseBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; 4062 const AKind: TDBGWatchPointKind; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; 4063var 4064 n: Integer; 4065begin 4066 for n := 0 to Count - 1 do 4067 begin 4068 Result := TBaseBreakPoint(GetItem(n)); 4069 if (Result.Kind = bpkData) 4070 and (Result.WatchData = AData) 4071 and (Result.WatchScope = AScope) 4072 and (Result.WatchKind = AKind) 4073 and (AIgnore <> Result) 4074 then Exit; 4075 end; 4076 Result := nil; 4077end; 4078 4079{ =========================================================================== } 4080{ TDBGBreakPoints } 4081{ =========================================================================== } 4082 4083function TDBGBreakPoints.Add(const ASource: String; const ALine: Integer; 4084 AnUpdating: Boolean): TDBGBreakPoint; 4085begin 4086 Result := TDBGBreakPoint(inherited Add(ASource, ALine, AnUpdating)); 4087end; 4088 4089function TDBGBreakPoints.Add(const AAddress: TDBGPtr; AnUpdating: Boolean 4090 ): TDBGBreakPoint; 4091begin 4092 Result := TDBGBreakPoint(inherited Add(AAddress, AnUpdating)); 4093end; 4094 4095function TDBGBreakPoints.Add(const AData: String; 4096 const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; 4097 AnUpdating: Boolean): TDBGBreakPoint; 4098begin 4099 Result := TDBGBreakPoint(inherited Add(AData, AScope, AKind, AnUpdating)); 4100end; 4101 4102constructor TDBGBreakPoints.Create(const ADebugger: TDebuggerIntf; 4103 const ABreakPointClass: TDBGBreakPointClass); 4104begin 4105 FDebugger := ADebugger; 4106 inherited Create(ABreakPointClass); 4107end; 4108 4109procedure TDBGBreakPoints.DoStateChange(const AOldState: TDBGState); 4110var 4111 n: Integer; 4112begin 4113 for n := 0 to Count - 1 do 4114 GetItem(n).DoStateChange(AOldState); 4115end; 4116 4117function TDBGBreakPoints.Find(const ASource: String; const ALine: Integer): TDBGBreakPoint; 4118begin 4119 Result := TDBGBreakPoint(inherited Find(Asource, ALine, nil)); 4120end; 4121 4122function TDBGBreakPoints.Find (const ASource: String; const ALine: Integer; const AIgnore: TDBGBreakPoint ): TDBGBreakPoint; 4123begin 4124 Result := TDBGBreakPoint(inherited Find(ASource, ALine, AIgnore)); 4125end; 4126 4127function TDBGBreakPoints.Find(const AAddress: TDBGPtr): TDBGBreakPoint; 4128begin 4129 Result := TDBGBreakPoint(inherited Find(AAddress)); 4130end; 4131 4132function TDBGBreakPoints.Find(const AAddress: TDBGPtr; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; 4133begin 4134 Result := TDBGBreakPoint(inherited Find(AAddress, nil)); 4135end; 4136 4137function TDBGBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; 4138 const AKind: TDBGWatchPointKind): TDBGBreakPoint; 4139begin 4140 Result := TDBGBreakPoint(inherited Find(AData, AScope, AKind, nil)); 4141end; 4142 4143function TDBGBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; 4144 const AKind: TDBGWatchPointKind; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; 4145begin 4146 Result := TDBGBreakPoint(inherited Find(AData, AScope, AKind, AIgnore)); 4147end; 4148 4149function TDBGBreakPoints.GetItem (const AnIndex: Integer ): TDBGBreakPoint; 4150begin 4151 Result := TDBGBreakPoint(inherited GetItem(AnIndex)); 4152end; 4153 4154procedure TDBGBreakPoints.SetItem (const AnIndex: Integer; const AValue: TDBGBreakPoint ); 4155begin 4156 inherited SetItem(AnIndex, AValue); 4157end; 4158 4159{ TDBGField } 4160 4161procedure TDBGField.IncRefCount; 4162begin 4163 inc(FRefCount); 4164end; 4165 4166procedure TDBGField.DecRefCount; 4167begin 4168 dec(FRefCount); 4169 if FRefCount <= 0 4170 then Self.Free; 4171end; 4172 4173constructor TDBGField.Create(const AName: String; ADBGType: TDBGType; 4174 ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags; AClassName: String = ''); 4175begin 4176 inherited Create; 4177 FName := AName; 4178 FLocation := ALocation; 4179 FDBGType := ADBGType; 4180 FFlags := AFlags; 4181 FRefCount := 0; 4182 FClassName := AClassName; 4183end; 4184 4185destructor TDBGField.Destroy; 4186begin 4187 FreeAndNil(FDBGType); 4188 inherited Destroy; 4189end; 4190 4191{ TDBGFields } 4192 4193constructor TDBGFields.Create; 4194begin 4195 FList := TList.Create; 4196 inherited; 4197end; 4198 4199destructor TDBGFields.Destroy; 4200var 4201 n: Integer; 4202begin 4203 for n := 0 to Count - 1 do 4204 Items[n].DecRefCount; 4205 4206 FreeAndNil(FList); 4207 inherited; 4208end; 4209 4210procedure TDBGFields.Add(const AField: TDBGField); 4211begin 4212 AField.IncRefCount; 4213 FList.Add(AField); 4214end; 4215 4216function TDBGFields.GetCount: Integer; 4217begin 4218 Result := FList.Count; 4219end; 4220 4221function TDBGFields.GetField(const AIndex: Integer): TDBGField; 4222begin 4223 Result := TDBGField(FList[AIndex]); 4224end; 4225 4226{ TDBGPTypes } 4227 4228constructor TDBGTypes.Create; 4229begin 4230 FList := TList.Create; 4231 inherited; 4232end; 4233 4234destructor TDBGTypes.Destroy; 4235var 4236 n: Integer; 4237begin 4238 for n := 0 to Count - 1 do 4239 Items[n].Free; 4240 4241 FreeAndNil(FList); 4242 inherited; 4243end; 4244 4245function TDBGTypes.GetCount: Integer; 4246begin 4247 Result := Flist.Count; 4248end; 4249 4250function TDBGTypes.GetType(const AIndex: Integer): TDBGType; 4251begin 4252 Result := TDBGType(FList[AIndex]); 4253end; 4254 4255{ TDBGPType } 4256 4257function TDBGType.GetFields: TDBGFields; 4258begin 4259 if FFields = nil then 4260 FFields := TDBGFields.Create; 4261 Result := FFields; 4262end; 4263 4264procedure TDBGType.Init; 4265begin 4266 // 4267end; 4268 4269constructor TDBGType.Create(AKind: TDBGSymbolKind; const ATypeName: String); 4270begin 4271 FKind := AKind; 4272 FTypeName := ATypeName; 4273 Init; 4274 inherited Create; 4275end; 4276 4277constructor TDBGType.Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType); 4278begin 4279 FKind := AKind; 4280 FArguments := AArguments; 4281 FResult := AResult; 4282 Init; 4283 inherited Create; 4284end; 4285 4286destructor TDBGType.Destroy; 4287begin 4288 FreeAndNil(FResult); 4289 FreeAndNil(FArguments); 4290 FreeAndNil(FFields); 4291 FreeAndNil(FMembers); 4292 inherited; 4293end; 4294 4295{ TWatchesSupplier } 4296 4297procedure TWatchesSupplier.RequestData(AWatchValue: TWatchValue); 4298begin 4299 if FNotifiedState in [dsPause, dsInternalPause] 4300 then InternalRequestData(AWatchValue) 4301 else AWatchValue.SetValidity(ddsInvalid); 4302end; 4303 4304function TWatchesSupplier.GetCurrentWatches: TWatches; 4305begin 4306 Result := Nil; 4307 if Monitor <> nil then 4308 Result := Monitor.Watches; 4309end; 4310 4311function TWatchesSupplier.GetMonitor: TWatchesMonitor; 4312begin 4313 Result := TWatchesMonitor(inherited Monitor); 4314end; 4315 4316procedure TWatchesSupplier.SetMonitor(AValue: TWatchesMonitor); 4317begin 4318 inherited Monitor := AValue; 4319end; 4320 4321procedure TWatchesSupplier.DoStateChange(const AOldState: TDBGState); 4322begin 4323 // workaround for state changes during TWatchValue.GetValue 4324 inc(DbgStateChangeCounter); 4325 if DbgStateChangeCounter = high(DbgStateChangeCounter) then DbgStateChangeCounter := 0; 4326 inherited DoStateChange(AOldState); 4327end; 4328 4329procedure TWatchesSupplier.InternalRequestData(AWatchValue: TWatchValue); 4330begin 4331 AWatchValue.SetValidity(ddsInvalid); 4332end; 4333 4334constructor TWatchesSupplier.Create(const ADebugger: TDebuggerIntf); 4335begin 4336 inherited Create(ADebugger); 4337 FNotifiedState := dsNone; 4338end; 4339 4340{ TWatchesMonitor } 4341 4342function TWatchesMonitor.GetSupplier: TWatchesSupplier; 4343begin 4344 Result := TWatchesSupplier(inherited Supplier); 4345end; 4346 4347procedure TWatchesMonitor.SetSupplier(AValue: TWatchesSupplier); 4348begin 4349 inherited Supplier := AValue; 4350end; 4351 4352function TWatchesMonitor.CreateWatches: TWatches; 4353begin 4354 Result := TWatches.Create; 4355end; 4356 4357constructor TWatchesMonitor.Create; 4358begin 4359 FWatches := CreateWatches; 4360 inherited Create; 4361end; 4362 4363destructor TWatchesMonitor.Destroy; 4364begin 4365 inherited Destroy; 4366 FreeAndNil(FWatches); 4367end; 4368 4369{ TLocalsSupplier } 4370 4371function TLocalsSupplier.GetCurrentLocalsList: TLocalsList; 4372begin 4373 Result := nil; 4374 if Monitor <> nil then 4375 Result := Monitor.LocalsList; 4376end; 4377 4378function TLocalsSupplier.GetMonitor: TLocalsMonitor; 4379begin 4380 Result := TLocalsMonitor(inherited Monitor); 4381end; 4382 4383procedure TLocalsSupplier.SetMonitor(AValue: TLocalsMonitor); 4384begin 4385 inherited Monitor := AValue; 4386end; 4387 4388procedure TLocalsSupplier.RequestData(ALocals: TLocals); 4389begin 4390 ALocals.SetDataValidity(ddsInvalid) 4391end; 4392 4393{ TLocalsMonitor } 4394 4395function TLocalsMonitor.GetSupplier: TLocalsSupplier; 4396begin 4397 Result := TLocalsSupplier(inherited Supplier); 4398end; 4399 4400procedure TLocalsMonitor.SetSupplier(AValue: TLocalsSupplier); 4401begin 4402 inherited Supplier := AValue; 4403end; 4404 4405function TLocalsMonitor.CreateLocalsList: TLocalsList; 4406begin 4407 Result := TLocalsList.Create; 4408end; 4409 4410constructor TLocalsMonitor.Create; 4411begin 4412 FLocalsList := CreateLocalsList; 4413 FLocalsList.AddReference; 4414 inherited Create; 4415end; 4416 4417destructor TLocalsMonitor.Destroy; 4418begin 4419 inherited Destroy; 4420 ReleaseRefAndNil(FLocalsList); 4421end; 4422 4423{ TBaseLineInfo } 4424 4425function TBaseLineInfo.GetSource(const AnIndex: integer): String; 4426begin 4427 Result := ''; 4428end; 4429 4430function TBaseLineInfo.IndexOf(const ASource: String): integer; 4431begin 4432 Result := -1; 4433end; 4434 4435constructor TBaseLineInfo.Create; 4436begin 4437 inherited Create; 4438end; 4439 4440function TBaseLineInfo.HasAddress(const ASource: String; const ALine: Integer 4441 ): Boolean; 4442var 4443 idx: Integer; 4444begin 4445 idx := IndexOf(ASource); 4446 if idx = -1 4447 then Result := False 4448 else Result := HasAddress(idx, ALine); 4449end; 4450 4451function TBaseLineInfo.GetInfo(AAddress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean; 4452begin 4453 Result := False; 4454end; 4455 4456procedure TBaseLineInfo.Request(const ASource: String); 4457begin 4458end; 4459 4460procedure TBaseLineInfo.Cancel(const ASource: String); 4461begin 4462 4463end; 4464 4465function TBaseLineInfo.Count: Integer; 4466begin 4467 Result := 0; 4468end; 4469 4470function TBaseLineInfo.HasAddress(const AIndex: Integer; const ALine: Integer 4471 ): Boolean; 4472begin 4473 Result := False; 4474end; 4475 4476{ TDBGLineInfo } 4477 4478procedure TDBGLineInfo.Changed(ASource: String); 4479begin 4480 DoChange(ASource); 4481end; 4482 4483procedure TDBGLineInfo.DoChange(ASource: String); 4484begin 4485 if Assigned(FOnChange) then FOnChange(Self, ASource); 4486end; 4487 4488procedure TDBGLineInfo.DoStateChange(const AOldState: TDBGState); 4489begin 4490end; 4491 4492constructor TDBGLineInfo.Create(const ADebugger: TDebuggerIntf); 4493begin 4494 inherited Create; 4495 FDebugger := ADebugger; 4496end; 4497 4498{ TCallStackEntry } 4499 4500function TCallStackEntry.GetArgumentCount: Integer; 4501begin 4502 Result := FArguments.Count; 4503end; 4504 4505function TCallStackEntry.GetArgumentName(const AnIndex: Integer): String; 4506begin 4507 Result := FArguments.Names[AnIndex]; 4508end; 4509 4510function TCallStackEntry.GetArgumentValue(const AnIndex: Integer): String; 4511begin 4512 Result := FArguments[AnIndex]; 4513 Result := GetPart('=', '', Result); 4514end; 4515 4516function TCallStackEntry.GetFunctionName: String; 4517begin 4518 Result := FFunctionName; 4519end; 4520 4521function TCallStackEntry.GetSource: String; 4522begin 4523 Result := ''; 4524end; 4525 4526function TCallStackEntry.GetValidity: TDebuggerDataState; 4527begin 4528 Result := FValidity; 4529end; 4530 4531procedure TCallStackEntry.SetValidity(AValue: TDebuggerDataState); 4532begin 4533 FValidity := AValue; 4534end; 4535 4536procedure TCallStackEntry.ClearLocation; 4537begin 4538 InitFields(0, 0, nil, '', 0, Validity); 4539 if Arguments <> nil then 4540 Arguments.Clear; 4541end; 4542 4543procedure TCallStackEntry.InitFields(const AIndex: Integer; const AnAddress: TDbgPtr; 4544 const AnArguments: TStrings; const AFunctionName: String; const ALine: Integer; 4545 AValidity: TDebuggerDataState); 4546begin 4547 FIndex := AIndex; 4548 FAddress := AnAddress; 4549 if AnArguments <> nil 4550 then FArguments.Assign(AnArguments); 4551 FFunctionName := AFunctionName; 4552 FLine := ALine; 4553 FValidity := AValidity; 4554end; 4555 4556constructor TCallStackEntry.Create; 4557begin 4558 inherited Create; 4559 FArguments := TStringlist.Create; 4560end; 4561 4562function TCallStackEntry.CreateCopy: TCallStackEntry; 4563begin 4564 Result := TCallStackEntry.Create; 4565 Result.Assign(Self); 4566end; 4567 4568destructor TCallStackEntry.Destroy; 4569begin 4570 inherited Destroy; 4571 FreeAndNil(FArguments); 4572end; 4573 4574procedure TCallStackEntry.Assign(AnOther: TCallStackEntry); 4575begin 4576 FValidity := AnOther.FValidity; 4577 FIndex := AnOther.FIndex; 4578 FAddress := AnOther.FAddress; 4579 FFunctionName := AnOther.FFunctionName; 4580 FLine := AnOther.FLine; 4581 FArguments.Assign(AnOther.FArguments); 4582end; 4583 4584procedure TCallStackEntry.Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; 4585 const AFunctionName: String; const AUnitName, AClassName, AProcName, AFunctionArgs: String; 4586 const ALine: Integer; AState: TDebuggerDataState); 4587begin 4588 InitFields(FIndex, AnAddress, AnArguments, AFunctionName, ALine, AState); 4589end; 4590 4591procedure TCallStackEntry.Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; 4592 const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; 4593 AState: TDebuggerDataState); 4594begin 4595 InitFields(FIndex, AnAddress, AnArguments, AFunctionName, ALine, AState); 4596end; 4597 4598function TCallStackEntry.GetFunctionWithArg: String; 4599var 4600 S: String; 4601 m: Integer; 4602begin 4603 S := ''; 4604 for m := 0 to ArgumentCount - 1 do 4605 begin 4606 if S <> '' then 4607 S := S + ', '; 4608 S := S + ArgumentValues[m]; 4609 end; 4610 if S <> '' then 4611 S := '(' + S + ')'; 4612 Result := FunctionName + S; 4613end; 4614 4615{ TCallStackList } 4616 4617function TCallStackList.GetEntry(const AIndex: Integer): TCallStackBase; 4618begin 4619 Result := TCallStackBase(FList[AIndex]); 4620end; 4621 4622function TCallStackList.GetEntryForThread(const AThreadId: Integer): TCallStackBase; 4623var 4624 i: Integer; 4625begin 4626 i := Count - 1; 4627 while (i >= 0) and (TCallStackBase(FList[i]).ThreadId <> AThreadId) do dec(i); 4628 if i >= 0 4629 then Result := TCallStackBase(FList[i]) 4630 else Result := NewEntryForThread(AThreadId); 4631end; 4632 4633function TCallStackList.NewEntryForThread(const AThreadId: Integer): TCallStackBase; 4634begin 4635 Result := nil; 4636end; 4637 4638constructor TCallStackList.Create; 4639begin 4640 FList := TList.Create; 4641end; 4642 4643destructor TCallStackList.Destroy; 4644begin 4645 inherited Destroy; 4646 Clear; 4647 FreeAndNil(FList); 4648end; 4649 4650procedure TCallStackList.Assign(AnOther: TCallStackList); 4651var 4652 i: Integer; 4653begin 4654 Clear; 4655 for i := 0 to AnOther.FList.Count-1 do 4656 FList.Add(TCallStackBase(AnOther.FList[i]).CreateCopy); 4657end; 4658 4659procedure TCallStackList.Add(ACallStack: TCallStackBase); 4660begin 4661 FList.Add(ACallStack); 4662end; 4663 4664procedure TCallStackList.Clear; 4665begin 4666 while FList.Count > 0 do begin 4667 TObject(FList[0]).Free; 4668 FList.Delete(0); 4669 end; 4670end; 4671 4672function TCallStackList.Count: Integer; 4673begin 4674 Result := FList.Count; 4675end; 4676 4677{ TCallStackSupplier } 4678 4679procedure TCallStackSupplier.Changed; 4680begin 4681 DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.Changed']); 4682 Monitor.DoModified; 4683end; 4684 4685function TCallStackSupplier.GetCurrentCallStackList: TCallStackList; 4686begin 4687 Result := nil; 4688 if Monitor <> nil then 4689 Result := Monitor.CallStackList; 4690end; 4691 4692function TCallStackSupplier.GetMonitor: TCallStackMonitor; 4693begin 4694 Result := TCallStackMonitor(inherited Monitor); 4695end; 4696 4697procedure TCallStackSupplier.SetMonitor(AValue: TCallStackMonitor); 4698begin 4699 inherited Monitor := AValue; 4700end; 4701 4702procedure TCallStackSupplier.RequestCount(ACallstack: TCallStackBase); 4703begin 4704 ACallstack.SetCountValidity(ddsInvalid); 4705end; 4706 4707procedure TCallStackSupplier.RequestAtLeastCount(ACallstack: TCallStackBase; 4708 ARequiredMinCount: Integer); 4709begin 4710 RequestCount(ACallstack); 4711end; 4712 4713procedure TCallStackSupplier.RequestCurrent(ACallstack: TCallStackBase); 4714begin 4715 ACallstack.SetCurrentValidity(ddsInvalid); 4716end; 4717 4718procedure TCallStackSupplier.RequestEntries(ACallstack: TCallStackBase); 4719var 4720 e: TCallStackEntry; 4721 It: TMapIterator; 4722begin 4723 DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.RequestEntries']); 4724 It := TMapIterator.Create(ACallstack.RawEntries); 4725 4726 if not It.Locate(ACallstack.LowestUnknown ) 4727 then if not It.EOM 4728 then It.Next; 4729 4730 while (not IT.EOM) and (TCallStackEntry(It.DataPtr^).Index < ACallstack.HighestUnknown) 4731 do begin 4732 e := TCallStackEntry(It.DataPtr^); 4733 if e.Validity = ddsRequested then e.Validity := ddsInvalid; 4734 It.Next; 4735 end; 4736 It.Free; 4737 4738 if Monitor <> nil then 4739 ACallstack.DoEntriesUpdated; // calls Monitor.DoModified; 4740 //Monitor.DoModified; 4741end; 4742 4743//procedure TCallStackSupplier.CurrentChanged; 4744//begin 4745// DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.CurrentChanged']); 4746// if Monitor <> nil 4747// then Monitor.NotifyCurrent; 4748//end; 4749 4750procedure TCallStackSupplier.UpdateCurrentIndex; 4751begin 4752 // 4753end; 4754 4755{ TCallStackMonitor } 4756 4757function TCallStackMonitor.GetSupplier: TCallStackSupplier; 4758begin 4759 Result := TCallStackSupplier(inherited Supplier); 4760end; 4761 4762procedure TCallStackMonitor.SetSupplier(AValue: TCallStackSupplier); 4763begin 4764 inherited Supplier := AValue; 4765end; 4766 4767function TCallStackMonitor.CreateCallStackList: TCallStackList; 4768begin 4769 Result := TCallStackList.Create; 4770end; 4771 4772constructor TCallStackMonitor.Create; 4773begin 4774 FCallStackList := CreateCallStackList; 4775 inherited Create; 4776end; 4777 4778destructor TCallStackMonitor.Destroy; 4779begin 4780 inherited Destroy; 4781 FreeAndNil(FCallStackList); 4782end; 4783 4784{ TThreadsSupplier } 4785 4786procedure TThreadsSupplier.Changed; 4787begin 4788 if Monitor <> nil 4789 then Monitor.DoModified; 4790end; 4791 4792function TThreadsSupplier.GetCurrentThreads: TThreads; 4793begin 4794 Result := nil; 4795 if Monitor <> nil then 4796 Result := Monitor.Threads; 4797end; 4798 4799function TThreadsSupplier.GetMonitor: TThreadsMonitor; 4800begin 4801 Result := TThreadsMonitor(inherited Monitor); 4802end; 4803 4804procedure TThreadsSupplier.SetMonitor(AValue: TThreadsMonitor); 4805begin 4806 inherited Monitor := AValue; 4807end; 4808 4809procedure TThreadsSupplier.ChangeCurrentThread(ANewId: Integer); 4810begin 4811 // 4812end; 4813 4814procedure TThreadsSupplier.RequestMasterData; 4815begin 4816 // 4817end; 4818 4819procedure TThreadsSupplier.DoStateChange(const AOldState: TDBGState); 4820begin 4821 if (Debugger.State = dsStop) and (CurrentThreads <> nil) then 4822 CurrentThreads.Clear; 4823 inherited DoStateChange(AOldState); 4824end; 4825 4826procedure TThreadsSupplier.DoStateLeavePauseClean; 4827begin 4828 DoCleanAfterPause; 4829end; 4830 4831procedure TThreadsSupplier.DoCleanAfterPause; 4832begin 4833 if CurrentThreads <> nil then 4834 CurrentThreads.Clear; 4835 if Monitor <> nil then 4836 Monitor.DoModified; 4837end; 4838 4839{ =========================================================================== } 4840{ TBaseSignal } 4841{ =========================================================================== } 4842 4843procedure TBaseSignal.AssignTo(Dest: TPersistent); 4844begin 4845 if Dest is TBaseSignal 4846 then begin 4847 TBaseSignal(Dest).Name := FName; 4848 TBaseSignal(Dest).ID := FID; 4849 TBaseSignal(Dest).HandledByDebugger := FHandledByDebugger; 4850 TBaseSignal(Dest).ResumeHandled := FResumeHandled; 4851 end 4852 else inherited AssignTo(Dest); 4853end; 4854 4855constructor TBaseSignal.Create(ACollection: TCollection); 4856begin 4857 FID := 0; 4858 FHandledByDebugger := False; 4859 FResumeHandled := True; 4860 inherited Create(ACollection); 4861end; 4862 4863procedure TBaseSignal.SetHandledByDebugger(const AValue: Boolean); 4864begin 4865 if AValue = FHandledByDebugger then Exit; 4866 FHandledByDebugger := AValue; 4867 Changed; 4868end; 4869 4870procedure TBaseSignal.SetID (const AValue: Integer ); 4871begin 4872 if FID = AValue then Exit; 4873 FID := AValue; 4874 Changed; 4875end; 4876 4877procedure TBaseSignal.SetName (const AValue: String ); 4878begin 4879 if FName = AValue then Exit; 4880 FName := AValue; 4881 Changed; 4882end; 4883 4884procedure TBaseSignal.SetResumeHandled(const AValue: Boolean); 4885begin 4886 if FResumeHandled = AValue then Exit; 4887 FResumeHandled := AValue; 4888 Changed; 4889end; 4890 4891{ =========================================================================== } 4892{ TDBGSignal } 4893{ =========================================================================== } 4894 4895function TDBGSignal.GetDebugger: TDebuggerIntf; 4896begin 4897 Result := TDBGSignals(Collection).FDebugger; 4898end; 4899 4900{ =========================================================================== } 4901{ TBaseSignals } 4902{ =========================================================================== } 4903 4904function TBaseSignals.Add (const AName: String; AID: Integer ): TBaseSignal; 4905begin 4906 Result := TBaseSignal(inherited Add); 4907 Result.BeginUpdate; 4908 try 4909 Result.Name := AName; 4910 Result.ID := AID; 4911 finally 4912 Result.EndUpdate; 4913 end; 4914end; 4915 4916constructor TBaseSignals.Create (const AItemClass: TBaseSignalClass ); 4917begin 4918 inherited Create(AItemClass); 4919end; 4920 4921procedure TBaseSignals.Reset; 4922begin 4923 Clear; 4924end; 4925 4926function TBaseSignals.Find(const AName: String): TBaseSignal; 4927var 4928 n: Integer; 4929 S: String; 4930begin 4931 S := UpperCase(AName); 4932 for n := 0 to Count - 1 do 4933 begin 4934 Result := TBaseSignal(GetItem(n)); 4935 if UpperCase(Result.Name) = S 4936 then Exit; 4937 end; 4938 Result := nil; 4939end; 4940 4941{ =========================================================================== } 4942{ TDBGSignals } 4943{ =========================================================================== } 4944 4945function TDBGSignals.Add(const AName: String; AID: Integer): TDBGSignal; 4946begin 4947 Result := TDBGSignal(inherited Add(AName, AID)); 4948end; 4949 4950constructor TDBGSignals.Create(const ADebugger: TDebuggerIntf; 4951 const ASignalClass: TDBGSignalClass); 4952begin 4953 FDebugger := ADebugger; 4954 inherited Create(ASignalClass); 4955end; 4956 4957function TDBGSignals.Find(const AName: String): TDBGSignal; 4958begin 4959 Result := TDBGSignal(inherited Find(ANAme)); 4960end; 4961 4962function TDBGSignals.GetItem(const AIndex: Integer): TDBGSignal; 4963begin 4964 Result := TDBGSignal(inherited GetItem(AIndex)); 4965end; 4966 4967procedure TDBGSignals.SetItem(const AIndex: Integer; const AValue: TDBGSignal); 4968begin 4969 inherited SetItem(AIndex, AValue); 4970end; 4971 4972{ =========================================================================== } 4973{ TBaseException } 4974{ =========================================================================== } 4975 4976procedure TBaseException.SetEnabled(AValue: Boolean); 4977begin 4978 if FEnabled = AValue then Exit; 4979 FEnabled := AValue; 4980 Changed; 4981end; 4982 4983procedure TBaseException.AssignTo(Dest: TPersistent); 4984begin 4985 if Dest is TBaseException 4986 then begin 4987 TBaseException(Dest).Name := FName; 4988 end 4989 else inherited AssignTo(Dest); 4990end; 4991 4992constructor TBaseException.Create(ACollection: TCollection); 4993begin 4994 inherited Create(ACollection); 4995end; 4996 4997procedure TBaseException.SetName(const AValue: String); 4998begin 4999 if FName = AValue then exit; 5000 5001 if TBaseExceptions(GetOwner).Find(AValue) <> nil 5002 then raise EDBGExceptions.Create('Duplicate name: ' + AValue); 5003 5004 FName := AValue; 5005 Changed; 5006end; 5007 5008{ =========================================================================== } 5009{ TBaseExceptions } 5010{ =========================================================================== } 5011 5012function TBaseExceptions.Add(const AName: String): TBaseException; 5013begin 5014 Result := TBaseException(inherited Add); 5015 Result.Name := AName; 5016end; 5017 5018constructor TBaseExceptions.Create(const AItemClass: TBaseExceptionClass); 5019begin 5020 inherited Create(AItemClass); 5021 FIgnoreAll := False; 5022end; 5023 5024destructor TBaseExceptions.Destroy; 5025begin 5026 ClearExceptions; 5027 inherited Destroy; 5028end; 5029 5030procedure TBaseExceptions.Reset; 5031begin 5032 ClearExceptions; 5033 FIgnoreAll := False; 5034end; 5035 5036function TBaseExceptions.Find(const AName: String): TBaseException; 5037var 5038 n: Integer; 5039 S: String; 5040begin 5041 S := UpperCase(AName); 5042 for n := 0 to Count - 1 do 5043 begin 5044 Result := TBaseException(GetItem(n)); 5045 if UpperCase(Result.Name) = S 5046 then Exit; 5047 end; 5048 Result := nil; 5049end; 5050 5051function TBaseExceptions.GetItem(const AIndex: Integer): TBaseException; 5052begin 5053 Result := TBaseException(inherited GetItem(AIndex)); 5054end; 5055 5056procedure TBaseExceptions.SetItem(const AIndex: Integer; AValue: TBaseException); 5057begin 5058 inherited SetItem(AIndex, AValue); 5059end; 5060 5061procedure TBaseExceptions.ClearExceptions; 5062begin 5063 while Count>0 do 5064 TBaseException(GetItem(Count-1)).Free; 5065end; 5066 5067procedure TBaseExceptions.SetIgnoreAll(const AValue: Boolean); 5068begin 5069 if FIgnoreAll = AValue then exit; 5070 FIgnoreAll := AValue; 5071 Changed; 5072end; 5073 5074procedure TBaseExceptions.AssignTo(Dest: TPersistent); 5075begin 5076 if Dest is TBaseExceptions 5077 then begin 5078 TBaseExceptions(Dest).IgnoreAll := IgnoreAll; 5079 end 5080 else inherited AssignTo(Dest); 5081end; 5082 5083{ TBaseDisassembler } 5084 5085procedure TBaseDisassembler.IndexError(AIndex: Integer); 5086begin 5087 raise EInvalidOperation.CreateFmt('Index out of range (%d)', [AIndex]); 5088end; 5089 5090function TBaseDisassembler.GetEntryPtr(AIndex: Integer): PDisassemblerEntry; 5091begin 5092 if (AIndex < -FCountBefore) 5093 or (AIndex >= FCountAfter) then IndexError(Aindex); 5094 5095 Result := InternalGetEntryPtr(AIndex); 5096end; 5097 5098function TBaseDisassembler.GetEntry(AIndex: Integer): TDisassemblerEntry; 5099begin 5100 if (AIndex < -FCountBefore) 5101 or (AIndex >= FCountAfter) then IndexError(Aindex); 5102 5103 Result := InternalGetEntry(AIndex); 5104end; 5105 5106function TBaseDisassembler.InternalGetEntry(AIndex: Integer): TDisassemblerEntry; 5107begin 5108 Result.Addr := 0; 5109 Result.Offset := 0; 5110 Result.SrcFileLine := 0; 5111 Result.SrcStatementIndex := 0; 5112 Result.SrcStatementCount := 0; 5113end; 5114 5115function TBaseDisassembler.InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; 5116begin 5117 Result := nil; 5118end; 5119 5120procedure TBaseDisassembler.DoChanged; 5121begin 5122 // nothing 5123end; 5124 5125procedure TBaseDisassembler.Changed; 5126begin 5127 if FChangedLockCount > 0 5128 then begin 5129 FIsChanged := True; 5130 exit; 5131 end; 5132 FIsChanged := False; 5133 DoChanged; 5134end; 5135 5136procedure TBaseDisassembler.LockChanged; 5137begin 5138 inc(FChangedLockCount); 5139end; 5140 5141procedure TBaseDisassembler.UnlockChanged; 5142begin 5143 dec(FChangedLockCount); 5144 if FIsChanged and (FChangedLockCount = 0) 5145 then Changed; 5146end; 5147 5148procedure TBaseDisassembler.InternalIncreaseCountBefore(ACount: Integer); 5149begin 5150 // increase count withou change notification 5151 if ACount < FCountBefore 5152 then begin 5153 debugln(DBG_DISASSEMBLER, ['WARNING: TBaseDisassembler.InternalIncreaseCountBefore will decrease was ', FCountBefore , ' new=',ACount]); 5154 SetCountBefore(ACount); 5155 end 5156 else FCountBefore := ACount; 5157end; 5158 5159procedure TBaseDisassembler.InternalIncreaseCountAfter(ACount: Integer); 5160begin 5161 // increase count withou change notification 5162 if ACount < FCountAfter 5163 then begin 5164 debugln(DBG_DISASSEMBLER, ['WARNING: TBaseDisassembler.InternalIncreaseCountAfter will decrease was ', FCountAfter , ' new=',ACount]); 5165 SetCountAfter(ACount) 5166 end 5167 else FCountAfter := ACount; 5168end; 5169 5170procedure TBaseDisassembler.SetCountBefore(ACount: Integer); 5171begin 5172 if FCountBefore = ACount 5173 then exit; 5174 FCountBefore := ACount; 5175 Changed; 5176end; 5177 5178procedure TBaseDisassembler.SetCountAfter(ACount: Integer); 5179begin 5180 if FCountAfter = ACount 5181 then exit; 5182 FCountAfter := ACount; 5183 Changed; 5184end; 5185 5186procedure TBaseDisassembler.SetBaseAddr(AnAddr: TDbgPtr); 5187begin 5188 if FBaseAddr = AnAddr 5189 then exit; 5190 FBaseAddr := AnAddr; 5191 Changed; 5192end; 5193 5194constructor TBaseDisassembler.Create; 5195begin 5196 Clear; 5197 FChangedLockCount := 0; 5198end; 5199 5200destructor TBaseDisassembler.Destroy; 5201begin 5202 inherited Destroy; 5203 Clear; 5204end; 5205 5206procedure TBaseDisassembler.Clear; 5207begin 5208 FCountAfter := 0; 5209 FCountBefore := 0; 5210 FBaseAddr := 0; 5211end; 5212 5213function TBaseDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore, 5214 ALinesAfter: Integer): Boolean; 5215begin 5216 Result := False; 5217end; 5218 5219{ TDBGDisassemblerEntryRange } 5220 5221function TDBGDisassemblerEntryRange.GetEntry(Index: Integer): TDisassemblerEntry; 5222begin 5223 if (Index < 0) or (Index >= FCount) 5224 then raise Exception.Create('Illegal Index'); 5225 Result := FEntries[Index]; 5226end; 5227 5228function TDBGDisassemblerEntryRange.GetCapacity: Integer; 5229begin 5230 Result := length(FEntries); 5231end; 5232 5233function TDBGDisassemblerEntryRange.GetEntryPtr(Index: Integer): PDisassemblerEntry; 5234begin 5235 if (Index < 0) or (Index >= FCount) 5236 then raise Exception.Create('Illegal Index'); 5237 Result := @FEntries[Index]; 5238end; 5239 5240procedure TDBGDisassemblerEntryRange.SetCapacity(const AValue: Integer); 5241begin 5242 SetLength(FEntries, AValue); 5243 if FCount >= AValue 5244 then FCount := AValue - 1; 5245end; 5246 5247procedure TDBGDisassemblerEntryRange.SetCount(const AValue: Integer); 5248begin 5249 if FCount = AValue then exit; 5250 if AValue >= Capacity 5251 then Capacity := AValue + Max(20, AValue div 4); 5252 5253 FCount := AValue; 5254end; 5255 5256procedure TDBGDisassemblerEntryRange.Clear; 5257begin 5258 SetCapacity(0); 5259 FCount := 0; 5260end; 5261 5262function TDBGDisassemblerEntryRange.Append(const AnEntryPtr: PDisassemblerEntry): Integer; 5263begin 5264 if FCount >= Capacity 5265 then Capacity := FCount + Max(20,FCount div 4); 5266 5267 FEntries[FCount] := AnEntryPtr^; 5268 Result := FCount; 5269 inc(FCount); 5270end; 5271 5272procedure TDBGDisassemblerEntryRange.Merge(const AnotherRange: TDBGDisassemblerEntryRange); 5273var 5274 i, j: Integer; 5275 a: TDBGPtr; 5276begin 5277 if AnotherRange.RangeStartAddr < RangeStartAddr then 5278 begin 5279 // merge before 5280 i := AnotherRange.Count - 1; 5281 a := FirstAddr; 5282 while (i >= 0) and (AnotherRange.EntriesPtr[i]^.Addr >= a) 5283 do dec(i); 5284 inc(i); 5285 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge: Merged to START: Other=', dbgs(AnotherRange), ' To other index=', i, ' INTO self=', dbgs(self) ]); 5286 if Capacity < Count + i 5287 then Capacity := Count + i; 5288 for j := Count-1 downto 0 do 5289 FEntries[j+i] := FEntries[j]; 5290 for j := 0 to i - 1 do 5291 FEntries[j] := AnotherRange.FEntries[j]; 5292 FCount := FCount + i; 5293 FRangeStartAddr := AnotherRange.FRangeStartAddr; 5294 end 5295 else begin 5296 // merge after 5297 a:= LastAddr; 5298 i := 0; 5299 while (i < AnotherRange.Count) and (AnotherRange.EntriesPtr[i]^.Addr <= a) 5300 do inc(i); 5301 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge to END: Other=', dbgs(AnotherRange), ' From other index=', i, ' INTO self=', dbgs(self) ]); 5302 if Capacity < Count + AnotherRange.Count - i 5303 then Capacity := Count + AnotherRange.Count - i; 5304 for j := 0 to AnotherRange.Count - i - 1 do 5305 FEntries[Count + j] := AnotherRange.FEntries[i + j]; 5306 FCount := FCount + AnotherRange.Count - i; 5307 FRangeEndAddr := AnotherRange.FRangeEndAddr; 5308 FLastEntryEndAddr := AnotherRange.FLastEntryEndAddr; 5309 if FRangeStartAddr = 0 then 5310 FRangeStartAddr := AnotherRange.FRangeStartAddr; 5311 end; 5312 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge AFTER MERGE: ', dbgs(self) ]); 5313end; 5314 5315function TDBGDisassemblerEntryRange.FirstAddr: TDbgPtr; 5316begin 5317 if FCount = 0 5318 then exit(0); 5319 Result := FEntries[0].Addr; 5320end; 5321 5322function TDBGDisassemblerEntryRange.LastAddr: TDbgPtr; 5323begin 5324 if FCount = 0 5325 then exit(0); 5326 Result := FEntries[FCount-1].Addr; 5327end; 5328 5329function TDBGDisassemblerEntryRange.ContainsAddr(const AnAddr: TDbgPtr; 5330 IncludeNextAddr: Boolean = False): Boolean; 5331begin 5332 if IncludeNextAddr 5333 then Result := (AnAddr >= RangeStartAddr) and (AnAddr <= RangeEndAddr) 5334 else Result := (AnAddr >= RangeStartAddr) and (AnAddr < RangeEndAddr); 5335end; 5336 5337function TDBGDisassemblerEntryRange.IndexOfAddr(const AnAddr: TDbgPtr): Integer; 5338begin 5339 Result := FCount - 1; 5340 while Result >= 0 do begin 5341 if FEntries[Result].Addr = AnAddr 5342 then exit; 5343 dec(Result); 5344 end; 5345end; 5346 5347function TDBGDisassemblerEntryRange.IndexOfAddrWithOffs(const AnAddr: TDbgPtr): Integer; 5348var 5349 O: Integer; 5350begin 5351 Result := IndexOfAddrWithOffs(AnAddr, O); 5352end; 5353 5354function TDBGDisassemblerEntryRange.IndexOfAddrWithOffs(const AnAddr: TDbgPtr; out 5355 AOffs: Integer): Integer; 5356begin 5357 Result := FCount - 1; 5358 while Result >= 0 do begin 5359 if FEntries[Result].Addr <= AnAddr 5360 then break; 5361 dec(Result); 5362 end; 5363 If Result < 0 5364 then AOffs := 0 5365 else AOffs := AnAddr - FEntries[Result].Addr; 5366end; 5367 5368{ TDBGDisassemblerEntryMapIterator } 5369 5370function TDBGDisassemblerEntryMapIterator.GetRangeForAddr(AnAddr: TDbgPtr; 5371 IncludeNextAddr: Boolean): TDBGDisassemblerEntryRange; 5372begin 5373 Result := nil; 5374 if not Locate(AnAddr) 5375 then if not BOM 5376 then Previous; 5377 5378 if BOM 5379 then exit; 5380 5381 GetData(Result); 5382 if not Result.ContainsAddr(AnAddr, IncludeNextAddr) 5383 then Result := nil; 5384end; 5385 5386function TDBGDisassemblerEntryMapIterator.NextRange: TDBGDisassemblerEntryRange; 5387begin 5388 Result := nil; 5389 if EOM 5390 then exit; 5391 5392 Next; 5393 if not EOM 5394 then GetData(Result); 5395end; 5396 5397function TDBGDisassemblerEntryMapIterator.PreviousRange: TDBGDisassemblerEntryRange; 5398begin 5399 Result := nil; 5400 if BOM 5401 then exit; 5402 5403 Previous; 5404 if not BOM 5405 then GetData(Result); 5406end; 5407 5408{ TDBGDisassemblerEntryMap } 5409 5410procedure TDBGDisassemblerEntryMap.ReleaseData(ADataPtr: Pointer); 5411type 5412 PDBGDisassemblerEntryRange = ^TDBGDisassemblerEntryRange; 5413begin 5414 if FFreeItemLock 5415 then exit; 5416 if Assigned(FOnDelete) 5417 then FOnDelete(PDBGDisassemblerEntryRange(ADataPtr)^); 5418 PDBGDisassemblerEntryRange(ADataPtr)^.Free; 5419end; 5420 5421constructor TDBGDisassemblerEntryMap.Create(AIdType: TMapIdType; ADataSize: Cardinal); 5422begin 5423 inherited; 5424 FIterator := TDBGDisassemblerEntryMapIterator.Create(Self); 5425end; 5426 5427destructor TDBGDisassemblerEntryMap.Destroy; 5428begin 5429 FreeAndNil(FIterator); 5430 inherited Destroy; 5431end; 5432 5433procedure TDBGDisassemblerEntryMap.AddRange(const ARange: TDBGDisassemblerEntryRange); 5434var 5435 MergeRng, MergeRng2: TDBGDisassemblerEntryRange; 5436 OldId: TDBGPtr; 5437begin 5438 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryMap.AddRange ', dbgs(ARange), ' to map with count=', Count ]); 5439 if ARange.Count = 0 then begin 5440 ARange.Free; 5441 exit; 5442 end; 5443 5444 MergeRng := GetRangeForAddr(ARange.RangeStartAddr, True); 5445 if MergeRng <> nil then begin 5446 // merge to end ( ARange.RangeStartAddr >= MergeRng.RangeStartAddr ) 5447 // MergeRng keeps it's ID; 5448 MergeRng.Merge(ARange); 5449 if assigned(FOnMerge) 5450 then FOnMerge(MergeRng, ARange); 5451 ARange.Free; 5452 5453 MergeRng2 := GetRangeForAddr(MergeRng.RangeEndAddr, True); 5454 if (MergeRng2 <> nil) and (MergeRng2 <> MergeRng) then begin 5455 // MergeRng is located before MergeRng2 5456 // MergeRng2 merges to end of MergeRng ( No ID changes ) 5457 MergeRng.Merge(MergeRng2); 5458 if assigned(FOnMerge) 5459 then FOnMerge(MergeRng, MergeRng2); 5460 Delete(MergeRng2.RangeStartAddr); 5461 end; 5462 exit; 5463 end; 5464 5465 MergeRng := GetRangeForAddr(ARange.RangeEndAddr, True); 5466 if MergeRng <> nil then begin 5467 // merge to start ( ARange.RangeEndAddr is in MergeRng ) 5468 if MergeRng.ContainsAddr(ARange.RangeStartAddr) 5469 then begin 5470 debugln(['ERROR: New Range is completely inside existing ', dbgs(MergeRng)]); 5471 exit; 5472 end; 5473 // MergeRng changes ID 5474 OldId := MergeRng.RangeStartAddr; 5475 MergeRng.Merge(ARange); 5476 if assigned(FOnMerge) 5477 then FOnMerge(ARange, MergeRng); 5478 FFreeItemLock := True; // prevent destruction of MergeRng 5479 Delete(OldId); 5480 FFreeItemLock := False; 5481 Add(MergeRng.RangeStartAddr, MergeRng); 5482 ARange.Free; 5483 exit; 5484 end; 5485 5486 Add(ARange.RangeStartAddr, ARange); 5487end; 5488 5489function TDBGDisassemblerEntryMap.GetRangeForAddr(AnAddr: TDbgPtr; 5490 IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; 5491begin 5492 Result := FIterator.GetRangeForAddr(AnAddr, IncludeNextAddr); 5493end; 5494 5495{ TDBGDisassembler } 5496 5497procedure TDBGDisassembler.EntryRangesOnDelete(Sender: TObject); 5498begin 5499 if FCurrentRange <> Sender 5500 then exit; 5501 LockChanged; 5502 FCurrentRange := nil; 5503 SetBaseAddr(0); 5504 SetCountBefore(0); 5505 SetCountAfter(0); 5506 UnlockChanged; 5507end; 5508 5509procedure TDBGDisassembler.EntryRangesOnMerge(MergeReceiver, 5510 MergeGiver: TDBGDisassemblerEntryRange); 5511var 5512 i: LongInt; 5513 lb, la: Integer; 5514begin 5515 // no need to call changed, will be done by whoever triggered this 5516 if FCurrentRange = MergeGiver 5517 then FCurrentRange := MergeReceiver; 5518 5519 if FCurrentRange = MergeReceiver 5520 then begin 5521 i := FCurrentRange.IndexOfAddrWithOffs(BaseAddr); 5522 if i >= 0 5523 then begin 5524 InternalIncreaseCountBefore(i); 5525 InternalIncreaseCountAfter(FCurrentRange.Count - 1 - i); 5526 exit; 5527 end 5528 else if FCurrentRange.ContainsAddr(BaseAddr) 5529 then begin 5530 debugln(DBG_DISASSEMBLER, ['WARNING: TDBGDisassembler.OnMerge: Address at odd offset ',BaseAddr, ' before=',CountBefore, ' after=', CountAfter]); 5531 lb := CountBefore; 5532 la := CountAfter; 5533 if HandleRangeWithInvalidAddr(FCurrentRange, BaseAddr, lb, la) 5534 then begin 5535 InternalIncreaseCountBefore(lb); 5536 InternalIncreaseCountAfter(la); 5537 exit; 5538 end; 5539 end; 5540 5541 LockChanged; 5542 SetBaseAddr(0); 5543 SetCountBefore(0); 5544 SetCountAfter(0); 5545 UnlockChanged; 5546 end; 5547end; 5548 5549function TDBGDisassembler.FindRange(AnAddr: TDbgPtr; ALinesBefore, 5550 ALinesAfter: Integer): Boolean; 5551var 5552 i: LongInt; 5553 NewRange: TDBGDisassemblerEntryRange; 5554begin 5555 LockChanged; 5556 try 5557 Result := False; 5558 NewRange := FEntryRanges.GetRangeForAddr(AnAddr); 5559 5560 if (NewRange <> nil) 5561 and ( (NewRange.RangeStartAddr > AnAddr) or (NewRange.RangeEndAddr < AnAddr) ) 5562 then 5563 NewRange := nil; 5564 5565 if NewRange = nil 5566 then begin 5567 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.FindRange: Address not found ', AnAddr, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count ]); 5568 exit; 5569 end; 5570 5571 i := NewRange.IndexOfAddr(AnAddr); 5572 if i < 0 5573 then begin 5574 // address at incorrect offset 5575 Result := HandleRangeWithInvalidAddr(NewRange, AnAddr, ALinesBefore, ALinesAfter); 5576 debugln(DBG_DISASSEMBLER, ['WARNING: TDBGDisassembler.FindRange: Address at odd offset ',AnAddr,' Result=', dbgs(result), ' before=',CountBefore, ' after=', CountAfter, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count]); 5577 if Result 5578 then begin 5579 FCurrentRange := NewRange; 5580 SetBaseAddr(AnAddr); 5581 SetCountBefore(ALinesBefore); 5582 SetCountAfter(ALinesAfter); 5583 end; 5584 exit; 5585 end; 5586 5587 FCurrentRange := NewRange; 5588 SetBaseAddr(AnAddr); 5589 SetCountBefore(i); 5590 SetCountAfter(NewRange.Count - 1 - i); 5591 Result := (i >= ALinesBefore) and (CountAfter >= ALinesAfter); 5592 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.FindRange: Address found ',AnAddr,' Result=', dbgs(result), ' before=',CountBefore, ' after=', CountAfter, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count]); 5593 finally 5594 UnlockChanged; 5595 end; 5596end; 5597 5598procedure TDBGDisassembler.DoChanged; 5599begin 5600 inherited DoChanged; 5601 if assigned(FOnChange) 5602 then FOnChange(Self); 5603end; 5604 5605procedure TDBGDisassembler.Clear; 5606begin 5607 debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.Clear: map had count=', FEntryRanges.Count ]); 5608 FCurrentRange := nil; 5609 FEntryRanges.Clear; 5610 inherited Clear; 5611 Changed; 5612end; 5613 5614procedure TDBGDisassembler.DoStateChange(const AOldState: TDBGState); 5615begin 5616 if FDebugger.State = dsPause 5617 then begin 5618 Changed; 5619 end 5620 else begin 5621 if (AOldState = dsPause) or (AOldState = dsNone) { Force clear on initialisation } 5622 then Clear; 5623 end; 5624end; 5625 5626function TDBGDisassembler.InternalGetEntry(AIndex: Integer): TDisassemblerEntry; 5627begin 5628 Result := FCurrentRange.Entries[AIndex + CountBefore]; 5629end; 5630 5631function TDBGDisassembler.InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; 5632begin 5633 Result := FCurrentRange.EntriesPtr[AIndex + CountBefore]; 5634end; 5635 5636function TDBGDisassembler.PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, 5637 ALinesAfter: Integer): boolean; 5638begin 5639 Result := False; 5640end; 5641 5642function TDBGDisassembler.HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange; 5643 AnAddr: TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean; 5644begin 5645 Result := False; 5646 if ARange <> nil then 5647 FEntryRanges.Delete(ARange.RangeStartAddr); 5648end; 5649 5650constructor TDBGDisassembler.Create(const ADebugger: TDebuggerIntf); 5651begin 5652 FDebugger := ADebugger; 5653 FEntryRanges := TDBGDisassemblerEntryMap.Create(itu8, SizeOf(TDBGDisassemblerEntryRange)); 5654 FEntryRanges.OnDelete := @EntryRangesOnDelete; 5655 FEntryRanges.OnMerge := @EntryRangesOnMerge; 5656 inherited Create; 5657end; 5658 5659destructor TDBGDisassembler.Destroy; 5660begin 5661 inherited Destroy; 5662 FEntryRanges.OnDelete := nil; 5663 Clear; 5664 FreeAndNil(FEntryRanges); 5665end; 5666 5667function TDBGDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore, 5668 ALinesAfter: Integer): Boolean; 5669begin 5670 Result := False; 5671 if (Debugger = nil) or (Debugger.State <> dsPause) or (AnAddr = 0) 5672 then exit; 5673 if (ALinesBefore < 0) or (ALinesAfter < 0) 5674 then raise Exception.Create('invalid PrepareRange request'); 5675 5676 // Do not LockChange, if FindRange changes something, then notification must be send to syncronize counts on IDE-object 5677 Result:= FindRange(AnAddr, ALinesBefore, ALinesAfter); 5678 if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange found existing data Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); 5679 if Result 5680 then exit; 5681 5682 if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange calling PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); 5683 if PrepareEntries(AnAddr, ALinesBefore, ALinesAfter) 5684 then Result:= FindRange(AnAddr, ALinesBefore, ALinesAfter); 5685 if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange found data AFTER PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); 5686end; 5687 5688(******************************************************************************) 5689(******************************************************************************) 5690(** **) 5691(** D E B U G G E R **) 5692(** **) 5693(******************************************************************************) 5694(******************************************************************************) 5695 5696{ TDebuggerProperties } 5697 5698constructor TDebuggerProperties.Create; 5699begin 5700 // 5701end; 5702 5703procedure TDebuggerProperties.Assign(Source: TPersistent); 5704begin 5705 // 5706end; 5707 5708{ =========================================================================== } 5709{ TDebuggerIntf } 5710{ =========================================================================== } 5711 5712class function TDebuggerIntf.Caption: String; 5713begin 5714 Result := 'No caption set'; 5715end; 5716 5717function TDebuggerIntf.ChangeFileName: Boolean; 5718begin 5719 Result := True; 5720end; 5721 5722constructor TDebuggerIntf.Create(const AExternalDebugger: String); 5723var 5724 list: TStringList; 5725 nr: TDebuggerNotifyReason; 5726begin 5727 inherited Create; 5728 for nr := low(TDebuggerNotifyReason) to high(TDebuggerNotifyReason) do 5729 FDestroyNotificationList[nr] := TMethodList.Create; 5730 FOnState := nil; 5731 FOnCurrent := nil; 5732 FOnOutput := nil; 5733 FOnDbgOutput := nil; 5734 FState := dsNone; 5735 FArguments := ''; 5736 FFilename := ''; 5737 FExternalDebugger := AExternalDebugger; 5738 5739 list := TStringList.Create; 5740 list.OnChange := @DebuggerEnvironmentChanged; 5741 FDebuggerEnvironment := list; 5742 5743 list := TStringList.Create; 5744 list.OnChange := @EnvironmentChanged; 5745 FEnvironment := list; 5746 FCurEnvironment := TStringList.Create; 5747 //FInternalUnitInfoProvider := TDebuggerUnitInfoProvider.Create; 5748 5749 FBreakPoints := CreateBreakPoints; 5750 FLocals := CreateLocals; 5751 FLineInfo := CreateLineInfo; 5752 FRegisters := CreateRegisters; 5753 FCallStack := CreateCallStack; 5754 FDisassembler := CreateDisassembler; 5755 FWatches := CreateWatches; 5756 FThreads := CreateThreads; 5757 FSignals := CreateSignals; 5758 FExitCode := 0; 5759end; 5760 5761function TDebuggerIntf.CreateBreakPoints: TDBGBreakPoints; 5762begin 5763 Result := TDBGBreakPoints.Create(Self, TDBGBreakPoint); 5764end; 5765 5766function TDebuggerIntf.CreateCallStack: TCallStackSupplier; 5767begin 5768 Result := TCallStackSupplier.Create(Self); 5769end; 5770 5771function TDebuggerIntf.CreateDisassembler: TDBGDisassembler; 5772begin 5773 Result := TDBGDisassembler.Create(Self); 5774end; 5775 5776function TDebuggerIntf.CreateLocals: TLocalsSupplier; 5777begin 5778 Result := TLocalsSupplier.Create(Self); 5779end; 5780 5781function TDebuggerIntf.CreateLineInfo: TDBGLineInfo; 5782begin 5783 Result := TDBGLineInfo.Create(Self); 5784end; 5785 5786class function TDebuggerIntf.CreateProperties: TDebuggerProperties; 5787begin 5788 Result := TDebuggerProperties.Create; 5789end; 5790 5791function TDebuggerIntf.CreateRegisters: TRegisterSupplier; 5792begin 5793 Result := TRegisterSupplier.Create(Self); 5794end; 5795 5796function TDebuggerIntf.CreateSignals: TDBGSignals; 5797begin 5798 Result := TDBGSignals.Create(Self, TDBGSignal); 5799end; 5800 5801function TDebuggerIntf.CreateWatches: TWatchesSupplier; 5802begin 5803 Result := TWatchesSupplier.Create(Self); 5804end; 5805 5806function TDebuggerIntf.CreateThreads: TThreadsSupplier; 5807begin 5808 Result := TThreadsSupplier.Create(Self); 5809end; 5810 5811procedure TDebuggerIntf.DebuggerEnvironmentChanged (Sender: TObject ); 5812begin 5813end; 5814 5815destructor TDebuggerIntf.Destroy; 5816var 5817 nr: TDebuggerNotifyReason; 5818begin 5819 FDestroyNotificationList[dnrDestroy].CallNotifyEvents(Self); 5820 for nr := low(TDebuggerNotifyReason) to high(TDebuggerNotifyReason) do 5821 FreeAndNil(FDestroyNotificationList[nr]); 5822 // don't call events 5823 FOnState := nil; 5824 FOnCurrent := nil; 5825 FOnOutput := nil; 5826 FOnDbgOutput := nil; 5827 5828 if FState <> dsNone 5829 then Done; 5830 5831 FBreakPoints.Debugger := nil; 5832 FLocals.Debugger := nil; 5833 FLineInfo.Debugger := nil; 5834 FRegisters.Debugger := nil; 5835 FCallStack.Debugger := nil; 5836 FDisassembler.Debugger := nil; 5837 FWatches.Debugger := nil; 5838 FThreads.Debugger := nil; 5839 5840 //FreeAndNil(FInternalUnitInfoProvider); 5841 FreeAndNil(FBreakPoints); 5842 FreeAndNil(FLocals); 5843 FreeAndNil(FLineInfo); 5844 FreeAndNil(FRegisters); 5845 FreeAndNil(FCallStack); 5846 FreeAndNil(FDisassembler); 5847 FreeAndNil(FWatches); 5848 FreeAndNil(FThreads); 5849 FreeAndNil(FDebuggerEnvironment); 5850 FreeAndNil(FEnvironment); 5851 FreeAndNil(FCurEnvironment); 5852 FreeAndNil(FSignals); 5853 inherited; 5854end; 5855 5856function TDebuggerIntf.Disassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean; 5857begin 5858 Result := ReqCmd(dcDisassemble, [AAddr, ABackward, @ANextAddr, @ADump, @AStatement, @AFile, @ALine]); 5859end; 5860 5861function TDebuggerIntf.GetLocation: TDBGLocationRec; 5862begin 5863 Result.Address := 0; 5864 Result.SrcLine := 0; 5865end; 5866 5867procedure TDebuggerIntf.LockCommandProcessing; 5868begin 5869 // nothing 5870end; 5871 5872procedure TDebuggerIntf.UnLockCommandProcessing; 5873begin 5874 // nothing 5875end; 5876 5877procedure TDebuggerIntf.BeginReset; 5878begin 5879 FIsInReset := True; 5880end; 5881 5882function TDebuggerIntf.NeedReset: Boolean; 5883begin 5884 Result := False; 5885end; 5886 5887procedure TDebuggerIntf.AddNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); 5888begin 5889 FDestroyNotificationList[AReason].Add(TMethod(AnEvent)); 5890end; 5891 5892procedure TDebuggerIntf.RemoveNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); 5893begin 5894 FDestroyNotificationList[AReason].Remove(TMethod(AnEvent)); 5895end; 5896 5897procedure TDebuggerIntf.Done; 5898begin 5899 SetState(dsNone); 5900 FEnvironment.Clear; 5901 FCurEnvironment.Clear; 5902end; 5903 5904procedure TDebuggerIntf.Release; 5905begin 5906 if Self <> nil 5907 then Self.DoRelease; 5908end; 5909 5910procedure TDebuggerIntf.DoCurrent(const ALocation: TDBGLocationRec); 5911begin 5912 DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoCurrent (Location) >> State=', dbgs(FState)]); 5913 if Assigned(FOnCurrent) then FOnCurrent(Self, ALocation); 5914 DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoCurrent (Location) <<']); 5915end; 5916 5917procedure TDebuggerIntf.DoDbgOutput(const AText: String); 5918begin 5919 // WriteLN(' [TDebuggerIntf] ', AText); 5920 if Assigned(FOnDbgOutput) then FOnDbgOutput(Self, AText); 5921end; 5922 5923procedure TDebuggerIntf.DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String); 5924begin 5925 DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoDbgEvent >> State=', dbgs(FState), ' Category=', dbgs(ACategory)]); 5926 if Assigned(FEventLogHandler) then FEventLogHandler.LogCustomEvent(ACategory, AEventType, AText); 5927 DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoDbgEvent <<']); 5928end; 5929 5930procedure TDebuggerIntf.DoException(const AExceptionType: TDBGExceptionType; 5931 const AExceptionClass: String; const AExceptionLocation: TDBGLocationRec; const AExceptionText: String; out AContinue: Boolean); 5932begin 5933 DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoException >> State=', dbgs(FState)]); 5934 if AExceptionType = deInternal then 5935 DoDbgEvent(ecDebugger, etExceptionRaised, 5936 Format('Exception class "%s" at $%.' + IntToStr(TargetWidth div 4) + 'x with message "%s"', 5937 [AExceptionClass, AExceptionLocation.Address, AExceptionText])); 5938 if Assigned(FOnException) then 5939 FOnException(Self, AExceptionType, AExceptionClass, AExceptionLocation, AExceptionText, AContinue) 5940 else 5941 AContinue := True; 5942 DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoException <<']); 5943end; 5944 5945procedure TDebuggerIntf.DoOutput(const AText: String); 5946begin 5947 if Assigned(FOnOutput) then FOnOutput(Self, AText); 5948end; 5949 5950procedure TDebuggerIntf.DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); 5951begin 5952 DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoBreakpointHit << State=', dbgs(FState)]); 5953 if Assigned(FOnBreakpointHit) 5954 then FOnBreakpointHit(Self, ABreakPoint, ACanContinue); 5955 DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit >> DoBreakpointHit <<']); 5956end; 5957 5958procedure TDebuggerIntf.DoBeforeState(const OldState: TDBGState); 5959begin 5960 DebugLnEnter(DBG_STATE_EVENT, ['DebugEvent: Enter >> DoBeforeState << State=', dbgs(FState)]); 5961 if Assigned(FOnBeforeState) then FOnBeforeState(Self, OldState); 5962 DebugLnExit(DBG_STATE_EVENT, ['DebugEvent: Exit >> DoBeforeState <<']); 5963end; 5964 5965procedure TDebuggerIntf.DoState(const OldState: TDBGState); 5966begin 5967 DebugLnEnter(DBG_STATE_EVENT, ['DebugEvent: Enter >> DoState << State=', dbgs(FState)]); 5968 if Assigned(FOnState) then FOnState(Self, OldState); 5969 DebugLnExit(DBG_STATE_EVENT, ['DebugEvent: Exit >> DoState <<']); 5970end; 5971 5972procedure TDebuggerIntf.EnvironmentChanged(Sender: TObject); 5973var 5974 n, idx: integer; 5975 S: String; 5976 Env: TStringList; 5977begin 5978 // Createe local copy 5979 if FState <> dsNone then 5980 begin 5981 Env := TStringList.Create; 5982 try 5983 Env.Assign(Environment); 5984 5985 // Check for nonexisting and unchanged vars 5986 for n := 0 to FCurEnvironment.Count - 1 do 5987 begin 5988 S := FCurEnvironment[n]; 5989 idx := Env.IndexOfName(GetPart([], ['='], S, False, False)); 5990 if idx = -1 5991 then ReqCmd(dcEnvironment, [S, False]) 5992 else begin 5993 if Env[idx] = S 5994 then Env.Delete(idx); 5995 end; 5996 end; 5997 5998 // Set the remaining 5999 for n := 0 to Env.Count - 1 do 6000 begin 6001 S := Env[n]; 6002 //Skip functions etc. 6003 if Pos('=()', S) <> 0 then Continue; 6004 ReqCmd(dcEnvironment, [S, True]); 6005 end; 6006 finally 6007 Env.Free; 6008 end; 6009 end; 6010 FCurEnvironment.Assign(FEnvironment); 6011end; 6012 6013function TDebuggerIntf.GetPseudoTerminal: TPseudoTerminal; 6014begin 6015 Result := nil; 6016end; 6017 6018//function TDebuggerIntf.GetUnitInfoProvider: TDebuggerUnitInfoProvider; 6019//begin 6020// Result := FUnitInfoProvider; 6021// if Result = nil then 6022// Result := FInternalUnitInfoProvider; 6023//end; 6024 6025function TDebuggerIntf.GetIsIdle: Boolean; 6026begin 6027 Result := False; 6028end; 6029 6030function TDebuggerIntf.Evaluate(const AExpression: String; 6031 ACallback: TDBGEvaluateResultCallback; EvalFlags: TDBGEvaluateFlags): Boolean; 6032begin 6033 Result := ReqCmd(dcEvaluate, [AExpression, Integer(EvalFlags)], TMethod(ACallback)); 6034end; 6035 6036function TDebuggerIntf.GetProcessList(AList: TRunningProcessInfoList): boolean; 6037begin 6038 result := false; 6039end; 6040 6041class function TDebuggerIntf.ExePaths: String; 6042begin 6043 Result := ''; 6044end; 6045 6046class function TDebuggerIntf.HasExePath: boolean; 6047begin 6048 Result := NeedsExePath; 6049end; 6050 6051class function TDebuggerIntf.NeedsExePath: boolean; 6052begin 6053 Result := true; // most debugger are external and have an exe path 6054end; 6055 6056class function TDebuggerIntf.RequiredCompilerOpts(ATargetCPU, ATargetOS: String): TDebugCompilerRequirements; 6057begin 6058 Result := []; 6059end; 6060 6061function TDebuggerIntf.GetCommands: TDBGCommands; 6062begin 6063 Result := COMMANDMAP[State] * GetSupportedCommands; 6064end; 6065 6066class function TDebuggerIntf.GetProperties: TDebuggerProperties; 6067var 6068 idx: Integer; 6069begin 6070 if MDebuggerPropertiesList = nil 6071 then MDebuggerPropertiesList := TStringList.Create; 6072 idx := MDebuggerPropertiesList.IndexOf(ClassName); 6073 if idx = -1 6074 then begin 6075 Result := CreateProperties; 6076 MDebuggerPropertiesList.AddObject(ClassName, Result) 6077 end 6078 else begin 6079 Result := TDebuggerProperties(MDebuggerPropertiesList.Objects[idx]); 6080 end; 6081end; 6082 6083function TDebuggerIntf.GetState: TDBGState; 6084begin 6085 Result := FState; 6086end; 6087 6088function TDebuggerIntf.ReqCmd(const ACommand: TDBGCommand; 6089 const AParams: array of const): Boolean; 6090var 6091 dummy: TMethod; 6092begin 6093 dummy.Code := nil; 6094 dummy.Data := nil; 6095 ReqCmd(ACommand, AParams, dummy); 6096end; 6097 6098function TDebuggerIntf.GetSupportedCommands: TDBGCommands; 6099begin 6100 Result := []; 6101end; 6102 6103function TDebuggerIntf.GetTargetWidth: Byte; 6104begin 6105 Result := SizeOf(PtrInt)*8; 6106end; 6107 6108function TDebuggerIntf.GetWaiting: Boolean; 6109begin 6110 Result := False; 6111end; 6112 6113procedure TDebuggerIntf.Init; 6114begin 6115 FExitCode := 0; 6116 FErrorStateMessage := ''; 6117 FErrorStateInfo := ''; 6118 SetState(dsIdle); 6119end; 6120 6121procedure TDebuggerIntf.JumpTo(const ASource: String; const ALine: Integer); 6122begin 6123 ReqCmd(dcJumpTo, [ASource, ALine]); 6124end; 6125 6126procedure TDebuggerIntf.Attach(AProcessID: String); 6127begin 6128 if State = dsIdle then SetState(dsStop); // Needed, because no filename was set 6129 ReqCmd(dcAttach, [AProcessID]); 6130end; 6131 6132procedure TDebuggerIntf.Detach; 6133begin 6134 ReqCmd(dcDetach, []); 6135end; 6136 6137procedure TDebuggerIntf.SendConsoleInput(AText: String); 6138begin 6139 ReqCmd(dcSendConsoleInput, [AText]); 6140end; 6141 6142function TDebuggerIntf.Modify(const AExpression, AValue: String): Boolean; 6143begin 6144 Result := ReqCmd(dcModify, [AExpression, AValue]); 6145end; 6146 6147procedure TDebuggerIntf.Pause; 6148begin 6149 ReqCmd(dcPause, []); 6150end; 6151 6152function TDebuggerIntf.ReqCmd(const ACommand: TDBGCommand; 6153 const AParams: array of const; const ACallback: TMethod): Boolean; 6154begin 6155 if FState = dsNone then Init; 6156 if ACommand in Commands 6157 then begin 6158 Result := RequestCommand(ACommand, AParams, ACallback); 6159 if not Result then begin 6160 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.ReqCmd failed: ',dbgs(ACommand)); 6161 end; 6162 end 6163 else begin 6164 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.ReqCmd Command not supported: ', 6165 dbgs(ACommand),' ClassName=',ClassName); 6166 Result := False; 6167 end; 6168end; 6169 6170procedure TDebuggerIntf.Run; 6171begin 6172 ReqCmd(dcRun, []); 6173end; 6174 6175procedure TDebuggerIntf.RunTo(const ASource: String; const ALine: Integer); 6176begin 6177 ReqCmd(dcRunTo, [ASource, ALine]); 6178end; 6179 6180procedure TDebuggerIntf.SetDebuggerEnvironment (const AValue: TStrings ); 6181begin 6182 FDebuggerEnvironment.Assign(AValue); 6183end; 6184 6185procedure TDebuggerIntf.SetEnvironment(const AValue: TStrings); 6186begin 6187 FEnvironment.Assign(AValue); 6188end; 6189 6190procedure TDebuggerIntf.SetExitCode(const AValue: Integer); 6191begin 6192 FExitCode := AValue; 6193end; 6194 6195procedure TDebuggerIntf.SetFileName(const AValue: String); 6196begin 6197 if FFileName <> AValue 6198 then begin 6199 DebugLn(DBG_VERBOSE, '[TDebuggerIntf.SetFileName] "', AValue, '"'); 6200 if FState in [dsRun, dsPause] 6201 then begin 6202 Stop; 6203 // check if stopped 6204 if FState <> dsStop 6205 then SetState(dsError); 6206 end; 6207 6208 if FState = dsStop 6209 then begin 6210 // Reset state 6211 FFileName := ''; 6212 ResetStateToIdle; 6213 ChangeFileName; 6214 end; 6215 6216 FFileName := AValue; 6217 // TODO: Why? 6218 if (FFilename <> '') and (FState = dsIdle) and ChangeFileName 6219 then SetState(dsStop); 6220 end 6221 else 6222 if FileName = '' then 6223 ResetStateToIdle; 6224end; 6225 6226procedure TDebuggerIntf.ResetStateToIdle; 6227begin 6228 SetState(dsIdle); 6229end; 6230 6231class procedure TDebuggerIntf.SetProperties(const AProperties: TDebuggerProperties); 6232var 6233 Props: TDebuggerProperties; 6234begin 6235 if AProperties = nil then Exit; 6236 Props := GetProperties; 6237 if Props = AProperties then Exit; 6238 6239 if Props = nil then Exit; // they weren't created ? 6240 Props.Assign(AProperties); 6241end; 6242 6243class function TDebuggerIntf.RequiresLocalExecutable: Boolean; 6244begin 6245 Result := True; 6246end; 6247 6248procedure TDebuggerIntf.TestCmd(const ACommand: String); 6249begin 6250 // 6251end; 6252 6253procedure TDebuggerIntf.SetState(const AValue: TDBGState); 6254var 6255 OldState: TDBGState; 6256begin 6257 // dsDestroying is final, do not unset 6258 if FState = dsDestroying 6259 then exit; 6260 6261 // dsDestroying must be silent. The ide believes the debugger is gone already 6262 if AValue = dsDestroying 6263 then begin 6264 FState := AValue; 6265 exit; 6266 end; 6267 6268 if AValue <> FState 6269 then begin 6270 DebugLnEnter(DBG_STATE, ['DebuggerState: Setting to ', dbgs(AValue),', from ', dbgs(FState)]); 6271 OldState := FState; 6272 FState := AValue; 6273 LockCommandProcessing; 6274 try 6275 DoBeforeState(OldState); 6276 try 6277 FThreads.DoStateChange(OldState); 6278 FCallStack.DoStateChange(OldState); 6279 FBreakpoints.DoStateChange(OldState); 6280 FLocals.DoStateChange(OldState); 6281 FLineInfo.DoStateChange(OldState); 6282 FRegisters.DoStateChange(OldState); 6283 FDisassembler.DoStateChange(OldState); 6284 FWatches.DoStateChange(OldState); 6285 finally 6286 DoState(OldState); 6287 end; 6288 finally 6289 UnLockCommandProcessing; 6290 DebugLnExit(DBG_STATE, ['DebuggerState: Finished ', dbgs(AValue)]); 6291 end; 6292 end; 6293end; 6294 6295procedure TDebuggerIntf.SetErrorState(const AMsg: String; const AInfo: String = ''); 6296begin 6297 if FErrorStateMessage = '' 6298 then FErrorStateMessage := AMsg; 6299 if FErrorStateInfo = '' 6300 then FErrorStateInfo := AInfo; 6301 SetState(dsError); 6302end; 6303 6304procedure TDebuggerIntf.DoRelease; 6305begin 6306 SetState(dsDestroying); 6307 if FReleaseLock > 0 6308 then exit; 6309 6310 Self.Free; 6311end; 6312 6313procedure TDebuggerIntf.LockRelease; 6314begin 6315 inc(FReleaseLock); 6316 DebugLnEnter(DBG_VERBOSE, ['> TDebuggerIntf.LockRelease ',FReleaseLock]); 6317end; 6318 6319procedure TDebuggerIntf.UnlockRelease; 6320begin 6321 DebugLnExit(DBG_VERBOSE, ['< TDebuggerIntf.UnlockRelease ',FReleaseLock]); 6322 dec(FReleaseLock); 6323 if (FReleaseLock = 0) and (State = dsDestroying) 6324 then Release; 6325end; 6326 6327procedure TDebuggerIntf.StepInto; 6328begin 6329 if ReqCmd(dcStepInto, []) then exit; 6330 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepInto Class=',ClassName,' failed.'); 6331end; 6332 6333procedure TDebuggerIntf.StepOverInstr; 6334begin 6335 if ReqCmd(dcStepOverInstr, []) then exit; 6336 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOverInstr Class=',ClassName,' failed.'); 6337end; 6338 6339procedure TDebuggerIntf.StepIntoInstr; 6340begin 6341 if ReqCmd(dcStepIntoInstr, []) then exit; 6342 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepIntoInstr Class=',ClassName,' failed.'); 6343end; 6344 6345procedure TDebuggerIntf.StepOut; 6346begin 6347 if ReqCmd(dcStepOut, []) then exit; 6348 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOut Class=', ClassName, ' failed.'); 6349end; 6350 6351procedure TDebuggerIntf.StepOver; 6352begin 6353 if ReqCmd(dcStepOver, []) then exit; 6354 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOver Class=',ClassName,' failed.'); 6355end; 6356 6357procedure TDebuggerIntf.Stop; 6358begin 6359 if ReqCmd(dcStop,[]) then exit; 6360 DebugLn(DBG_WARNINGS, 'TDebuggerIntf.Stop Class=',ClassName,' failed.'); 6361end; 6362 6363constructor TBaseDebugManagerIntf.Create(AOwner: TComponent); 6364begin 6365 inherited Create(AOwner); 6366 6367 FValueFormatterList := TStringList.Create; 6368 FValueFormatterList.Sorted := True; 6369 FValueFormatterList.Duplicates := dupError; 6370end; 6371 6372function TBaseDebugManagerIntf.DebuggerCount: Integer; 6373begin 6374 Result := MDebuggerClasses.Count; 6375end; 6376 6377destructor TBaseDebugManagerIntf.Destroy; 6378begin 6379 FValueFormatterList.Free; 6380 6381 inherited Destroy; 6382end; 6383 6384function TBaseDebugManagerIntf.FindDebuggerClass(const Astring: String 6385 ): TDebuggerClass; 6386var 6387 idx: Integer; 6388begin 6389 idx := MDebuggerClasses.IndexOf(AString); 6390 if idx = -1 6391 then Result := nil 6392 else Result := TDebuggerClass(MDebuggerClasses.Objects[idx]); 6393end; 6394 6395function TBaseDebugManagerIntf.FormatValue(const aSymbolKind: TDBGSymbolKind; 6396 const aTypeName, aValue: string): string; 6397var 6398 I: Integer; 6399begin 6400 I := FValueFormatterList.IndexOf(ValueFormatterKey(aSymbolKind, aTypeName)); 6401 if I>=0 then 6402 Result := TStringFunction(FValueFormatterList.Objects[I])(aValue) 6403 else 6404 Result := aValue; 6405end; 6406 6407function TBaseDebugManagerIntf.FormatValue(const aDBGType: TDBGType; 6408 const aValue: string): string; 6409begin 6410 if aDBGType=nil then 6411 Result := aValue 6412 else 6413 Result := FormatValue(aDBGType.Kind, aDBGType.TypeName, aValue); 6414end; 6415 6416function TBaseDebugManagerIntf.GetDebuggerClass(const AIndex: Integer): TDebuggerClass; 6417begin 6418 Result := TDebuggerClass(MDebuggerClasses.Objects[AIndex]); 6419end; 6420 6421procedure TBaseDebugManagerIntf.RegisterValueFormatter( 6422 const aSymbolKind: TDBGSymbolKind; const aTypeName: string; 6423 const aFunc: TStringFunction); 6424begin 6425 FValueFormatterList.AddObject(ValueFormatterKey(aSymbolKind, aTypeName), TObject(aFunc)); 6426end; 6427 6428function TBaseDebugManagerIntf.ValueFormatterKey( 6429 const aSymbolKind: TDBGSymbolKind; const aTypeName: string): string; 6430begin 6431 Result := UpperCase(IntToStr(Ord(aSymbolKind))+':'+aTypeName); 6432end; 6433 6434 6435initialization 6436 MDebuggerPropertiesList := nil; 6437 {$IFDEF DBG_STATE} {$DEFINE DBG_STATE_EVENT} {$ENDIF} 6438 {$IFDEF DBG_EVENTS} {$DEFINE DBG_STATE_EVENT} {$ENDIF} 6439 DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} ); 6440 DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); 6441 DBG_STATE := DebugLogger.FindOrRegisterLogGroup('DBG_STATE' {$IFDEF DBG_STATE} , True {$ENDIF} ); 6442 DBG_EVENTS := DebugLogger.FindOrRegisterLogGroup('DBG_EVENTS' {$IFDEF DBG_EVENTS} , True {$ENDIF} ); 6443 DBG_STATE_EVENT := DebugLogger.FindOrRegisterLogGroup('DBG_STATE_EVENT' {$IFDEF DBG_STATE_EVENT} , True {$ENDIF} ); 6444 DBG_DATA_MONITORS := DebugLogger.FindOrRegisterLogGroup('DBG_DATA_MONITORS' {$IFDEF DBG_DATA_MONITORS} , True {$ENDIF} ); 6445 DBG_DISASSEMBLER := DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER' {$IFDEF DBG_DISASSEMBLER} , True {$ENDIF} ); 6446 6447 MDebuggerClasses := TStringList.Create; 6448 MDebuggerClasses.Sorted := True; 6449 MDebuggerClasses.Duplicates := dupError; 6450 6451finalization 6452 DoFinalization; 6453 FreeAndNil(MDebuggerClasses); 6454 6455end. 6456