paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-19 22:29:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

Debugger: GDB improve internal breakpoints at start. Issue #0026209 #0026470

Browse Source 
git-svn-id: trunk@47567 -
This commit is contained in:
martin 2015-01-30 23:16:32 +00:00
parent 7e93d299dc
commit f611836e4c
6 changed files with 435 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2092,6 +2092,7 @@ components/lazdebuggergdbmi/test/RunGdbmi.lpr svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/ArgVPrg.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/EnvPrg.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/ExceptPrg.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/ExceptPrgStep.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/WatchesPrg.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/WatchesPrgArray.inc svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/WatchesPrgEnum.inc svneol=native#text/pascal
@ -2100,6 +2101,7 @@ components/lazdebuggergdbmi/test/TestApps/WatchesPrgSimple.inc svneol=native#tex
components/lazdebuggergdbmi/test/TestApps/WatchesPrgString.inc svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/WatchesPrgStruct.inc svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/WatchesPrgVariant.inc svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/breakprog.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestApps/u1/unitw1.pas svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestGdbmi.lpi svneol=native#text/pascal
components/lazdebuggergdbmi/test/TestGdbmi.lpr svneol=native#text/pascal

462
components/lazdebuggergdbmi/gdbmidebugger.pp
View File

@ -567,34 +567,34 @@ type
{ TGDBMIInternalBreakPoint }
TGDBMIInternalBreakPoint = class
private type
TClearOpt = (coClearIfSet, coKeepIfSet);
TInternalBreakLocation = (iblNamed, iblAddrOfNamed, iblCustomAddr, iblAddOffset);
TInternalBreakData = record
BreakGdbId: Integer;
BreakAddr: TDBGPtr;
BreakFunction: String;
//BreakFile: String;
//BreakLine: Integer;
end;
private
FBreaks: array[TInternalBreakLocation] of TInternalBreakData;
(* F...ID: -1 not set, -2 blocked
*)
FEnabled: Boolean;
FLineOffsFunction: string;
// -break-insert name
FNameBreakID: Integer;
FNameBreakAddr: TDBGPtr;
// -break-insert *addr
FAddrBreakID: Integer;
FAddrBreakAddr: TDBGPtr;
// -break-insert *custom
FCustomID: Integer;
FCustomAddr: TDBGPtr;
// -break-insert +x
FLineOffsID: Integer;
FLineOffsAddr: TDBGPtr;
FMainAddrFound: TDBGPtr;
FName: string;
FName: string; // The (function) name of the location "main" or "FPC_RAISE"
FMainAddrFound: TDBGPtr; // The address found for this named location
FUseForceFlag: Boolean;
procedure ClearName(ACmd: TGDBMIDebuggerCommand);
procedure ClearAddr(ACmd: TGDBMIDebuggerCommand); // Main-Addr
procedure ClearCustom(ACmd: TGDBMIDebuggerCommand);
procedure ClearLineOffs(ACmd: TGDBMIDebuggerCommand);
function BreakSet(ACmd: TGDBMIDebuggerCommand; ALoc: String; out AId: integer;
out AnAddr: TDBGPtr): Boolean;
function BreakSet(ACmd: TGDBMIDebuggerCommand; ALoc: String; out AId: integer;
out AnAddr: TDBGPtr; out AFuncName: string): Boolean;
procedure Clear(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
ABlock: Boolean = False);
function BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
ALoc: TInternalBreakLocation;
AClearIfSet: TClearOpt): Boolean;
function GetInfoAddr(ACmd: TGDBMIDebuggerCommand): TDBGPtr;
procedure InternalSetAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
function HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
function HasBreakWithId(AnId: Integer): Boolean;
procedure InternalSetAddr(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
AnAddr: TDBGPtr);
public
constructor Create(AName: string);
procedure SetBoth(ACmd: TGDBMIDebuggerCommand);
@ -604,14 +604,17 @@ type
procedure SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
procedure Clear(ACmd: TGDBMIDebuggerCommand);
function ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
// a blocked id can not be set, until after the next clear (clear all)
function ClearAndBlockId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
function MatchAddr(AnAddr: TDBGPtr): boolean;
function MatchId(AnId: Integer): boolean;
function IsBreakSet: boolean;
function BreakSetCount: Integer;
procedure EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
procedure Enable(ACmd: TGDBMIDebuggerCommand);
procedure Disable(ACmd: TGDBMIDebuggerCommand);
property MainAddrFound: TDBGPtr read FMainAddrFound;
property LineOffsFunction: string read FLineOffsFunction;
// property LineOffsFunction: string read FBreaks[iblAddOffset].BreakFunction;
property UseForceFlag: Boolean read FUseForceFlag write FUseForceFlag;
property Enabled: Boolean read FEnabled;
end;
@ -4815,64 +4818,78 @@ function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
);
var
RunToMainState: TRunToMainState;
EntryPointNum: TDBGPtr;
procedure SetMainBrk;
function TrySetMainBrk(AType: TRunToMainType; ANextState: TRunToMainState): Boolean;
function SetMainBrk: boolean;
procedure MaybeAddMainBrk(AType: TRunToMainType; AnSkipIfCntGreater: Integer;
ACheckEntryPoinReloc: Boolean = false);
begin
RunToMainState := ANextState;
//RunToMainState := ANextState;
// Check if the Entrypoint looks promising (if it looks like it matches the relocated address)
if ACheckEntryPoinReloc and not(EntryPointNum > $4000) then
exit;
// Check amount of already set breakpoints
if (AnSkipIfCntGreater >= 0) and (FTheDebugger.FMainAddrBreak.BreakSetCount > AnSkipIfCntGreater) then
exit;
case AType of
mtMain: FTheDebugger.FMainAddrBreak.SetByName(Self);
mtMainAddr: FTheDebugger.FMainAddrBreak.SetByAddr(Self);
mtEntry: FTheDebugger.FMainAddrBreak.SetAtCustomAddr(Self, StrToQWordDef(EntryPoint, 0));
mtAddZero: FTheDebugger.FMainAddrBreak.SetAtLineOffs(Self, 0);
end;
Result := FTheDebugger.FMainAddrBreak.IsBreakSet;
end;
var
bcnt: Integer;
begin
case RunToMainState of
msMainAddr: begin
if TrySetMainBrk(mtMainAddr, msTryZero) then exit;
if TrySetMainBrk(mtEntry, msTryZero) then exit;
if TrySetMainBrk(mtAddZero, msNone) then exit;
Result := False;
bcnt := FTheDebugger.FMainAddrBreak.BreakSetCount;
case DebuggerProperties.InternalStartBreak of
gdsbEntry: begin
MaybeAddMainBrk(mtEntry, -1, true);
if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
MaybeAddMainBrk(mtEntry, -1, false);
MaybeAddMainBrk(mtAddZero, -1);
// set only, if no other is set (e.g. 2nd attempt)
MaybeAddMainBrk(mtMainAddr, 0);
MaybeAddMainBrk(mtMain, 0);
end;
end;
msMain: begin
if TrySetMainBrk(mtMain, msTryZero) then exit;
if TrySetMainBrk(mtAddZero, msNone) then exit;
gdsbMainAddr: begin
MaybeAddMainBrk(mtMainAddr, -1);
// set only, if no other is set (e.g. 2nd attempt)
if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
MaybeAddMainBrk(mtEntry, 0, true);
MaybeAddMainBrk(mtAddZero, 1);
MaybeAddMainBrk(mtEntry, 0, false);
MaybeAddMainBrk(mtMain, 0);
end;
end;
msAddZero: begin
if TrySetMainBrk(mtAddZero, msTryEntryName) then exit;
if TrySetMainBrk(mtEntry, msTryName) then exit;
gdsbMain: begin
MaybeAddMainBrk(mtMain, -1);
// set only, if no other is set (e.g. 2nd attempt)
MaybeAddMainBrk(mtAddZero, 0);
MaybeAddMainBrk(mtMainAddr, 0);
MaybeAddMainBrk(mtEntry, 0, false);
end;
msEntryPoint: begin
if TrySetMainBrk(mtEntry, msTryZero) then exit;
if TrySetMainBrk(mtAddZero, msNone) then exit;
gdsbAddZero: begin
MaybeAddMainBrk(mtAddZero, -1);
// set only, if no other is set (e.g. 2nd attempt)
MaybeAddMainBrk(mtEntry, 0, true);
MaybeAddMainBrk(mtMain, 0);
MaybeAddMainBrk(mtEntry, 0, false);
MaybeAddMainBrk(mtMainAddr, 0);
end;
msDefault: begin
(* Force mtMain before + 0: gdb 7.4 will pretend to have +0, but fail it later. *)
TrySetMainBrk(mtMain, msNone); // include name
TrySetMainBrk(mtAddZero, msNone); // always include +0
if TrySetMainBrk(mtEntry, msTryNameZero) then exit;
if TrySetMainBrk(mtMainAddr, msTryZero) then exit;
else begin // gdsbDefault
// SetByName: "main", this is the best aproach, unless any library also exports main.
MaybeAddMainBrk(mtMain, -1);
MaybeAddMainBrk(mtEntry, -1, true); // Previous versions used "+0" as 2nd in the list
MaybeAddMainBrk(mtAddZero, -1);
MaybeAddMainBrk(mtMainAddr, 2); // set only, if less than 2 are set
// set only, if no other is set (e.g. 2nd attempt)
MaybeAddMainBrk(mtEntry, 0, false);
end;
msTryNameZero: begin
if (FTheDebugger.FMainAddrBreak.LineOffsFunction <> 'main')
then
TrySetMainBrk(mtAddZero, msNone); // include +0, if not at main
if TrySetMainBrk(mtMain, msTryZero) then exit;
end;
msTryZero: begin
if TrySetMainBrk(mtAddZero, msNone) then exit;
end;
msTryEntryName: begin
if TrySetMainBrk(mtEntry, msTryName) then exit;
if TrySetMainBrk(mtMain, msNone) then exit;
end;
msTryName: begin
if TrySetMainBrk(mtMain, msNone) then exit;
end;
msNone:
FTheDebugger.FMainAddrBreak.Clear(Self);
end;
Result := bcnt < FTheDebugger.FMainAddrBreak.BreakSetCount; // added new breaks
end;
function ParseLogForPid(ALogTxt: String): Integer;
@ -4894,10 +4911,11 @@ function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
var
R: TGDBMIExecResult;
Cmd, s, s2, rval: String;
i: integer;
i, j, LoopCnt: integer;
List: TGDBMINameValueList;
BrkErr: Boolean;
begin
EntryPointNum := StrToQWordDef(EntryPoint, 0);
TargetInfo^.TargetPID := 0;
FDidKillNow := False;
RunToMainState := msEntryPoint;
@ -4915,13 +4933,16 @@ function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
rval := '';
R.State := dsError;
FTheDebugger.FMainAddrBreak.Clear(Self);
while true do begin
LoopCnt := 6; // max iterations
while (LoopCnt > 0) and not(DebuggerState = dsError) do begin
dec(LoopCnt);
SetMainBrk;
if not FTheDebugger.FMainAddrBreak.IsBreakSet
then begin
(* TODO:
If no main break can be set, it may still be possible (desirable) to run
the app, without debug-capacbilities
Or maybe even try to set all breakpoints.
*)
SetDebuggerErrorState(Format(gdbmiCommandStartMainBreakError, [LineEnding]),
ErrorStateInfo);
@ -4969,15 +4990,20 @@ function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
if not BrkErr
then break;
while BrkErr do begin
if FTheDebugger.FMainAddrBreak.ClearId(Self, i) then
BrkErr := ParseBreakInsertError(s, i)
else begin
FTheDebugger.FMainAddrBreak.Clear(Self);
BrkErr := False;
j := FTheDebugger.FMainAddrBreak.BreakSetCount;
while BrkErr and not(DebuggerState = dsError) do begin
if not FTheDebugger.FMainAddrBreak.ClearAndBlockId(Self, i)
then begin
DebugLn(DBG_WARNINGS, ['TGDBMIDebugger.RunToMain: An unknown breakpoint id was reported as failing: ', i]);
if not ExecuteCommand('-break-delete %d', [i], [cfCheckError]) // wil set error state if it fails
then break;
inc(j);
end;
BrkErr := ParseBreakInsertError(s, i)
end;
// Break, if no breakpoint was removed
if j = FTheDebugger.FMainAddrBreak.BreakSetCount
then break;
end;
if DebuggerState = dsError then
@ -11400,79 +11426,56 @@ end;
{ TGDBMIInternalBreakPoint }
procedure TGDBMIInternalBreakPoint.ClearName(ACmd: TGDBMIDebuggerCommand);
procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand;
ALoc: TInternalBreakLocation; ABlock: Boolean);
begin
if FNameBreakID = -1 then exit;
ACmd.ExecuteCommand('-break-delete %d', [FNameBreakID], [cfCheckError]);
FNameBreakID := -1;
FNameBreakAddr := 0;
FEnabled := FEnabled and ((FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID >= 0) or (FLineOffsID >= 0));
if FBreaks[ALoc].BreakGdbId < 0 then exit;
ACmd.ExecuteCommand('-break-delete %d', [FBreaks[ALoc].BreakGdbId], [cfCheckError]);
if ABlock then
FBreaks[ALoc].BreakGdbId := -2
else
FBreaks[ALoc].BreakGdbId := -1;
FBreaks[ALoc].BreakAddr := 0;
FEnabled := FEnabled and IsBreakSet;
if ALoc = iblAddrOfNamed then FMainAddrFound := 0;
if ALoc = iblAddOffset then FBreaks[iblAddOffset].BreakFunction := '';
end;
procedure TGDBMIInternalBreakPoint.ClearAddr(ACmd: TGDBMIDebuggerCommand);
begin
if FAddrBreakID = -1 then exit;
ACmd.ExecuteCommand('-break-delete %d', [FAddrBreakID], [cfCheckError]);
FAddrBreakID := -1;
FAddrBreakAddr := 0;
FMainAddrFound := 0;
FEnabled := FEnabled and ((FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID >= 0) or (FLineOffsID >= 0));
end;
procedure TGDBMIInternalBreakPoint.ClearCustom(ACmd: TGDBMIDebuggerCommand);
begin
if FCustomID = -1 then exit;
ACmd.ExecuteCommand('-break-delete %d', [FCustomID], [cfCheckError]);
FCustomID := -1;
FCustomAddr := 0;
FEnabled := FEnabled and ((FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID >= 0) or (FLineOffsID >= 0));
end;
procedure TGDBMIInternalBreakPoint.ClearLineOffs(ACmd: TGDBMIDebuggerCommand);
begin
if FLineOffsID = -1 then exit;
ACmd.ExecuteCommand('-break-delete %d', [FLineOffsID], [cfCheckError]);
FLineOffsID := -1;
FLineOffsAddr := 0;
FLineOffsFunction := '';
FEnabled := FEnabled and ((FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID >= 0) or (FLineOffsID >= 0));
end;
function TGDBMIInternalBreakPoint.BreakSet(ACmd: TGDBMIDebuggerCommand; ALoc: String; out
AId: integer; out AnAddr: TDBGPtr): Boolean;
var
FuncName: string;
begin
Result := BreakSet(ACmd, ALoc, AId, AnAddr, FuncName);
end;
function TGDBMIInternalBreakPoint.BreakSet(ACmd: TGDBMIDebuggerCommand; ALoc: String; out
AId: integer; out AnAddr: TDBGPtr; out AFuncName: string): Boolean;
function TGDBMIInternalBreakPoint.BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
ALoc: TInternalBreakLocation; AClearIfSet: TClearOpt): Boolean;
var
R: TGDBMIExecResult;
ResultList: TGDBMINameValueList;
begin
AId := -1;
AnAddr := 0;
AFuncName := '';
Result := True; // true, if already set (dsError does not matter)
if ACmd.DebuggerState = dsError then exit;
if AClearIfSet = coClearIfSet then
Clear(ACmd, ALoc); // keeps blocked indicator
if FBreaks[ALoc].BreakGdbId <> -1 then exit; // not(set or blocked)
FBreaks[ALoc].BreakGdbId := -1;
FBreaks[ALoc].BreakAddr := 0;
FBreaks[ALoc].BreakFunction := '';
if UseForceFlag and (dfForceBreakDetected in ACmd.FTheDebugger.FDebuggerFlags) then
begin
if (not ACmd.ExecuteCommand('-break-insert -f %s', [ALoc], R)) or
if (not ACmd.ExecuteCommand('-break-insert -f %s', [ABreakLoc], R)) or
(R.State = dsError)
then
ACmd.ExecuteCommand('-break-insert %s', [ALoc], R);
ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
end
else
ACmd.ExecuteCommand('-break-insert %s', [ALoc], R);
ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
Result := R.State <> dsError;
if not Result then exit;
FEnabled := True;
FEnabled := True; // TODO: What if some bp are disabled?
ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
AId := StrToIntDef(ResultList.Values['number'], -1);
AnAddr := StrToQWordDef(ResultList.Values['addr'], 0);
AFuncName := ResultList.Values['func'];
FBreaks[ALoc].BreakGdbId := StrToIntDef(ResultList.Values['number'], -1);
FBreaks[ALoc].BreakAddr := StrToQWordDef(ResultList.Values['addr'], 0);
FBreaks[ALoc].BreakFunction := ResultList.Values['func'];
ResultList.Free;
end;
@ -11484,6 +11487,7 @@ begin
Result := FMainAddrFound;
if Result <> 0 then
exit;
if ACmd.DebuggerState = dsError then Exit;
if (not ACmd.ExecuteCommand('info address ' + FName, R)) or
(R.State = dsError)
then exit;
@ -11493,36 +11497,47 @@ begin
FMainAddrFound := Result;
end;
procedure TGDBMIInternalBreakPoint.InternalSetAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
function TGDBMIInternalBreakPoint.HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
var
i: TInternalBreakLocation;
begin
if (AnAddr <> FAddrBreakAddr) then
ClearAddr(ACmd);
Result := True;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if (FBreaks[i].BreakGdbId >= 0) and (FBreaks[i].BreakAddr = AnAddr) then
exit;
Result := False;
end;
if (AnAddr = 0) or (AnAddr = FAddrBreakAddr) or
(AnAddr = FCustomAddr) or (AnAddr = FLineOffsAddr)
then exit;
function TGDBMIInternalBreakPoint.HasBreakWithId(AnId: Integer): Boolean;
var
i: TInternalBreakLocation;
begin
Result := True;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if (FBreaks[i].BreakGdbId = AnId) then
exit;
Result := False;
end;
if (FCustomID >= 0) and (AnAddr = FCustomAddr) then begin
FAddrBreakID := FCustomID;
FAddrBreakAddr := FCustomAddr;
FCustomID := -1;
FCustomAddr := 0;
end
else
BreakSet(ACmd, Format('*%u', [AnAddr]), FAddrBreakID, FAddrBreakAddr);
procedure TGDBMIInternalBreakPoint.InternalSetAddr(ACmd: TGDBMIDebuggerCommand;
ALoc: TInternalBreakLocation; AnAddr: TDBGPtr);
begin
if (AnAddr = 0) or HasBreakAtAddr(AnAddr) then // HasBreakAddr includes this BP being allready at AnAddr.
exit;
// Always ClearIfSet since the address changed
BreakSet(ACmd, Format('*%u', [AnAddr]), ALoc, coClearIfSet);
end;
constructor TGDBMIInternalBreakPoint.Create(AName: string);
var
i: TInternalBreakLocation;
begin
FMainAddrFound := 0;
FNameBreakID := -1;
FNameBreakAddr := 0;
FAddrBreakID := -1;
FAddrBreakAddr := 0;
FCustomID := -1;
FCustomAddr := 0;
FLineOffsID := -1;
FLineOffsAddr := 0;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do begin
FBreaks[i].BreakGdbId := -1;
FBreaks[i].BreakAddr := 0;
end;
FUseForceFlag := False;
FName := AName;
FEnabled := False;
@ -11538,110 +11553,106 @@ end;
Therefore during startup a named break point is used as fallback.
*)
procedure TGDBMIInternalBreakPoint.SetBoth(ACmd: TGDBMIDebuggerCommand);
var
A: TDBGPtr;
begin
if ACmd.DebuggerState = dsError then Exit;
// keep if already set
if FNameBreakID < 0 then
if not BreakSet(ACmd, FName, FNameBreakID, FNameBreakAddr) then exit;
if not BreakSet(ACmd, FName, iblNamed, coKeepIfSet) then exit;
if FBreaks[iblAddrOfNamed].BreakGdbId = -2 then exit;
// Try to retrieve the address of the procedure
A := GetInfoAddr(ACmd);
if A = 0 then exit;
if (A <> FNameBreakAddr) then
InternalSetAddr(ACmd, A);
InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
end;
procedure TGDBMIInternalBreakPoint.SetByName(ACmd: TGDBMIDebuggerCommand);
begin
if FNameBreakID < 0 then
if not BreakSet(ACmd, FName, FNameBreakID, FNameBreakAddr) then exit;
BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
// keep others
end;
procedure TGDBMIInternalBreakPoint.SetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
var
A: TDBGPtr;
begin
if ACmd.DebuggerState = dsError then Exit;
if FAddrBreakID >= 0 then exit; // already set
if FBreaks[iblAddrOfNamed].BreakGdbId <> -2 then
InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
A := GetInfoAddr(ACmd);
InternalSetAddr(ACmd, A);
if (A <> 0) and (A = FAddrBreakAddr) then
ClearName(ACmd);
If SetNamedOnFail and (A = 0) and (FNameBreakID < 0) then
BreakSet(ACmd, FName, FNameBreakID, FNameBreakAddr);
// SetNamedOnFail includes if blocked
If SetNamedOnFail and (FBreaks[iblNamed].BreakGdbId < 0) then
BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
end;
procedure TGDBMIInternalBreakPoint.SetAtCustomAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
begin
if ACmd.DebuggerState = dsError then Exit;
ClearCustom(ACmd);
if (AnAddr <> 0) and
((FAddrBreakID < 0) or (AnAddr <> FAddrBreakAddr)) and
((FLineOffsID < 0) or (AnAddr <> FLineOffsAddr)) and
((FNameBreakID < 0) or (AnAddr <> FNameBreakAddr))
then
BreakSet(ACmd, Format('*%u', [AnAddr]), FCustomID, FCustomAddr);
InternalSetAddr(ACmd, iblCustomAddr, AnAddr);
end;
procedure TGDBMIInternalBreakPoint.SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
begin
if ACmd.DebuggerState = dsError then Exit;
ClearLineOffs(ACmd);
// always clear, and set again
if AnOffset < 0 then
BreakSet(ACmd, Format('%d', [AnOffset]), FLineOffsID, FLineOffsAddr, FLineOffsFunction)
BreakSet(ACmd, Format('%d', [AnOffset]), iblAddOffset, coClearIfSet)
else
BreakSet(ACmd, Format('+%d', [AnOffset]), FLineOffsID, FLineOffsAddr, FLineOffsFunction);
BreakSet(ACmd, Format('+%d', [AnOffset]), iblAddOffset, coClearIfSet);
end;
procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand);
var
i: TInternalBreakLocation;
begin
if ACmd.DebuggerState = dsError then Exit;
ClearName(ACmd);
ClearAddr(ACmd);
ClearCustom(ACmd);
ClearLineOffs(ACmd);
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do begin
Clear(ACmd, i);
FBreaks[i].BreakGdbId := -1; // unblock
end;
FEnabled := False;
end;
function TGDBMIInternalBreakPoint.ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
var
i: TInternalBreakLocation;
begin
Result := (AnId > 0) and
( (AnId = FNameBreakID) or (AnId = FAddrBreakID) or
(AnId = FCustomID) or (AnId = FLineOffsID) );
if not Result then exit;
Result := False;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if (AnId = FBreaks[i].BreakGdbId) then begin
Clear(ACmd, i);
Result := True;
break;
end;
end;
if (AnId = FNameBreakID) then ClearName(ACmd);
if (AnId = FAddrBreakID) then ClearAddr(ACmd);
if (AnId = FCustomID) then ClearCustom(ACmd);
if (AnId = FLineOffsID) then ClearLineOffs(ACmd);
function TGDBMIInternalBreakPoint.ClearAndBlockId(ACmd: TGDBMIDebuggerCommand;
AnId: Integer): Boolean;
var
i: TInternalBreakLocation;
begin
Result := False;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if (AnId = FBreaks[i].BreakGdbId) then begin
Clear(ACmd, i, True);
Result := True;
break;
end;
end;
function TGDBMIInternalBreakPoint.MatchAddr(AnAddr: TDBGPtr): boolean;
begin
Result := (AnAddr <> 0) and
( (AnAddr = FNameBreakAddr) or (AnAddr = FAddrBreakAddr) or
(AnAddr = FCustomAddr) or (AnAddr = FLineOffsAddr));
Result := (AnAddr <> 0) and HasBreakAtAddr(AnAddr);
end;
function TGDBMIInternalBreakPoint.MatchId(AnId: Integer): boolean;
begin
Result := (AnId >= 0) and
( (AnId = FNameBreakID) or (AnId = FAddrBreakID) or
(AnId = FCustomID) or (AnId = FLineOffsID));
Result := (AnId >= 0) and HasBreakWithId(AnId);
end;
function TGDBMIInternalBreakPoint.IsBreakSet: boolean;
begin
Result := (FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID > 0) or (FLineOffsID > 0);
Result := BreakSetCount > 0;
end;
function TGDBMIInternalBreakPoint.BreakSetCount: Integer;
var
i: TInternalBreakLocation;
begin
Result := 0;
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if (FBreaks[i].BreakGdbId >= 0) then
inc(Result);
end;
procedure TGDBMIInternalBreakPoint.EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand;
@ -11656,35 +11667,26 @@ end;
procedure TGDBMIInternalBreakPoint.Enable(ACmd: TGDBMIDebuggerCommand);
var
R: TGDBMIExecResult;
i: TInternalBreakLocation;
begin
if FEnabled then exit;
FEnabled := (FNameBreakID >= 0) or (FAddrBreakID >= 0) or (FCustomID >= 0) or (FLineOffsID >= 0);
if FNameBreakID >= 0 then
ACmd.ExecuteCommand('-break-enable %d', [FNameBreakID], R);
if FAddrBreakID >= 0 then
ACmd.ExecuteCommand('-break-enable %d', [FAddrBreakID], R);
if FCustomID >= 0 then
ACmd.ExecuteCommand('-break-enable %d', [FCustomID], R);
if FLineOffsID >= 0 then
ACmd.ExecuteCommand('-break-enable %d', [FLineOffsID], R);
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if FBreaks[i].BreakGdbId >= 0 then begin
ACmd.ExecuteCommand('-break-enable %d', [FBreaks[i].BreakGdbId], R);
FEnabled := True;
end;
end;
procedure TGDBMIInternalBreakPoint.Disable(ACmd: TGDBMIDebuggerCommand);
var
R: TGDBMIExecResult;
i: TInternalBreakLocation;
begin
if not FEnabled then exit;
FEnabled := False;
if FNameBreakID >= 0 then
ACmd.ExecuteCommand('-break-disable %d', [FNameBreakID], R);
if FAddrBreakID >= 0 then
ACmd.ExecuteCommand('-break-disable %d', [FAddrBreakID], R);
if FCustomID >= 0 then
ACmd.ExecuteCommand('-break-disable %d', [FCustomID], R);
if FLineOffsID >= 0 then
ACmd.ExecuteCommand('-break-disable %d', [FLineOffsID], R);
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
if FBreaks[i].BreakGdbId >= 0 then
ACmd.ExecuteCommand('-break-disable %d', [FBreaks[i].BreakGdbId], R);
end;
{ TGDBMIDebuggerSimpleCommand }

