From 36964ad84542f20b954b69f9356d2c00388c062e Mon Sep 17 00:00:00 2001 From: lazarus Date: Mon, 5 Nov 2001 00:12:51 +0000 Subject: [PATCH] MWE: First steps of a debugger. git-svn-id: trunk@388 - --- .gitattributes | 8 + debugger/cmdlinedebugger.pp | 309 +++++++++++++++++++++++++++++ debugger/dbgbreakpoint.pp | 73 +++++-- debugger/dbgoutputform.lrc | 7 + debugger/dbgoutputform.pp | 75 +++++++ debugger/dbgwatch.pp | 61 ++++-- debugger/debugger.pp | 188 ++++++++++++++---- debugger/gdbdebugger.pp | 264 ++++++++++++++++++++++++ debugger/tdbgoutputform.lfm | 16 ++ debugger/test/debugtest.pp | 14 ++ debugger/test/debugtestform.lrc | 32 +++ debugger/test/debugtestform.pp | 236 ++++++++++++++++++++++ debugger/test/examples/testcntr.pp | 24 +++ debugger/test/tdebugtesttorm.lfm | 132 ++++++++++++ ide/main.pp | 26 ++- 15 files changed, 1384 insertions(+), 81 deletions(-) create mode 100644 debugger/cmdlinedebugger.pp create mode 100644 debugger/dbgoutputform.lrc create mode 100644 debugger/dbgoutputform.pp create mode 100644 debugger/gdbdebugger.pp create mode 100644 debugger/tdbgoutputform.lfm create mode 100644 debugger/test/debugtest.pp create mode 100644 debugger/test/debugtestform.lrc create mode 100644 debugger/test/debugtestform.pp create mode 100644 debugger/test/examples/testcntr.pp create mode 100644 debugger/test/tdebugtesttorm.lfm diff --git a/.gitattributes b/.gitattributes index 9f068a3f63..78e4489a3f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -39,9 +39,17 @@ components/synedit/synhighlightercpp.pp svneol=native#text/pascal components/synedit/synhighlighterhtml.pp svneol=native#text/pascal components/synedit/synhighlighterpas.pp svneol=native#text/pascal components/synedit/syntextdrawer.pp svneol=native#text/pascal +debugger/cmdlinedebugger.pp svneol=native#text/pascal debugger/dbgbreakpoint.pp svneol=native#text/pascal +debugger/dbgoutputform.pp svneol=native#text/pascal debugger/dbgwatch.pp svneol=native#text/pascal debugger/debugger.pp svneol=native#text/pascal +debugger/gdbdebugger.pp svneol=native#text/pascal +debugger/tdbgoutputform.lfm svneol=native#text/plain +debugger/test/debugtest.pp svneol=native#text/pascal +debugger/test/debugtestform.pp svneol=native#text/pascal +debugger/test/examples/testcntr.pp svneol=native#text/pascal +debugger/test/tdebugtesttorm.lfm svneol=native#text/plain designer/abstractcompiler.pp svneol=native#text/pascal designer/abstracteditor.pp svneol=native#text/pascal designer/abstractfilesystem.pp svneol=native#text/pascal diff --git a/debugger/cmdlinedebugger.pp b/debugger/cmdlinedebugger.pp new file mode 100644 index 0000000000..ab67d84e3a --- /dev/null +++ b/debugger/cmdlinedebugger.pp @@ -0,0 +1,309 @@ +{ $Id$ } +{ ---------------------------------------------- + CMDLineDebugger.pp - Debugger class for + commandline debuggers + ---------------------------------------------- + + @created(Wed Feb 28st WET 2001) + @lastmod($Date$) + @author(Marc Weustink ) + + This unit contains the Commandline debugger class for external commandline + debuggers. + + +/*************************************************************************** + * * + * This program is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + ***************************************************************************/ +} +unit CmdLineDebugger; + +{$mode objfpc} +{$H+} + +interface + +uses + Classes, Process, Debugger{, strmlsnr}; + +type + TCmdLineDebugger = class(TDebugger) + private + FTargetProcess: TProcess; // The target process to be debugged + FDbgProcess: TProcess; // The process used to call the debugger + + FTargetOutputBuf: String; // Tempbuffer for process output + FOutputLines: TStringList; // Debugger output + + procedure GetOutput; + protected + WaitPrompt: String; // Prompt to wait for + procedure CreateDebugProcess(const AName: String); + procedure CreateTargetProcess(const AName: String); + procedure KillTargetProcess; + procedure SendCmdLn(const ACommand: String; const AGetOutput: Boolean); overload; + procedure SendCmdLn(const ACommand: String; Values: array of const; const AGetOutput: Boolean); overload; + property TargetProcess: TProcess read FTargetProcess; + property DebugProcess: TProcess read FDbgProcess; + property OutputLines: TStringList read FOutputLines; + public + constructor Create; override; + destructor Destroy; override; + procedure TestCmd(const ACommand: String); // For internal debugging purposes + end; + +procedure SendBreak(const AHandle: Integer); + +implementation + +uses + Linux, + SysUtils, Forms; + +////////////////////////////////////////////////// +// Needs to go to proper include +// Platform dependent +////////////////////////////////////////////////// + +{------------------------------------------------------------------------------ + Function: SendBreak + Params: AHandle THe handle of the proces tosend break to + Returns: + ------------------------------------------------------------------------------} +procedure SendBreak(const AHandle: Integer); +begin + if AHandle <> 0 + then Kill(AHandle, SIGINT); +end; + +{------------------------------------------------------------------------------ + Function: WaitForHandles + Params: AHandles: A set of handles to wait for (max 32) + Returns: BitArray of handles set, 0 when an error ocoured + ------------------------------------------------------------------------------} +function WaitForHandles(const AHandles: array of Integer): Integer; +var + n, R, Max, Count: Integer; + TimeOut: Integer; + FDSWait, FDS: TFDSet; +begin + Result := 0; + Max := 0; + Count := High(AHandles); + if Count < 0 then Exit; + if Count > 31 then Count := 31; + FD_ZERO(FDS); + + for n := 0 to Count do + begin + if Max < AHandles[n] then Max := AHandles[n]; + if AHandles[n] <> 0 + then FD_Set(AHandles[n], FDS); + end; + + repeat + FDSWait := FDS; + TimeOut := 10; + R := Select(Max + 1, @FDSWait, nil, nil, TimeOut); + Application.ProcessMessages; + until R <> 0; + + if R > 0 + then begin + for n := 0 to Count do + if (AHandles[n] <> 0) + and (FD_ISSET(AHandles[n], FDSWait)) + then begin + Result := Result or 1 shl n; + Dec(R); + if R=0 then Break; + end; + end; +end; + +////////////////////////////////////////////////// + +////////////////////////////////////////////////// +// Tools and utilities +// +////////////////////////////////////////////////// +function GetLine(var ABuffer: String): String; +var + idx: Integer; +begin + idx := Pos(#10, ABuffer); + if idx = 0 + then Result := '' + else begin + Result := Copy(ABuffer, 1, idx); + Delete(ABuffer, 1, idx); + end; +end; + +function StripLN(const ALine: String): String; +var + idx: Integer; +begin + idx := Pos(#10, ALine); + if idx = 0 + then Result := '' + else begin + if (idx > 1) + and (ALine[idx - 1] = #13) + then Dec(idx); + Result := Copy(ALine, 1, idx - 1); + end; +end; + +////////////////////////////////////////////////// + +{ TCmdLineDebugger } + +constructor TCmdLineDebugger.Create; +begin + FDbgProcess := nil; + FTargetProcess := nil; + FOutputLines := TStringList.Create; + FTargetOutputBuf := ''; + inherited Create; +end; + +procedure TCmdLineDebugger.CreateDebugProcess(const AName:String); +begin + if FDbgProcess = nil + then begin + FDbgProcess := TProcess.Create(AName, [poUsePipes, poNoConsole, poExecuteOnCreate]); + WriteLn('[TCmdLineDebugger] Debug PID: ', FDbgProcess.Handle); + GetOutput; + end; +end; + +procedure TCmdLineDebugger.CreateTargetProcess(const AName:String); +begin + // TODO: Better cleanup + FTargetProcess.Free; + FTargetProcess := TProcess.Create(AName, [poUsePipes, poNoConsole, poExecuteOnCreate, poRunSuspended]); + WriteLN('[TCmdLineDebugger] Target PID = ', FTargetProcess.Handle); +end; + +destructor TCmdLineDebugger.Destroy; +begin + inherited; + FDbgProcess.Free; + FTargetProcess.Free; +end; + +procedure TCmdLineDebugger.GetOutput; + function ReadData(const AStream: TStream; var ABuffer: String): Integer; + var + S: String; + begin + SetLength(S, 1024); + Result := AStream.Read(S[1], 1024); + if Result > 0 + then begin + SetLength(S, Result); + ABuffer := ABuffer + S; + end; + end; + +var + OutputBuf: String; + Line: String; + OutHandle: Integer; + WaitSet: Integer; + Count: Integer; +begin + WriteLN('[GetOutput] Enter'); + + if (FTargetProcess = nil) + then OutHandle := 0 + else OutHandle := FTargetProcess.Output.Handle; + + OutputBuf := ''; + Line := ''; + OutputLines.Clear; + repeat + WaitSet := WaitForHandles([FDbgProcess.Output.Handle, OutHandle]); + if WaitSet = 0 + then begin + WriteLN('[Getoutput] Error waiting '); + SetState(dsError); + Break; + end; + + if ((WaitSet and 1) <> 0) and (FDbgProcess <> nil) + then begin + Count := ReadData(FDbgProcess.Output, OutputBuf); + if Count > 0 + then while True do + begin + Line := GetLine(OutputBuf); + if Line = '' then Break; + Line := StripLN(Line); + if Line <> '' then FOutputLines.Add(Line); + DoDbgOutput(Line); + end; + end; + + if ((WaitSet and 2) <> 0) and (FTargetProcess <> nil) + then begin + Count := ReadData(FTargetProcess.Output, FTargetOutputBuf); + if Count > 0 + then while True do + begin + Line := StripLN(GetLine(FTargetOutputBuf)); + if Line = '' then Break; + DoOutput(Line); + end; + end; + until OutputBuf = WaitPrompt; + + WriteLN('[GetOutput] Leave'); +end; + +procedure TCmdLineDebugger.KillTargetProcess; +begin + FTargetProcess.Terminate(0); + FTargetProcess.WaitOnExit; + FTargetProcess.Free; + FTargetProcess:= nil; +end; + +procedure TCmdLineDebugger.SendCmdLn(const ACommand: String; const AGetOutput: Boolean); overload; +const + LF = #10; +begin + if FDbgProcess <> nil + then begin + WriteLN(Format('[TCmdLineDebugger.SendCmd] CMD: <%s>', [ACommand])); + FDbgProcess.Input.Write(ACommand[1], Length(ACommand)); + FDbgProcess.Input.Write(LF, 1); + if AGetOutput + then GetOutput; + end; +end; + +procedure TCmdLineDebugger.SendCmdLn(const ACommand: String; Values: array of const; const AGetOutput: Boolean); +begin + SendCmdLn(Format(ACommand, Values), AGetOutput); +end; + +procedure TCmdLineDebugger.TestCmd(const ACommand: String); +begin + SendCmdLn(ACommand, True); +end; + +end. +{ ============================================================================= + $Log$ + Revision 1.1 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + + +} diff --git a/debugger/dbgbreakpoint.pp b/debugger/dbgbreakpoint.pp index cc011e8530..1525f94b60 100644 --- a/debugger/dbgbreakpoint.pp +++ b/debugger/dbgbreakpoint.pp @@ -5,7 +5,7 @@ @created(Wed Feb 25st WET 2001) @lastmod($Date$) - @author(Marc Weustink ) + @author(Marc Weustink ) This unit contains the class definitions of the Breakpoints used by the debugger @@ -58,30 +58,40 @@ type property Valid: Boolean read FValid write SetValid; end; - TDBGBreakPointGroup = class(TCollection) + TDBGBreakPoints = class(TCollection) + private + function GetItem(const AnIndex: Integer): TDBGBreakPoint; + procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint); + protected + public + constructor Create; + property Items[const AnIndex: Integer]: TDBGBreakPoint read GetItem write SetItem; default; + end; + + TDBGBreakPointGroup = class(TCollectionItem) private FEnabled: Boolean; FName: String; - function GetItem(const AnIndex: Integer): TDBGBreakPoint; + FBreakpoints: TDBGBreakPoints; procedure SetEnabled(const AValue: Boolean); - procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint); procedure SetName(const AValue: String); protected public + constructor Create(ACollection: TCollection); override; + destructor Destroy; override; + property Breakpoints: TDBGBreakPoints read FBreakpoints; property Enabled: Boolean read FEnabled write SetEnabled; - property Items[const AnIndex: Integer]: TDBGBreakPoint - read GetItem write SetItem; default; property Name: String read FName write SetName; end; TDBGBreakPointGroups = class(TCollection) private function GetItem(const AnIndex: Integer): TDBGBreakPointGroup; - procedure SetItem(const AnIndex: Integer; const Value: TDBGBreakPointGroup); + procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPointGroup); protected public - property Items[const AnIndex: Integer]: TDBGBreakPointGroup - read GetItem write SetItem; default; + constructor Create; + property Items[const AnIndex: Integer]: TDBGBreakPointGroup read GetItem write SetItem; default; end; @@ -130,11 +140,31 @@ begin FValid := AValue; end; +{ TDBGBreakPoints } + +constructor TDBGBreakPoints.Create; +begin + inherited Create(TDBGBreakPoint); +end; + +function TDBGBreakPoints.GetItem(const AnIndex: Integer): TDBGBreakPoint; +begin + Result := TDBGBreakPoint(inherited GetItem(AnIndex)); +end; + +procedure TDBGBreakPoints.SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint); +begin +end; + { TDBGBreakPointGroup } -function TDBGBreakPointGroup.GetItem(const AnIndex: Integer): TDBGBreakPoint; +constructor TDBGBreakPointGroup.Create(ACollection: TCollection); +begin + inherited Create(ACollection); +end; + +destructor TDBGBreakPointGroup.Destroy; begin - Result:=nil; end; procedure TDBGBreakPointGroup.SetEnabled(const AValue: Boolean); @@ -142,11 +172,6 @@ begin FEnabled := AValue; end; -procedure TDBGBreakPointGroup.SetItem(const AnIndex: Integer; - const AValue: TDBGBreakPoint); -begin -end; - procedure TDBGBreakPointGroup.SetName(const AValue: String); begin FName := AValue; @@ -154,20 +179,26 @@ end; { TDBGBreakPointGroups } -function TDBGBreakPointGroups.GetItem( - const AnIndex: Integer): TDBGBreakPointGroup; +constructor TDBGBreakPointGroups.Create; begin - Result:=nil; + inherited Create(TDBGBreakPointGroup); end; -procedure TDBGBreakPointGroups.SetItem(const AnIndex: Integer; - const Value: TDBGBreakPointGroup); +function TDBGBreakPointGroups.GetItem(const AnIndex: Integer): TDBGBreakPointGroup; +begin + Result := TDBGBreakPointGroup(inherited GetItem(AnIndex)); +end; + +procedure TDBGBreakPointGroups.SetItem(const AnIndex: Integer; const AValue: TDBGBreakPointGroup); begin end; end. { ============================================================================= $Log$ + Revision 1.4 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + Revision 1.3 2001/10/18 13:01:31 lazarus MG: fixed speedbuttons numglyphs>1 and started IDE debugging diff --git a/debugger/dbgoutputform.lrc b/debugger/dbgoutputform.lrc new file mode 100644 index 0000000000..f2b31e762e --- /dev/null +++ b/debugger/dbgoutputform.lrc @@ -0,0 +1,7 @@ + LazarusResources.Add('TDbgOutputForm','FORMDATA', + 'TPF0'#14'TDbgOutputForm'#13'DbgOutputForm'#7'CAPTION'#6#12'Debug output'#8 + +'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#4'LEFT'#3#239#0 + +#6'HEIGHT'#3#150#0#3'TOP'#3#161#0#5'WIDTH'#3','#1#0#5'TMemo'#9'txtOutput' + +#4'Left'#2#8#3'Top'#2'h'#5'Width'#3'X'#2#6'Height'#3#150#0#5'Align'#7#8'a' + +'lClient'#0#0#0 + ); diff --git a/debugger/dbgoutputform.pp b/debugger/dbgoutputform.pp new file mode 100644 index 0000000000..165956f332 --- /dev/null +++ b/debugger/dbgoutputform.pp @@ -0,0 +1,75 @@ +{ $Id$ } +{ ---------------------------------------- + dbgoutputform.pp - Shows target output + ---------------------------------------- + + @created(Wed Feb 25st WET 2001) + @lastmod($Date$) + @author(Marc Weustink ) + +*************************************************************************** + * * + * This program is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + ***************************************************************************/ +} +unit dbgoutputform; + +{$mode objfpc} +{$H+} + +interface + +uses + Classes, Graphics, Controls, Forms, Dialogs, LResources, + Buttons, StdCtrls, Debugger; + +type + TDbgOutputForm = class(TForm) + txtOutput: TMemo; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + protected + procedure Loaded; override; + public + procedure AddText(const AText: String); + end; + +implementation + +procedure TDbgOutputForm.AddText(const AText: String); +begin + txtOutput.Lines.Add(AText); +end; + +procedure TDbgOutputForm.FormCreate(Sender: TObject); +begin + txtOutput.Lines.Clear; +end; + +procedure TDbgOutputForm.FormDestroy(Sender: TObject); +begin +end; + +procedure TDbgOutputForm.Loaded; +begin + inherited Loaded; + + // Not yet through resources + txtOutput.Scrollbars := ssBoth; +end; + +initialization + {$I dbgoutputform.lrc} + +end. +{ ============================================================================= + $Log$ + Revision 1.1 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + +} diff --git a/debugger/dbgwatch.pp b/debugger/dbgwatch.pp index 6a593c386c..0bf011ad8c 100644 --- a/debugger/dbgwatch.pp +++ b/debugger/dbgwatch.pp @@ -5,7 +5,7 @@ @created(Wed Feb 25st WET 2001) @lastmod($Date$) - @author(Marc Weustink ) + @author(Marc Weustink ) This unit contains the class definitions of the Watches used by the debugger @@ -31,56 +31,87 @@ uses type TDBGWatch = class(TCollectionItem) private - FValue: String; - FName: String; + FEnabled: Boolean; + FExpression: String; FOnChange: TNotifyEvent; + function GetValid: Boolean; + function GetValue: String; + procedure SetEnabled(const AValue: Boolean); + procedure SetExpression(const AValue: String); procedure SetValue(const AValue: String); - procedure SetName(const AValue: String); protected public - property Name: String read FName write SetName; - property Value: String read FValue write SetValue; + property Enabled: Boolean read FEnabled write SetEnabled; + property Expression: String read FExpression write SetExpression; + property Valid: Boolean read GetValid; + property Value: String read GetValue write SetValue; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TDBGWatches = class(TCollection) private function GetItem(const AnIndex: Integer): TDBGWatch; - procedure SetItem(const AnIndex: Integer; const Value: TDBGWatch); + procedure SetItem(const AnIndex: Integer; const AValue: TDBGWatch); protected public - property Items[const AnIndex: Integer]: TDBGWatch - read GetItem write SetItem; default; + constructor Create; + property Items[const AnIndex: Integer]: TDBGWatch read GetItem write SetItem; default; end; implementation { TDBGWatch } -procedure TDBGWatch.SetName(const AValue: String); +function TDBGWatch.GetValid: Boolean; begin - FName := AValue; + Result := False; +end; + +function TDBGWatch.GetValue: String; +begin + if Valid + then begin + end + else Result := ''; +end; + +procedure TDBGWatch.SetEnabled(const AValue: Boolean); +begin + FEnabled := AValue; +end; + +procedure TDBGWatch.SetExpression(const AValue: String); +begin + FExpression := AValue; end; procedure TDBGWatch.SetValue(const AValue: String); begin - FValue := AValue; end; { TDBGWatches } -function TDBGWatches.GetItem(const AnIndex: Integer): TDBGWatch; +constructor TDBGWatches.Create; begin - Result:=nil + inherited Create(TDBGWatch); end; -procedure TDBGWatches.SetItem(const AnIndex: Integer; const Value: TDBGWatch); +function TDBGWatches.GetItem(const AnIndex: Integer): TDBGWatch; begin + Result := TDBGWatch(inherited GetItem(AnIndex)); +end; + +procedure TDBGWatches.SetItem(const AnIndex: Integer; const AValue: TDBGWatch); +begin + inherited SetItem(AnIndex, AValue); end; end. { ============================================================================= $Log$ + Revision 1.4 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + Revision 1.3 2001/10/18 13:01:31 lazarus MG: fixed speedbuttons numglyphs>1 and started IDE debugging diff --git a/debugger/debugger.pp b/debugger/debugger.pp index 82e18a45b3..086543fa0b 100644 --- a/debugger/debugger.pp +++ b/debugger/debugger.pp @@ -1,11 +1,11 @@ { $Id$ } { ---------------------------------------- - DBGDebugger.pp - Debugger base classes + Debugger.pp - Debugger base classes ---------------------------------------- @created(Wed Feb 25st WET 2001) @lastmod($Date$) - @author(Marc Weustink ) + @author(Marc Weustink ) This unit contains the base class definitions of the debugger. These classes are only definitions. Implemented debuggers should be @@ -30,102 +30,218 @@ uses Classes, DBGWatch, DBGBreakpoint; type - TDBGCommandFlags = set of (dcfRun, dcfPause, dcfStop, dcfStepOver, dcfStepInto, - dcfRunTo, dcfJumpto, dcfBreak); - TDBGState = (dsStop, dsPause, dsRun, dsError); + TDBGLocationRec = record + Adress: Pointer; + FuncName: String; + SrcFile: String; + SrcLine: Integer; + end; - TDBGCurrentLineEvent = procedure(Sender: TObject; const AFilename: String; - const ALine: Integer) of object; + TDBGCommand = (dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcRunTo, dcJumpto, dcBreak); + TDBGCommands = set of TDBGCommand; + TDBGState = (dsNone, dsIdle, dsStop, dsPause, dsRun, dsError); - TDebugger = class + TDBGOutputEvent = procedure(Sender: TObject; const AText: String) of object; + TDBGCurrentLineEvent = procedure(Sender: TObject; const ALocation: TDBGLocationRec) of object; + + TDebugger = class(TObject) private - FFileName: String; + FArguments: String; FBreakPointGroups: TDBGBreakPointGroups; - FOnCurrent: TDBGCurrentLineEvent; - FOnState: TNotifyEvent; + FFileName: String; + FState: TDBGState; FWatches: TDBGWatches; + FOnCurrent: TDBGCurrentLineEvent; + FOnOutput: TDBGOutputEvent; + FOnDbgOutput: TDBGOutputEvent; + FOnState: TNotifyEvent; + function GetState: TDBGState; + function ReqCmd(const ACommand: TDBGCommand; const AParams: array of const): Boolean; protected - function GetDBGState: TDBGState; virtual; + procedure DoCurrent(const ALocation: TDBGLocationRec); + procedure DoDbgOutput(const AText: String); + procedure DoOutput(const AText: String); + procedure DoState; + function GetFlags: TDBGCommands; virtual; + function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; virtual; abstract; // True if succesful procedure SetFileName(const Value: String); virtual; - function GetFlags: TDBGCommandFlags; virtual; + procedure SetState(const Value: TDBGState); public - procedure Init; virtual; // Initializes external debugger - procedure Done; virtual; // Kills external debugger - procedure Run; virtual; // Starts / continues debugging - procedure Pause; virtual; // Stops running - procedure Stop; virtual; // quit debugging - procedure StepOver; virtual; - procedure StepInto; virtual; - procedure RunTo(const AFilename: String; const ALine: Integer); virtual; // Executes til a certain point - procedure JumpTo(const AFilename: String; const ALine: Integer); virtual; // No execute, only set exec point - property BreakPointGroups: TDBGBreakPointGroups read FBreakPointGroups; // list of all breakpoints - property FileName: String read FFileName write SetFileName; // The name of the exe to be debugged - property Flags: TDBGCommandFlags read GetFlags; // All available commands of the debugger - property State: TDBGState read GetDBGState; - property Watches: TDBGWatches read FWatches; // list of all watches localvars etc - property OnState: TNotifyEvent read FOnState write FOnState; // Fires when the current state of the debugger changes - property OnCurrent: TDBGCurrentLineEvent read FOnCurrent write FOnCurrent; //Passes info about the current line being debugged + constructor Create; virtual; + destructor Destroy; override; + + procedure Init; virtual; // Initializes the debugger + procedure Done; virtual; // Kills the debugger + procedure Run; // Starts / continues debugging + procedure Pause; // Stops running + procedure Stop; // quit debugging + procedure StepOver; + procedure StepInto; + procedure RunTo(const ASource: String; const ALine: Integer); virtual; // Executes til a certain point + procedure JumpTo(const ASource: String; const ALine: Integer); virtual; // No execute, only set exec point + property Arguments: String read FArguments write FArguments; // Arguments feed to the program + property BreakPointGroups: TDBGBreakPointGroups read FBreakPointGroups; // list of all breakpoints + property FileName: String read FFileName write SetFileName; // The name of the exe to be debugged + property Flags: TDBGCommands read GetFlags; // All available commands of the debugger + property State: TDBGState read FState; // The current stete of the debugger + property Watches: TDBGWatches read FWatches; // list of all watches localvars etc + property OnCurrent: TDBGCurrentLineEvent read FOnCurrent write FOnCurrent; // Passes info about the current line being debugged + property OnState: TNotifyEvent read FOnState write FOnState; // Fires when the current state of the debugger changes + property OnOutput: TDBGOutputEvent read FOnOutput write FOnOutput; // Passes all output of the debugged target + property OnDbgOutput: TDBGOutputEvent read FOnDbgOutput write FOnDbgOutput;// Passes all debuggeroutput end; implementation +uses + SysUtils; + +const + COMMANDMAP: array[TDBGState] of TDBGCommands = ( + {dsNone } [dcBreak], + {dsIdle } [dcRun, dcStepOver, dcStepInto, dcRunTo, dcJumpto, dcBreak], + {dsStop } [dcRun, dcStepOver, dcStepInto, dcRunTo, dcJumpto, dcBreak], + {dsPause} [dcRun, dcStop, dcStepOver, dcStepInto, dcRunTo, dcJumpto, dcBreak], + {dsRun } [dcPause, dcStop, dcBreak], + {dsError} [] + ); + { TDebugger } +constructor TDebugger.Create; +begin + inherited Create; + FOnState := nil; + FOnCurrent := nil; + FOnOutput := nil; + FOnDbgOutput := nil; + FState := dsNone; + FArguments := ''; + FFilename := ''; + FBreakPointGroups := TDBGBreakPointGroups.Create; + FWatches := TDBGWatches.Create; +end; + +destructor TDebugger.Destroy; +begin + // don't call events + FOnState := nil; + FOnCurrent := nil; + FOnOutput := nil; + FOnDbgOutput := nil; + + if FState <> dsNone + then Done; + + FBreakPointGroups.Free; + FWatches.Free; + inherited; +end; + procedure TDebugger.Done; begin + SetState(dsNone); end; - -function TDebugger.GetDBGState: TDBGState; +procedure TDebugger.DoCurrent(const ALocation: TDBGLocationRec); begin - Result:=dsStop; + if Assigned(FOnCurrent) then FOnCurrent(Self, ALocation); end; -function TDebugger.GetFlags: TDBGCommandFlags; +procedure TDebugger.DoDbgOutput(const AText: String); begin - Result:=[dcfStop]; + if Assigned(FOnDbgOutput) then FOnDbgOutput(Self, AText); +end; + +procedure TDebugger.DoOutput(const AText: String); +begin + if Assigned(FOnOutput) then FOnOutput(Self, AText); +end; + +procedure TDebugger.DoState; +begin + if Assigned(FOnState) then FOnState(Self); +end; + +function TDebugger.GetState: TDBGState; +begin + Result := FState; +end; + +function TDebugger.GetFlags: TDBGCommands; +begin + Result := []; end; procedure TDebugger.Init; begin + SetState(dsIdle); end; -procedure TDebugger.JumpTo(const AFilename: String; const ALine: Integer); +procedure TDebugger.JumpTo(const ASource: String; const ALine: Integer); begin + ReqCmd(dcJumpTo, [ASource, ALine]); end; procedure TDebugger.Pause; begin + ReqCmd(dcPause, []); +end; + +function TDebugger.ReqCmd(const ACommand: TDBGCommand; const AParams: array of const): Boolean; +begin + if FState = dsNone then Init; + if ACommand in (COMMANDMAP[FState] * Flags) + then Result := RequestCommand(ACommand, AParams) + else Result := False; end; procedure TDebugger.Run; begin + ReqCmd(dcRun, []); end; -procedure TDebugger.RunTo(const AFilename: String; const ALine: Integer); +procedure TDebugger.RunTo(const ASource: String; const ALine: Integer); begin + ReqCmd(dcRunTo, [ASource, ALine]); end; procedure TDebugger.SetFileName(const Value: String); begin + FFileName := Value; +end; + +procedure TDebugger.SetState(const Value: TDBGState); +begin + if Value <> FState + then begin + FState := Value; + DoState; + end; end; procedure TDebugger.StepInto; begin + ReqCmd(dcStepInto, []); end; procedure TDebugger.StepOver; begin + ReqCmd(dcStepOver, []); end; procedure TDebugger.Stop; begin + ReqCmd(dcStop, []); end; end. { ============================================================================= $Log$ + Revision 1.3 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + Revision 1.2 2001/10/18 13:01:31 lazarus MG: fixed speedbuttons numglyphs>1 and started IDE debugging diff --git a/debugger/gdbdebugger.pp b/debugger/gdbdebugger.pp new file mode 100644 index 0000000000..f457f15eb5 --- /dev/null +++ b/debugger/gdbdebugger.pp @@ -0,0 +1,264 @@ +{ $Id$ } +{ ---------------------------------------------- + GDBDebugger.pp - Debugger class forGDB + ---------------------------------------------- + + @created(Wed Feb 28st WET 2001) + @lastmod($Date$) + @author(Marc Weustink ) + + This unit contains the Commandline debugger class for the GDB + debugger. + + +/*************************************************************************** + * * + * This program is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + ***************************************************************************/ +} +unit GDBDebugger; + +{$mode objfpc} +{$H+} + +interface + +uses + Classes, Process, Debugger, CmdLineDebugger; + +type + + TGDBDebugger = class(TCmdLineDebugger) + private + procedure GDBRun; + procedure GDBPause; + procedure GDBStop; + procedure GDBStepOver; + procedure GDBStepInto; + procedure GDBRunTo(const ASource: String; const ALine: Integer); + procedure GDBJumpTo(const ASource: String; const ALine: Integer); + procedure RunCommand(const ACommand: String); + function GetGDBState: TDBGState; + function GetLocation: TDBGLocationRec; + protected + function GetFlags: TDBGCommands; override; + function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override; + public + constructor Create; override; + destructor Destroy; override; + + procedure Init; override; // Initializes external debugger + procedure Done; override; // Kills external debugger + end; + + +implementation + +uses + SysUtils; + +{ TGDBDebugger } + +constructor TGDBDebugger.Create; +begin + inherited Create; +end; + +destructor TGDBDebugger.Destroy; +begin + inherited; +end; + +procedure TGDBDebugger.Done; +begin + if State = dsRun then GDBPause; + SendCmdLn('quit', False); + inherited Done; +end; + +procedure TGDBDebugger.GDBJumpTo(const ASource: String; const ALine: Integer); +begin +end; + +procedure TGDBDebugger.GDBPause; +begin + SendBreak(TargetProcess.Handle); +end; + +procedure TGDBDebugger.GDBRun; +var + loc: TDBGLocationRec; + dState: TDBGState; +begin + case State of + dsIdle, dsStop: begin + CreateTargetProcess(FileName); + + SendCmdLn('file %s', [FileName], True); + SendCmdLn('attach %d', [TargetProcess.Handle], True); + + TargetProcess.Resume; + SetState(dsRun); + + repeat + SendCmdLn('cont', True); + loc := GetLocation; + dState := GetGDBState; + until ((loc.FuncName <> 'HEAP') and (loc.FuncName <> '_start')) or (dState <> dsPause); + DoCurrent(loc); + SetState(dState); + end; + dsPause: begin + RunCommand('cont'); + end; + end; +end; + +procedure TGDBDebugger.GDBRunTo(const ASource: String; const ALine: Integer); +begin +end; + +procedure TGDBDebugger.GDBStepInto; +begin + RunCommand('step'); +end; + +procedure TGDBDebugger.GDBStepOver; +begin + RunCommand('next'); +end; + +procedure TGDBDebugger.GDBStop; +var + dState: TDBGState; +begin + if State = dsRun + then begin + GDBPause; + // wait till pause is executed + SendCmdLn('', True); + end; + + dState := GetGDBState; + if dState = dsRun + then Exit; + + if dState = dsPause + then begin + SendCmdLn('kill', True); + dState := GetGDBState; + end; + if dState = dsStop + then KillTargetProcess; + SetState(dState); +end; + +function TGDBDebugger.GetFlags: TDBGCommands; +begin + Result := [dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcRunTo, dcJumpto, dcBreak] +end; + +function TGDBDebugger.GetGDBState: TDBGState; +var + S: String; +begin + SendCmdLn('info program', True); + S := OutputLines.Text; + if Pos('stopped', S) > 0 + then Result := dsPause + else if Pos('not being run', S) > 0 + then Result := dsStop + else Result := dsNone; +end; + +function TGDBDebugger.GetLocation: TDBGLocationRec; +var + n, idx: Integer; + NoSrc: Boolean; + S: String; +begin + Result.Adress := nil; + Result.FuncName := ''; + Result.SrcFile := ''; + Result.SrcLine := -1; + + SendCmdLn('info frame', True); + for n := 0 to OutputLines.Count - 1 do + begin + S := OutputLines[n]; + idx := Pos('eip = 0x', S); + if idx = 0 then Continue; + + // Get addr + Delete(S, 1, idx + 7); + idx := Pos('in', S); + if idx = 0 then Break; + Result.Adress := Pointer(StrToIntDef('$' + Copy(S, 1, idx - 2), 0)); + + // get function + Delete(S, 1, idx + 2); + idx := Pos(' (', S); + NoSrc := (idx = 0); + if NoSrc + then idx := Pos(';',S); + Result.FuncName := Copy(S, 1, idx - 1); + if NoSrc then Break; + + // getsource info + Delete(S, 1, idx + 1); + idx := Pos(':', S); + if idx = 0 then Break; + Result.SrcFile := Copy(S, 1, idx - 1); + Delete(S, 1, idx); + idx := Pos(')', S); + if idx = 0 then Break; + Result.SrcLine := StrToIntDef(Copy(S, 1, idx - 1), 0); + end; +end; + +procedure TGDBDebugger.Init; +begin + WaitPrompt := '(gdb) '; + if DebugProcess = nil + then begin + CreateDebugProcess('/usr/bin/gdb -silent'); + SendCmdLn('', True); + end; + SendCmdLn('set confirm off', True); + inherited Init; +end; + +function TGDBDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; +begin + case ACommand of + dcRun: GDBRun; + dcPause: GDBPause; + dcStop: GDBStop; + dcStepOver: GDBStepOver; + dcStepInto: GDBStepInto; + dcRunTo: GDBRunTo(String(APArams[0].VAnsiString), APArams[1].VInteger); + dcJumpto: GDBJumpTo(String(APArams[0].VAnsiString), APArams[1].VInteger); + end; + Result := True; +end; + +procedure TGDBDebugger.RunCommand(const ACommand: String); +begin + SetState(dsRun); + SendCmdLn(ACommand, True); + DoCurrent(GetLocation); + SetState(GetGDBState); +end; + +end. +{ ============================================================================= + $Log$ + Revision 1.1 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + + +} diff --git a/debugger/tdbgoutputform.lfm b/debugger/tdbgoutputform.lfm new file mode 100644 index 0000000000..7399de8726 --- /dev/null +++ b/debugger/tdbgoutputform.lfm @@ -0,0 +1,16 @@ +object DbgOutputForm: TDbgOutputForm + CAPTION = 'Debug output' + OnCreate = FormCreate + OnDestroy = FormDestroy + LEFT = 239 + HEIGHT = 150 + TOP = 161 + WIDTH = 300 + object txtOutput: TMemo + Left = 8 + Top = 104 + Width = 600 + Height = 150 + Align = alClient + end +end diff --git a/debugger/test/debugtest.pp b/debugger/test/debugtest.pp new file mode 100644 index 0000000000..f0490648b1 --- /dev/null +++ b/debugger/test/debugtest.pp @@ -0,0 +1,14 @@ +program debugtest; + +{$mode objfpc} +{$H+} + + +uses + Classes, Forms, DebugTestForm; + +begin + Application.Initialize; + Application.CreateForm(TDebugTestForm, DebugTestForm1); + Application.Run; +end. diff --git a/debugger/test/debugtestform.lrc b/debugger/test/debugtestform.lrc new file mode 100644 index 0000000000..9604f41087 --- /dev/null +++ b/debugger/test/debugtestform.lrc @@ -0,0 +1,32 @@ + LazarusResources.Add('TDebugTestForm','FORMDATA', + 'TPF0'#14'TDebugTestForm'#13'DebugTestForm'#7'CAPTION'#6#13'DebugTestForm' + +#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#4'LEFT'#3#239 + +#0#6'HEIGHT'#3','#1#3'TOP'#3#161#0#5'WIDTH'#3'l'#2#0#7'TBUTTON'#7'cmdInit' + +#7'CAPTION'#6#4'Init'#4'LEFT'#2#10#6'HEIGHT'#2#25#3'TOP'#2''''#5'WIDTH'#2 + +'2'#7'OnClick'#7#12'cmdInitClick'#0#0#7'TBUTTON'#7'cmdDone'#7'CAPTION'#6#4 + +'Done'#4'LEFT'#2'F'#6'HEIGHT'#2#25#3'TOP'#2''''#5'WIDTH'#2'2'#7'OnClick'#7 + +#12'cmdDoneClick'#0#0#7'TBUTTON'#6'cmdRun'#7'CAPTION'#6#3'Run'#4'LEFT'#3 + +#130#0#6'HEIGHT'#2#25#3'TOP'#2''''#5'WIDTH'#2'2'#7'OnClick'#7#11'cmdRunCl' + +'ick'#0#0#7'TBUTTON'#8'cmdPause'#7'CAPTION'#6#5'Pause'#4'LEFT'#3#190#0#6 + +'HEIGHT'#2#25#3'TOP'#2''''#5'WIDTH'#2'2'#7'OnClick'#7#13'cmdPauseClick'#0 + +#0#7'TBUTTON'#7'cmdStop'#7'CAPTION'#6#4'Stop'#4'LEFT'#3#250#0#6'HEIGHT'#2 + +#25#3'TOP'#2''''#5'WIDTH'#2'2'#7'OnClick'#7#12'cmdStopClick'#0#0#7'TBUTTO' + +'N'#7'cmdStep'#7'CAPTION'#6#4'Step'#4'LEFT'#3'6'#1#6'HEIGHT'#2#25#3'TOP'#2 + +''''#5'WIDTH'#2'2'#7'OnClick'#7#12'cmdStepClick'#0#0#7'TBUTTON'#11'cmdSte' + +'pInto'#7'CAPTION'#6#9'Step into'#4'LEFT'#3'r'#1#6'HEIGHT'#2#25#3'TOP'#2 + +''''#5'WIDTH'#2'2'#7'OnClick'#7#16'cmdStepIntoClick'#0#0#6'TLabel'#8'lblS' + +'tate'#4'Left'#2#8#3'Top'#2'h'#5'WIDTH'#2'2'#0#0#6'TLabel'#9'lblAdress'#4 + +'Left'#2':'#3'Top'#2'h'#5'WIDTH'#2'd'#0#0#6'TLabel'#9'lblSource'#4'Left'#3 + +#166#0#3'Top'#2'h'#5'WIDTH'#2'd'#0#0#6'TLabel'#7'lblLine'#4'Left'#3#18#1#3 + +'Top'#2'h'#5'WIDTH'#2'd'#0#0#6'TLabel'#7'lblFunc'#4'Left'#3'~'#1#3'Top'#2 + +'h'#5'WIDTH'#2'd'#0#0#5'TMemo'#6'txtLog'#4'Left'#2#8#3'Top'#3#132#0#5'Wid' + +'th'#3'X'#2#6'Height'#3#150#0#0#0#7'TButton'#10'cmdCommand'#4'Left'#3#252 + +#0#3'Top'#2'G'#5'Width'#2'2'#6'Height'#2#25#7'Caption'#6#3'CMD'#7'OnClick' + +#7#15'cmdCommandClick'#0#0#7'TButton'#8'cmdCLear'#4'Left'#3'9'#1#3'Top'#2 + +'G'#5'Width'#2'2'#6'Height'#2#25#7'Caption'#6#5'Clear'#7'OnClick'#7#13'cm' + +'dClearClick'#0#0#5'TEdit'#10'txtCommand'#4'Left'#2#8#3'Top'#2'H'#5'Width' + +#3#237#0#6'Height'#2#24#4'Text'#6#0#0#0#6'TLabel'#11'lblFileName'#4'Left' + +#2#8#3'Top'#2#8#5'WIDTH'#2'F'#7'Caption'#6#9'Filename:'#0#0#5'TEdit'#11't' + +'xtFileName'#4'Left'#2'F'#3'Top'#2#8#5'Width'#3'%'#1#6'Height'#2#24#4'Tex' + +'t'#6#0#0#0#0 + ); diff --git a/debugger/test/debugtestform.pp b/debugger/test/debugtestform.pp new file mode 100644 index 0000000000..f1baad62d8 --- /dev/null +++ b/debugger/test/debugtestform.pp @@ -0,0 +1,236 @@ +{ $Id$ } +{ ---------------------------------------- + debugtestform.pp - Debugger test app + ---------------------------------------- + + @created(Wed Feb 25st WET 2001) + @lastmod($Date$) + @author(Marc Weustink ) + +*************************************************************************** + * * + * This program is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + ***************************************************************************/ +} +unit debugtestform; + +{$mode objfpc} +{$H+} + +interface + +uses + Classes, Graphics, Controls, Forms, Dialogs, LResources, + Buttons, StdCtrls, Debugger, DbgOutputForm; + +type + TDebugTestForm = class(TForm) + cmdInit : TButton; + cmdDone : TButton; + cmdRun : TButton; + cmdPause : TButton; + cmdStop : TButton; + cmdStep : TButton; + cmdStepInto : TButton; + lblFileName: TLabel; + lblAdress: TLabel; + lblSource: TLabel; + lblLine: TLabel; + lblFunc: TLabel; + lblState: TLabel; + txtLog: TMemo; + cmdCommand: TButton; + cmdClear: TButton; + txtCommand: TEdit; + txtFileName: TEdit; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure cmdInitClick(Sender: TObject); + procedure cmdDoneClick(Sender: TObject); + procedure cmdRunClick(Sender: TObject); + procedure cmdPauseClick(Sender: TObject); + procedure cmdStopClick(Sender: TObject); + procedure cmdStepClick(Sender: TObject); + procedure cmdStepIntoClick(Sender: TObject); + procedure cmdCommandClick(Sender: TObject); + procedure cmdClearClick(Sender: TObject); + private + FDebugger: TDebugger; + FOutputForm: TDBGOutputForm; + procedure DBGState(Sender: TObject); + procedure DBGCurrent(Sender: TObject; const ALocation: TDBGLocationRec); + procedure DBGOutput(Sender: TObject; const AText: String); + procedure DBGTargetOutput(Sender: TObject; const AText: String); + procedure OutputFormDestroy(Sender: TObject); + protected + procedure Loaded; override; + public + destructor Destroy; override; + end; + +var + DebugTestForm1: TDebugTestForm; + +implementation + +uses + SysUtils, + GDBDebugger; + +procedure TDebugTestForm.Loaded; +begin + inherited Loaded; + + // Not yet through resources + txtLog.Scrollbars := ssBoth; +end; + +destructor TDebugTestForm.Destroy; +begin + // This shouldn't be needed, but the OnDestroy event isn't called + inherited; + FormDestroy(Self); +end; + +procedure TDebugTestForm.FormCreate(Sender: TObject); +begin + txtLog.Lines.Clear; + FDebugger := nil; +end; + +procedure TDebugTestForm.FormDestroy(Sender: TObject); +begin + FDebugger.Free; + FDebugger := nil; +end; + +procedure TDebugTestForm.cmdInitClick(Sender: TObject); +begin + if FDebugger = nil + then begin + FDebugger := TGDBDebugger.Create; + FDebugger.OnDbgOutput := @DBGOutput; + FDebugger.OnOutput := @DBGTargetOutput; + FDebugger.OnCurrent := @DBGCurrent; + FDebugger.OnState := @DBGState; + + FOutputForm := TDBGOutputForm.Create(nil); + FOutputForm.OnDestroy := @OutputFormDestroy; + FOutputForm.Show; + end; + FDebugger.Init; +end; + +procedure TDebugTestForm.cmdDoneClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.Done; + FDebugger.Free; + FDebugger := nil; + end; +end; + +procedure TDebugTestForm.cmdRunClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.FileName := txtFileName.Text; + FDebugger.Run; + end; +end; + +procedure TDebugTestForm.cmdPauseClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.Pause; + end; +end; + +procedure TDebugTestForm.cmdStepClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.StepOver; + end; +end; + +procedure TDebugTestForm.cmdStepIntoClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.StepInto; + end; +end; + +procedure TDebugTestForm.cmdStopClick(Sender: TObject); +begin + if FDebugger <> nil + then begin + FDebugger.Stop; + end; +end; + +procedure TDebugTestForm.cmdCommandClick(Sender: TObject); +begin + TGDBDebugger(FDebugger).TestCmd(txtCommand.Text); +end; + +procedure TDebugTestForm.cmdClearClick(Sender: TObject); +begin + txtLog.Lines.Clear; +end; + +procedure TDebugTestForm.OutputFormDestroy(Sender: TObject); +begin + FOutputForm := nil; +end; + +procedure TDebugTestForm.DBGOutput(Sender: TObject; const AText: String); +begin + txtLog.Lines.Add(AText); +end; + +procedure TDebugTestForm.DBGTargetOutput(Sender: TObject; const AText: String); +begin + if FOutputForm <> nil + then FOutputForm.AddText(AText); +end; + +procedure TDebugTestForm.DBGCurrent(Sender: TObject; const ALocation: TDBGLocationRec); +begin + lblAdress.Caption := Format('$%p', [ALocation.Adress]); + lblSource.Caption := ALocation.SrcFile; + lblLine.Caption := IntToStr(ALocation.SrcLine); + lblFunc.Caption := ALocation.FuncName; +end; + +procedure TDebugTestForm.DBGState(Sender: TObject); +begin + case FDebugger.State of + dsNone :lblState.Caption := 'dsNone '; + dsIdle :lblState.Caption := 'dsIdle '; + dsStop :lblState.Caption := 'dsStop '; + dsPause:lblState.Caption := 'dsPause'; + dsRun :lblState.Caption := 'dsRun '; + dsError:lblState.Caption := 'dsError'; + else + lblState.Caption := '?'; + end; +end; + +initialization + {$I debugtestform.lrc} + +end. +{ ============================================================================= + $Log$ + Revision 1.1 2001/11/05 00:12:51 lazarus + MWE: First steps of a debugger. + +} diff --git a/debugger/test/examples/testcntr.pp b/debugger/test/examples/testcntr.pp new file mode 100644 index 0000000000..70c81fd560 --- /dev/null +++ b/debugger/test/examples/testcntr.pp @@ -0,0 +1,24 @@ +program testcntr; + +uses + SysUtils; + +var + m, n, x : Cardinal; + time: TDateTime; +begin + m :=0; + x := 0; + while x < 3 do + begin + repeat + Write(Format('[%.10d] ', [m])); + Inc(m); + for n := 0 to 79 do Write('.'); + WriteLN; + until m mod 10 = 0; + time := now; + while (now - time) * SecsPerDay < 10 do; + inc(x); + end; +end. \ No newline at end of file diff --git a/debugger/test/tdebugtesttorm.lfm b/debugger/test/tdebugtesttorm.lfm new file mode 100644 index 0000000000..0f0689f996 --- /dev/null +++ b/debugger/test/tdebugtesttorm.lfm @@ -0,0 +1,132 @@ +object DebugTestForm: TDebugTestForm + CAPTION = 'DebugTestForm' + OnCreate = FormCreate + OnDestroy = FormDestroy + LEFT = 239 + HEIGHT = 300 + TOP = 161 + WIDTH = 620 + object cmdInit: TBUTTON + CAPTION = 'Init' + LEFT = 10 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdInitClick + end + object cmdDone: TBUTTON + CAPTION = 'Done' + LEFT = 70 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdDoneClick + end + object cmdRun: TBUTTON + CAPTION = 'Run' + LEFT = 130 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdRunClick + end + object cmdPause: TBUTTON + CAPTION = 'Pause' + LEFT = 190 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdPauseClick + end + object cmdStop: TBUTTON + CAPTION = 'Stop' + LEFT = 250 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdStopClick + end + object cmdStep: TBUTTON + CAPTION = 'Step' + LEFT = 310 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdStepClick + end + object cmdStepInto: TBUTTON + CAPTION = 'Step into' + LEFT = 370 + HEIGHT = 25 + TOP = 39 + WIDTH = 50 + OnClick = cmdStepIntoClick + end + object lblState: TLabel + Left = 8 + Top = 104 + WIDTH = 50 + end + object lblAdress: TLabel + Left = 58 + Top = 104 + WIDTH = 100 + end + object lblSource: TLabel + Left = 166 + Top = 104 + WIDTH = 100 + end + object lblLine: TLabel + Left = 274 + Top = 104 + WIDTH = 100 + end + object lblFunc: TLabel + Left = 382 + Top = 104 + WIDTH = 100 + end + object txtLog: TMemo + Left = 8 + Top = 132 + Width = 600 + Height = 150 + end + object cmdCommand: TButton + Left = 252 + Top = 71 + Width = 50 + Height = 25 + Caption = 'CMD' + OnClick = cmdCommandClick + end + object cmdCLear: TButton + Left = 313 + Top = 71 + Width = 50 + Height = 25 + Caption = 'Clear' + OnClick = cmdClearClick + end + object txtCommand: TEdit + Left = 8 + Top = 72 + Width = 237 + Height = 24 + Text = '' + end + object lblFileName: TLabel + Left = 8 + Top = 8 + WIDTH = 70 + Caption = 'Filename:' + end + object txtFileName: TEdit + Left = 70 + Top = 8 + Width = 293 + Height = 24 + Text = '' + end +end diff --git a/ide/main.pp b/ide/main.pp index 43fdcea268..2f7b14a645 100644 --- a/ide/main.pp +++ b/ide/main.pp @@ -220,8 +220,7 @@ type // Debugger Events procedure OnDebuggerChangeState(Sender: TObject); - procedure OnDebuggerCurrentLine(Sender: TObject; const AFilename: String; - const ALine: Integer); + procedure OnDebuggerCurrentLine(Sender: TObject; const ALocation: TDBGLocationRec); // MessagesView Events procedure MessagesViewSelectionChanged(sender : TObject); @@ -3471,20 +3470,23 @@ begin end; end; -procedure TMainIDE.OnDebuggerCurrentLine(Sender: TObject; - const AFilename: String; const ALine: Integer); +procedure TMainIDE.OnDebuggerCurrentLine(Sender: TObject; const ALocation: TDBGLocationRec); // debugger paused program due to pause or error // -> show the current execution line in editor -var ActiveSrcEdit: TSourceEditor; +// if SrcLine = -1 then no source is available +var + ActiveSrcEdit: TSourceEditor; begin if (Sender<>TheDebugger) or (Sender=nil) then exit; - if DoOpenEditorFile(AFilename,false)<>mrOk then exit; + //TODO: Show assembler window if no source can be found. + if ALocation.SrcLine = -1 then Exit; + if DoOpenEditorFile(ALocation.SrcFile, false) <> mrOk then exit; ActiveSrcEdit:=SourceNoteBook.GetActiveSE; if ActiveSrcEdit=nil then exit; - ActiveSrcEdit.EditorComponent.CaretXY:=Point(1,ALine); + ActiveSrcEdit.EditorComponent.CaretXY:=Point(1, ALocation.SrcLine); ActiveSrcEdit.EditorComponent.TopLine:= - ALine-(ActiveSrcEdit.EditorComponent.LinesInWindow div 2); - ActiveSrcEdit.ErrorLine:=ALine; + ALocation.SrcLine - (ActiveSrcEdit.EditorComponent.LinesInWindow div 2); + ActiveSrcEdit.ErrorLine:=ALocation.SrcLine; end; function TMainIDE.SomethingOfProjectIsModified: boolean; @@ -4380,6 +4382,9 @@ end. { ============================================================================= $Log$ + Revision 1.134 2001/11/05 00:12:50 lazarus + MWE: First steps of a debugger. + Revision 1.133 2001/11/03 08:37:34 lazarus MG: fixed errorline showing, resource adding and published var editing and added make cleanall @@ -9007,6 +9012,9 @@ end. { ============================================================================= $Log$ + Revision 1.134 2001/11/05 00:12:50 lazarus + MWE: First steps of a debugger. + Revision 1.133 2001/11/03 08:37:34 lazarus MG: fixed errorline showing, resource adding and published var editing and added make cleanall