diff --git a/icons/other/breaks.png b/icons/other/breaks.png new file mode 100644 index 00000000..441feedf Binary files /dev/null and b/icons/other/breaks.png differ diff --git a/icons/other/step.png b/icons/other/step.png new file mode 100644 index 00000000..43825a4f Binary files /dev/null and b/icons/other/step.png differ diff --git a/icons/other/stop.png b/icons/other/stop.png new file mode 100644 index 00000000..b626916f Binary files /dev/null and b/icons/other/stop.png differ diff --git a/lazproj/coedit.lpi b/lazproj/coedit.lpi index e169bef4..e4dfefcc 100644 --- a/lazproj/coedit.lpi +++ b/lazproj/coedit.lpi @@ -13,7 +13,7 @@ - + @@ -108,6 +108,9 @@ + + + @@ -236,7 +239,7 @@ - + @@ -506,6 +509,10 @@ + + + + diff --git a/lazproj/coedit.lpr b/lazproj/coedit.lpr index 30afd90d..4050e720 100644 --- a/lazproj/coedit.lpr +++ b/lazproj/coedit.lpr @@ -12,7 +12,7 @@ uses ce_dockoptions, ce_shortcutseditor, ce_mru, ce_processes, ce_dubproject, ce_dialogs, ce_dubprojeditor, ce_controls, ce_dfmt, ce_lcldragdrop, ce_stringrange, ce_dlangmaps, ce_projgroup, ce_projutils, ce_d2synpresets, - ce_dastworx; + ce_dastworx, ce_dbgitf; {$R *.res} diff --git a/src/ce_dbgitf.pas b/src/ce_dbgitf.pas new file mode 100644 index 00000000..a1a1e608 --- /dev/null +++ b/src/ce_dbgitf.pas @@ -0,0 +1,90 @@ +unit ce_dbgitf; + +{$I ce_defines.inc} + +interface + +uses + Classes, SysUtils, ce_observer; + +type + + TBreakPointKind = ( + bpkBreak, // break + bpkTrace // a message is output + ); + + (** + * ICEEDebugObserver can call any of the method during debugging + *) + ICEDebugger = interface + procedure addBreakPoint(const fname: string; line: integer; kind: TBreakPointKind); + procedure removeBreakPoint(const fname: string; line: integer); + end; + + // Enumerates th e reason why debuging breaks. + TCEDebugBreakReason = ( + dbUnknown, // ? + dbBreakPoint, // a break point is reached. + dbSignal, // an unexpected signal is emitted. + dbStep // step to this line + ); + (** + * An implementer is informed about a debuging session. + *) + ICEDebugObserver = interface(IObserverType) + ['ICEDebugObserver'] + // a debugging session starts. The ICEDebugger can be stored for the session. + procedure debugStart(debugger: ICEDebugger); + // a debugging session terminates. Any pointer to a ICEDebugger becomes invalid. + procedure debugStop; + // the debuger wants to know how many times debugQueryBreakPoints must be called. + function debugQueryBpCount: integer; + // the debuger wants breakpoints. + procedure debugQueryBreakPoint(const index: integer; out fname: string; + out line: integer; out kind: TBreakPointKind); + // a break happens when code in fname at line is executed. + procedure debugBreak(const fname: string; line: integer; reason: TCEDebugBreakReason); + end; + + (** + * An implementer notifies is observer about a debuginf session. + *) + TCEDebugObserverSubject = specialize TCECustomSubject; + + // TCEDebugObserverSubject primitives + procedure subjDebugStart(subj: TCEDebugObserverSubject; dbg: ICEDebugger); + procedure subjDebugStop(subj: TCEDebugObserverSubject); + procedure subjDebugBreak(subj: TCEDebugObserverSubject; const fname: string; + line: integer; reason: TCEDebugBreakReason); + + +implementation + +procedure subjDebugStart(subj: TCEDebugObserverSubject; dbg: ICEDebugger); +var + i: integer; +begin + for i:= 0 to subj.observersCount-1 do + (subj.observers[i] as ICEDebugObserver).debugStart(dbg); +end; + +procedure subjDebugStop(subj: TCEDebugObserverSubject); +var + i: integer; +begin + for i:= 0 to subj.observersCount-1 do + (subj.observers[i] as ICEDebugObserver).debugStop; +end; + +procedure subjDebugBreak(subj: TCEDebugObserverSubject; const fname: string; + line: integer; reason: TCEDebugBreakReason); +var + i: integer; +begin + for i:= 0 to subj.observersCount-1 do + (subj.observers[i] as ICEDebugObserver).debugBreak(fname, line, reason); +end; + +end. + diff --git a/src/ce_gdb.lfm b/src/ce_gdb.lfm index 0098f297..d589665a 100644 --- a/src/ce_gdb.lfm +++ b/src/ce_gdb.lfm @@ -142,7 +142,7 @@ inherited CEGdbWidget: TCEGdbWidget Top = 0 Caption = 'btnStop' OnClick = btnStopClick - resourceName = 'CANCEL' + resourceName = 'STOP' scaledSeparator = False end object btnContinue: TCEToolButton[7] diff --git a/src/ce_gdb.pas b/src/ce_gdb.pas index 02dc38bf..42f5beba 100644 --- a/src/ce_gdb.pas +++ b/src/ce_gdb.pas @@ -5,11 +5,11 @@ unit ce_gdb; interface uses - Classes, SysUtils, FileUtil, ListFilterEdit, Forms, Controls, Graphics, - RegExpr, ComCtrls, PropEdits, GraphPropEdits, RTTIGrids, Dialogs, ExtCtrls, - Menus, strutils, Buttons, StdCtrls, process, fpjson, + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, RegExpr, ComCtrls, + PropEdits, GraphPropEdits, RTTIGrids, Dialogs, ExtCtrls, Menus, Buttons, + StdCtrls, process, fpjson, ce_common, ce_interfaces, ce_widget, ce_processes, ce_observer, ce_synmemo, - ce_sharedres, ce_stringrange, ce_dsgncontrols, ce_dialogs; + ce_sharedres, ce_stringrange, ce_dsgncontrols, ce_dialogs, ce_dbgitf; type @@ -211,7 +211,7 @@ type end; { TCEGdbWidget } - TCEGdbWidget = class(TCEWidget, ICEProjectObserver, ICEDocumentObserver) + TCEGdbWidget = class(TCEWidget, ICEProjectObserver, ICEDocumentObserver, ICEDebugger) btnContinue: TCEToolButton; btnPause: TCEToolButton; btnReg: TCEToolButton; @@ -237,6 +237,7 @@ type protected procedure setToolBarFlat(value: boolean); override; private + fSubj: TCEDebugObserverSubject; fDoc: TCESynMemo; fProj: ICECommonProject; fJson: TJsonObject; @@ -251,8 +252,7 @@ type // procedure startDebugging; procedure killGdb; - procedure updateFileLineBrks; - procedure editorModBrk(sender: TCESynMemo; line: integer; modification: TBreakPointModification); + procedure storeObserversBreakpoints; // GDB output processors procedure gdboutQuiet(sender: TObject); procedure gdboutJsonize(sender: TObject); @@ -273,6 +273,9 @@ type procedure docFocused(document: TCESynMemo); procedure docChanged(document: TCESynMemo); procedure docClosing(document: TCESynMemo); + // + procedure addBreakPoint(const fname: string; line: integer; kind: TBreakPointKind); + procedure removeBreakPoint(const fname: string; line: integer); public constructor create(aOwner: TComponent); override; destructor destroy; override; @@ -413,6 +416,7 @@ begin stateViewer.TIObject := fInspState; fJson := TJsonObject.Create; fStackItems := TStackItems.create; + fSubj:= TCEDebugObserverSubject.Create; fShowCLI := true; // AssignPng(btnSendCom, 'ACCEPT'); @@ -427,6 +431,7 @@ begin fJson.Free; fStackItems.Free; EntitiesConnector.removeObserver(self); + fSubj.free; inherited; end; @@ -473,14 +478,10 @@ end; {$REGION ICEDocumentObserver ---------------------------------------------------} procedure TCEGdbWidget.docNew(document: TCESynMemo); begin - if document.isDSource then - document.onBreakpointModify := @editorModBrk; end; procedure TCEGdbWidget.docFocused(document: TCESynMemo); begin - if document.isDSource then - document.onBreakpointModify := @editorModBrk; fDoc := document; end; @@ -505,49 +506,41 @@ begin FreeAndNil(fGdb); end; -procedure TCEGdbWidget.updateFileLineBrks; +procedure TCEGdbWidget.storeObserversBreakpoints; var i,j: integer; - doc: TCESynMemo; + obs: ICEDebugObserver; nme: string; + lne: integer; + knd: TBreakPointKind; begin fFileLineBrks.Clear; - if fDocHandler = nil then exit; - // - for i:= 0 to fDocHandler.documentCount-1 do + for i:= 0 to fSubj.observersCount-1 do begin - doc := fDocHandler.document[i]; - if not doc.isDSource then - continue; - nme := doc.fileName; - if not nme.fileExists then - continue; - {$PUSH}{$WARNINGS OFF}{$HINTS OFF} - for j := 0 to doc.breakPointsCount-1 do - fFileLineBrks.AddObject(nme, TObject(pointer(doc.BreakPointLine(j)))); - {$POP} + obs := fSubj.observers[i] as ICEDebugObserver; + for j := 0 to obs.debugQueryBpCount-1 do + begin + obs.debugQueryBreakPoint(j, nme, lne, knd); + {$PUSH}{$WARNINGS OFF}{$HINTS OFF} + fFileLineBrks.AddObject(nme, TObject(pointer(lne))); + {$POP} + end; end; end; -procedure TCEGdbWidget.editorModBrk(sender: TCESynMemo; line: integer; modification: TBreakPointModification); -var - str: string; - nme: string; -const - cmd: array[TBreakPointModification] of string = ('break ', 'clear '); +procedure TCEGdbWidget.addBreakPoint(const fname: string; line: integer; kind: TBreakPointKind); begin - // set only breakpoint in live, while debugging - // note: only works if execution is paused (breakpoint) - // and not inside a loop (for ex. with sleep). - if fGdb = nil then exit; - if not fGdb.Running then exit; - nme := sender.fileName; - if not nme.fileExists then exit; - // - str := cmd[modification] + nme + ':' + intToStr(line); - fGdb.Suspend; - gdbCommand(str); - fGdb.Resume; + if fGdb.isNil or not fGdb.Running then + exit; + //TODO-cGDB: handle trace points + gdbCommand('break ' + fname + ':' + intToStr(line)); +end; + +procedure TCEGdbWidget.removeBreakPoint(const fname: string; line: integer); +begin + if fGdb.isNil or not fGdb.Running then + exit; + gdbCommand('clear ' + fname + ':' + intToStr(line)); end; procedure TCEGdbWidget.startDebugging; @@ -556,10 +549,15 @@ var i: integer; begin // protect - if fProj = nil then exit; - if fProj.binaryKind <> executable then exit; + if fProj = nil then + exit; + if fProj.binaryKind <> executable then + exit; str := fProj.outputFilename; - if not str.fileExists then exit; + if not str.fileExists then + exit; + // TODO-cDBG: detect finish event and notifiy the observers. + subjDebugStart(fSubj, self as ICEDebugger); // gdb process killGdb; fGdb := TCEProcess.create(nil); @@ -571,14 +569,13 @@ begin fGdb.OnTerminate:= @gdboutQuiet; fgdb.execute; // file:line breakpoints - updateFileLineBrks; + storeObserversBreakpoints; for i:= 0 to fFileLineBrks.Count-1 do begin str := 'break ' + fFileLineBrks.Strings[i] + ':' + intToStr(PtrUInt(fFileLineBrks.Objects[i])) + #10; fGdb.Input.Write(str[1], str.length); end; // break on druntime exceptions + any throw' - fGdb.OnReadData := @gdboutQuiet; gdbCommand('break onAssertError'); gdbCommand('break onAssertErrorMsg'); gdbCommand('break onUnittestErrorMsg'); @@ -804,11 +801,7 @@ begin if val.isNotNil then line := strToInt(val.AsString); if (line <> -1) and fullname.fileExists then - begin - getMultiDocHandler.openDocument(fullname); - fDoc.setFocus; - fDoc.CaretY:= line; - end; + subjDebugBreak(fSubj, fullname, line, dbBreakPoint); end; end @@ -837,15 +830,8 @@ begin + LineEnding + 'Do you wish to pause execution ?', [signame, sigmean, line, fullname]), 'Unexpected signal received') = mrNo then gdbCommand('continue', @gdboutJsonize) - else - begin - if (line <> -1) and fullname.fileExists then - begin - getMultiDocHandler.openDocument(fullname); - fDoc.setFocus; - fDoc.CaretY:= line; - end; - end; + else if (line <> -1) and fullname.fileExists then + subjDebugBreak(fSubj, fullname, line, dbSignal); end; end; @@ -992,7 +978,7 @@ end; procedure TCEGdbWidget.btnStopClick(Sender: TObject); begin - gdbCommand('kill', @gdboutQuiet); + gdbCommand('kill', @gdboutJsonize); killGdb; end; diff --git a/src/ce_interfaces.pas b/src/ce_interfaces.pas index 77e293f0..df51b378 100644 --- a/src/ce_interfaces.pas +++ b/src/ce_interfaces.pas @@ -22,7 +22,7 @@ type * Each project format has its own dedicated editors. * A few common properties allow some generic operations whatever is the format. *) - ICECommonProject = interface(ISubjectType) + ICECommonProject = interface ['ICECommonProject'] // general properties ------------------------------------------------------ @@ -98,7 +98,7 @@ type (** * An implementer declares some actions on demand. *) - ICEContextualActions = interface(ISubjectType) + ICEContextualActions = interface(IObserverType) ['ICEContextualActions'] // declares a context name for the actions function contextName: string; @@ -113,7 +113,7 @@ type (** * An implementer is informed about the current file(s). *) - ICEDocumentObserver = interface(ISubjectType) + ICEDocumentObserver = interface(IObserverType) ['ICEDocumentObserver'] // document has been created (empty, runnable, project source, ...). procedure docNew(document: TCESynMemo); @@ -139,7 +139,7 @@ type * - the current project, the one that's active) which can be either the FSP * or one of the project in the group. *) - ICEProjectObserver = interface(ISubjectType) + ICEProjectObserver = interface(IObserverType) ['ICEProjectObserver'] // a project has been created/opened procedure projNew(project: ICECommonProject); @@ -164,7 +164,7 @@ type (** * An implementer can add a main menu entry. *) - ICEMainMenuProvider = interface(ISubjectType) + ICEMainMenuProvider = interface(IObserverType) ['ICEMainMenuProvider'] // item is a new mainMenu entry. item must be filled with the sub-items to be added. procedure menuDeclare(item: TMenuItem); @@ -182,7 +182,7 @@ type * An implementer declares some actions which have their own main menu entry and * whose shortcuts are automatically handled *) - ICEActionProvider = interface(ISubjectType) + ICEActionProvider = interface(IObserverType) ['ICEActionProvider'] // the action handler will clear the references to the actions collected previously and start collecting if result. function actHandlerWantRecollect: boolean; @@ -203,7 +203,7 @@ type (** * An implementer can expose customizable shortcuts to be edited in a dedicated widget. *) - ICEEditableShortCut = interface(ISubjectType) + ICEEditableShortCut = interface(IObserverType) ['ICEEditableShortCut'] // a TCEEditableShortCutSubject will start to collect shortcuts if result. function scedWantFirst: boolean; @@ -237,7 +237,7 @@ type (** * An implementer can expose options to be edited in a dedicated widget. *) - ICEEditableOptions = interface(ISubjectType) + ICEEditableOptions = interface(IObserverType) ['ICEEditableOptions'] // the widget wants the category. function optionedWantCategory(): string; diff --git a/src/ce_observer.pas b/src/ce_observer.pas index ac4292dc..327277ec 100644 --- a/src/ce_observer.pas +++ b/src/ce_observer.pas @@ -57,8 +57,6 @@ type property isUpdating: boolean read getIsUpdating; end; - - (** * Interface for a Coedit subject. Basically designed to hold a list of observer *) @@ -70,15 +68,18 @@ type // optionally implemented to trigger all the methods of the observer interface. end; - // Base type for an interface that contains the methods of a subject. - ISubjectType = interface + (** + * Base type used as constraint for an interface that contains + * the methods called by a ICESubject. + *) + IObserverType = interface end; (** * Standard implementation of an ICESubject. - * Any descendant adds itself to the global EntitiesConnector. + * Any descendant automatically adds itself to the EntitiesConnector. *) - generic TCECustomSubject = class(ICESubject) + generic TCECustomSubject = class(ICESubject) protected fObservers: TObjectList; // test for a specific interface when adding an observer. diff --git a/src/ce_synmemo.pas b/src/ce_synmemo.pas index dd851c7d..d5cd5786 100644 --- a/src/ce_synmemo.pas +++ b/src/ce_synmemo.pas @@ -11,7 +11,7 @@ uses SynEditMarks, SynEditTypes, SynHighlighterJScript, SynBeautifier, dialogs, fpjson, jsonparser, LazUTF8, LazUTF8Classes, Buttons, StdCtrls, ce_common, ce_writableComponent, ce_d2syn, ce_txtsyn, ce_dialogs, - ce_sharedres, ce_dlang, ce_stringrange; + ce_sharedres, ce_dlang, ce_stringrange, ce_dbgitf, ce_observer; type @@ -49,12 +49,6 @@ type TIdentifierMatchOptions = set of TIdentifierMatchOption; - TBreakPointModification = (bpAdded, bpRemoved); - - // breakpoint added or removed - TBreakPointModifyEvent = procedure(sender: TCESynMemo; line: integer; - modification: TBreakPointModification) of object; - // Simple THintWindow descendant allowing the font size to be in sync with the editor. TCEEditorHintWindow = class(THintWindow) public @@ -122,7 +116,7 @@ type TSortDialog = class; - TCESynMemo = class(TSynEdit) + TCESynMemo = class(TSynEdit, ICEDebugObserver) private fFilename: string; fDastWorxExename: string; @@ -153,7 +147,6 @@ type fTxtHighlighter: TSynTxtSyn; fImages: TImageList; fBreakPoints: TFPList; - fBreakpointEvent: TBreakPointModifyEvent; fMatchSelectionOpts: TSynSearchOptions; fMatchIdentOpts: TSynSearchOptions; fMatchOpts: TIdentifierMatchOptions; @@ -171,6 +164,7 @@ type fModuleTokFound: boolean; fHasModuleDeclaration: boolean; fLastCompletion: string; + fDebugger: ICEDebugger; procedure decCallTipsLvl; procedure setMatchOpts(value: TIdentifierMatchOptions); function getMouseBytePosition: Integer; @@ -195,6 +189,7 @@ type procedure gutterClick(Sender: TObject; X, Y, Line: integer; mark: TSynEditMark); procedure addBreakPoint(line: integer); procedure removeBreakPoint(line: integer); + procedure removeDebugTimeMarks; function findBreakPoint(line: integer): boolean; procedure showCallTips(const tips: string); function lexCanCloseBrace: boolean; @@ -204,6 +199,14 @@ type procedure setSelectionOrWordCase(upper: boolean); procedure sortSelectedLines(descending, caseSensitive: boolean); procedure tokFoundForCaption(const token: PLexToken; out stop: boolean); + // + procedure debugStart(debugger: ICEDebugger); + procedure debugStop; + function debugQueryBpCount: integer; + procedure debugQueryBreakPoint(const index: integer; out fname: string; out line: integer; out kind: TBreakPointKind); + procedure debugBreak(const fname: string; line: integer; reason: TCEDebugBreakReason); + function breakPointsCount: integer; + function breakPointLine(index: integer): integer; protected procedure DoEnter; override; procedure DoExit; override; @@ -223,6 +226,7 @@ type constructor Create(aOwner: TComponent); override; destructor destroy; override; procedure setFocus; override; + procedure showPage; // function pageCaption(checkModule: boolean): string; procedure checkFileDate; @@ -243,12 +247,8 @@ type procedure ShowPhobosDoc; procedure nextChangedArea; procedure previousChangedArea; - function implementMain: THasMain; procedure sortLines; - // - function breakPointsCount: integer; - function breakPointLine(index: integer): integer; - property onBreakpointModify: TBreakPointModifyEvent read fBreakpointEvent write fBreakpointEvent; + function implementMain: THasMain; // property IdentifierMatchOptions: TIdentifierMatchOptions read fMatchOpts write setMatchOpts; property Identifier: string read fIdentifier; @@ -723,6 +723,9 @@ begin fImages := TImageList.Create(self); fImages.AddResourceName(HINSTANCE, 'BULLET_RED'); fImages.AddResourceName(HINSTANCE, 'BULLET_GREEN'); + fImages.AddResourceName(HINSTANCE, 'BULLET_BLACK'); + fImages.AddResourceName(HINSTANCE, 'BREAKS'); + fImages.AddResourceName(HINSTANCE, 'STEP'); fBreakPoints := TFPList.Create; // fPositions := TCESynMemoPositions.create(self); @@ -742,12 +745,14 @@ begin fDastWorxExename:= exeFullName('dastworx' + exeExt); // subjDocNew(TCEMultiDocSubject(fMultiDocSubject), self); + EntitiesConnector.addObserver(self); end; destructor TCESynMemo.destroy; begin saveCache; // + EntitiesConnector.removeObserver(self); subjDocClosing(TCEMultiDocSubject(fMultiDocSubject), self); fMultiDocSubject.Free; fPositions.Free; @@ -783,6 +788,11 @@ begin subjDocFocused(TCEMultiDocSubject(fMultiDocSubject), self); end; +procedure TCESynMemo.showPage; +begin + getMultiDocHandler.openDocument(fileName); +end; + procedure TCESynMemo.DoEnter; begin inherited; @@ -2404,7 +2414,7 @@ begin end; {$ENDREGION --------------------------------------------------------------------} -{$REGION breakpoints -----------------------------------------------------------} +{$REGION debugging/breakpoints -----------------------------------------------------------} function TCESynMemo.breakPointsCount: integer; begin exit(fBreakPoints.Count); @@ -2434,8 +2444,8 @@ begin {$PUSH}{$WARNINGS OFF}{$HINTS OFF} fBreakPoints.Add(pointer(line)); {$POP} - if assigned(fBreakpointEvent) then - fBreakpointEvent(self, line, bpAdded); + if assigned(fDebugger) then + fDebugger.addBreakPoint(fFilename, line, bpkBreak); end; procedure TCESynMemo.removeBreakPoint(line: integer); @@ -2447,8 +2457,13 @@ begin {$PUSH}{$WARNINGS OFF}{$HINTS OFF} fBreakPoints.Remove(pointer(line)); {$POP} - if assigned(fBreakpointEvent) then - fBreakpointEvent(self, line, bpRemoved); + if assigned(fDebugger) then + fDebugger.removeBreakPoint(fFilename, line); +end; + +procedure TCESynMemo.removeDebugTimeMarks; +begin + //TODO-cGDB: clean gutter marks generated during the session end; function TCESynMemo.findBreakPoint(line: integer): boolean; @@ -2465,6 +2480,44 @@ begin else addBreakPoint(line); end; + +procedure TCESynMemo.debugStart(debugger: ICEDebugger); +begin + fDebugger := debugger; +end; + +procedure TCESynMemo.debugStop; +begin + fDebugger := nil; + removeDebugTimeMarks; +end; + +function TCESynMemo.debugQueryBpCount: integer; +begin + exit(fBreakPoints.Count); +end; + +procedure TCESynMemo.debugQueryBreakPoint(const index: integer; out fname: string; + out line: integer; out kind: TBreakPointKind); +begin + fname:= fFilename; + line := breakPointLine(index); + kind := bpkBreak; +end; + +procedure TCESynMemo.debugBreak(const fname: string; line: integer; + reason: TCEDebugBreakReason); +begin + if fname <> fFilename then + exit; + showPage; + caretY := line; + // TODO-cDBG: add markup according to break reason + case reason of + dbBreakPoint:; + dbSignal:; + end; +end; {$ENDREGION --------------------------------------------------------------------} {$ENDREGION --------------------------------------------------------------------}