41
components/lazdebuggergdbmi/test/TestApps/ExceptPrgStep.pas Normal file
View File

@ -0,0 +1,41 @@
program ExceptPrgStep;
uses sysutils;
var
i: integer;
procedure foo;
begin
raise Exception.create('a');
writeln(1);
end;
begin
try
foo;
writeln(1);
foo;
foo;
except
writeln(1);
end;
writeln(2);
try
try
foo;
writeln(1);
foo;
foo;
except
writeln(1);
end;
writeln(2);
except
writeln(1);
end;
writeln(2);
writeln(2);
writeln(2);
end.

33
components/lazdebuggergdbmi/test/TestApps/breakprog.pas Normal file
View File

@ -0,0 +1,33 @@
program breakprog;
procedure WriteLnIpc(aStr: String);
begin
writeln(aStr);
writeln(aStr+aStr);
end;
function CalcNextUpdTime(aTime: Integer): Integer;
begin
writeln(aTime);
writeln(aTime+aTime);
Result := 5*aTime;
end;
function StripFileDrive(const FileName: string): string;
begin
writeln(FileName);
writeln(FileName+FileName);
Result := FileName;
Delete(Result, 1, 1);
end;
begin
//nodrv := StripFileDrive(s);
WriteLnIpc('drive="%s", dir="%s", path="%s", nodrv=%s.');
CalcNextUpdTime(1);
WriteLnIpc('Now = ');
WriteLnIpc('UpdateTime = ');
WriteLnIpc('RealUpdateTime = ');
end.

55
components/lazdebuggergdbmi/test/testbreakpoint.pas
View File

@ -34,10 +34,14 @@ type
published
// Due to a linker error breakpoints can point to invalid addresses
procedure TestStartMethod;
procedure TestStartMethodBadLinker; // not called prog in front of MAIN // causes bad linker with dwarf
procedure TestBadAddrBreakpoint;
procedure TestInteruptWhilePaused;
end;
const
BREAK_LINE_BREAKPROG = 28;
implementation
procedure TTestBrkGDBMIDebugger.TestInterruptTarget;
@ -104,6 +108,57 @@ begin
AssertTestErrors;
end;
procedure TTestBreakPoint.TestStartMethodBadLinker;
var
dbg: TGDBMIDebugger;
TestExeName, s: string;
i: TGDBMIDebuggerStartBreak;
IgnoreRes: String;
begin
if SkipTest then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestBreakPoint')] then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf(' TTestBreakPoint.StartMethod')] then exit;
ClearTestErrors;
FBrkErr := nil;
TestCompile(AppDir + 'breakprog.pas', TestExeName);
for i := Low(TGDBMIDebuggerStartBreak) to high(TGDBMIDebuggerStartBreak) do begin
WriteStr(s, i);
try
dbg := StartGDB(AppDir, TestExeName);
dbg.OnCurrent := @DoCurrent;
TGDBMIDebuggerProperties(dbg.GetProperties).InternalStartBreak := i;
with dbg.BreakPoints.Add('breakprog.pas', BREAK_LINE_BREAKPROG) do begin
InitialEnabled := True;
Enabled := True;
end;
dbg.Run;
IgnoreRes := '';
case DebuggerInfo.Version of
000000..070399: if (i = gdsbAddZero) and
(CompilerInfo.Version = 020604)
then IgnoreRes:= 'gdb below 7.4 and fpc 2.6.4 does not work with gdsbAddZero';
070400..070499: if i = gdsbAddZero then IgnoreRes:= 'gdb 7.4.x does not work with gdsbAddZero';
end;
TestTrue(s+' not in error state 1', dbg.State <> dsError, 0, IgnoreRes);
TestTrue(s+' at break', FCurLine = BREAK_LINE_BREAKPROG, 0, IgnoreRes);
TGDBMIDebuggerProperties(dbg.GetProperties).InternalStartBreak := gdsbDefault;
finally
dbg.Done;
CleanGdb;
dbg.Free;
end;
end;
AssertTestErrors;
end;
function TTestBreakPoint.DoGetFeedBack(Sender: TObject; const AText, AInfo: String;
AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
begin

75
components/lazdebuggergdbmi/test/testexception.pas
View File

@ -5,7 +5,7 @@ unit TestException;
interface
uses
Classes, fpcunit, testutils, testregistry, TestGDBMIControl,
Classes, sysutils, fpcunit, testutils, testregistry, TestGDBMIControl,
TestBase, GDBMIDebugger, LCLProc, DbgIntfDebuggerBase;
type
@ -14,6 +14,9 @@ type
TTestExceptionOne = class(TGDBTestCase)
private
FCurLine: Integer;
FCurFile: string;
FGotExceptCount: Integer;
FGotExceptClass: String;
FGotExceptMsg: String;
@ -25,12 +28,21 @@ type
const AExceptionLocation: TDBGLocationRec;
const AExceptionText: String;
out AContinue: Boolean);
protected
procedure DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
published
procedure TestException;
end;
procedure TestExceptionStepOut;
end;
const
(* Stepping out of the exception may currently stop one line before the "except statemet.
The lines below are the first line in the statement. (so 2 later)
*)
BREAK_LINE_EXCEPT_1 = 20; // first except blog // may be 18 = at "except" keyword
BREAK_LINE_EXCEPT_2 = 31; // 2nd except
BREAK_LINE_EXCEPT_END = 38; // line for break at end
implementation
@ -52,6 +64,12 @@ begin
AContinue := False;
end;
procedure TTestExceptionOne.DoCurrent(Sender: TObject; const ALocation: TDBGLocationRec);
begin
FCurFile := ALocation.SrcFile;
FCurLine := ALocation.SrcLine;
end;
procedure TTestExceptionOne.TestException;
var
TestExeName, TstName: string;
@ -218,6 +236,57 @@ begin
AssertTestErrors;
end;
procedure TTestExceptionOne.TestExceptionStepOut;
var
TestExeName, TstName: string;
dbg: TGDBMIDebugger;
begin
if SkipTest then exit;
if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
ClearTestErrors;
TestCompile(AppDir + 'ExceptPrgStep.pas', TestExeName, '', '');
try
FGotExceptCount := 0; TstName := 'STEP';
dbg := StartGDB(AppDir, TestExeName);
dbg.OnException := @DoDebuggerException;
dbg.OnCurrent := @DoCurrent;
with dbg.BreakPoints.Add('ExceptPrgStep.pas', BREAK_LINE_EXCEPT_END) do begin
InitialEnabled := True;
Enabled := True;
end;
dbg.Run;
TestEquals(TstName+' Got 1 exception', 1, FGotExceptCount);
dbg.StepOver;
TestTrue(TstName+' (Stepped) at break '+IntToStr(FCurLine),
(FCurLine <= BREAK_LINE_EXCEPT_1) and (FCurLine >= BREAK_LINE_EXCEPT_1 - 2));
TestEquals(TstName+' (Stepped) Still Got 1 exception', 1, FGotExceptCount);
dbg.Run;
TestEquals(TstName+' Got 2 exception', 2, FGotExceptCount);
dbg.StepOver;
TestTrue(TstName+' (Stepped 2) at break '+IntToStr(FCurLine),
(FCurLine <= BREAK_LINE_EXCEPT_2) and (FCurLine >= BREAK_LINE_EXCEPT_2 - 2));
TestEquals(TstName+' (Stepped 2) Still Got 2 exception', 2, FGotExceptCount);
dbg.Run; // run to break (tmp break cleared)
TestEquals(TstName+' at break', BREAK_LINE_EXCEPT_END, FCurLine);
TestEquals(TstName+' Still Got 2 exception', 2, FGotExceptCount);
dbg.Stop;
finally
dbg.Done;
CleanGdb;
dbg.Free;
end;
AssertTestErrors;
end;
initialization
RegisterDbgTest(TTestExceptionOne);
RegisterTestSelectors(['TTestExceptionOne'