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

FpDebug: Windows, fixed intercepting system exceptions (access violations, stack overflow, div zero,...)

Browse Source 
git-svn-id: branches/fixes_2_0@60171 -
This commit is contained in:
mattias 2019-01-24 09:33:38 +00:00
parent ce95a8b81d
commit 7c6b8f01a5
1 changed files with 10 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
components/fpdebug/fpdbgwinclasses.pas
View File

@ -540,7 +540,7 @@ end;
function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
procedure HandleException(const AEvent: TDebugEvent);
procedure HandleException(const AEvent: TDebugEvent; out InterceptAtFirstChance: Boolean);
const
PARAMCOLS = 12 - SizeOf(Pointer);
var
@ -550,6 +550,7 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
ExInfo32: TExceptionDebugInfo32 absolute AEvent.Exception;
ExInfo64: TExceptionDebugInfo64 absolute AEvent.Exception;
begin
InterceptAtFirstChance := True;
// Kept the debug-output as comments, since they provide deeper information
// on how to interprete the exception-information.
{
@ -561,7 +562,7 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
case AEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_ACCESS_VIOLATION : ExceptionClass:='ACCESS VIOLATION';
EXCEPTION_ARRAY_BOUNDS_EXCEEDED : ExceptionClass:='ARRAY BOUNDS EXCEEDED';
EXCEPTION_BREAKPOINT : ExceptionClass:='BREAKPOINT';
EXCEPTION_BREAKPOINT : ExceptionClass:='BREAKPOINT'; // should never be here
EXCEPTION_DATATYPE_MISALIGNMENT : ExceptionClass:='DATATYPE MISALIGNMENT';
EXCEPTION_FLT_DENORMAL_OPERAND : ExceptionClass:='FLT DENORMAL OPERAND';
EXCEPTION_FLT_DIVIDE_BY_ZERO : ExceptionClass:='FLT DIVIDE BY ZERO';
@ -579,7 +580,7 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
EXCEPTION_NONCONTINUABLE_EXCEPTION : ExceptionClass:='NONCONTINUABLE EXCEPTION';
EXCEPTION_POSSIBLE_DEADLOCK : ExceptionClass:='POSSIBLE DEADLOCK';
EXCEPTION_PRIV_INSTRUCTION : ExceptionClass:='PRIV INSTRUCTION';
EXCEPTION_SINGLE_STEP : ExceptionClass:='SINGLE STEP';
EXCEPTION_SINGLE_STEP : ExceptionClass:='SINGLE STEP'; // should never be here
EXCEPTION_STACK_OVERFLOW : ExceptionClass:='STACK OVERFLOW';
// add some status - don't know if we can get them here
@ -595,6 +596,7 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
STATUS_SXS_INVALID_DEACTIVATION : DebugLn('STATUS_SXS_INVALID_DEACTIVATION');
}
else
InterceptAtFirstChance := False;
ExceptionClass := 'Unknown exception code $' + IntToHex(ExInfo32.ExceptionRecord.ExceptionCode, 8);
{
DebugLn(' [');
@ -785,6 +787,8 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
log('[%d:%d]: %s', [AEvent.dwProcessId, AEvent.dwThreadId, S]);
end;
var
InterceptAtFirst: Boolean;
begin
if HandleDebugEvent(MDebugEvent)
then result := deBreakpoint
@ -816,9 +820,9 @@ begin
result := deBreakpoint;
end
else begin
HandleException(MDebugEvent);
if MDebugEvent.Exception.dwFirstChance = 1 then
result := deInternalContinue
HandleException(MDebugEvent, InterceptAtFirst);
if (MDebugEvent.Exception.dwFirstChance = 1) and (not InterceptAtFirst) then
result := deInternalContinue // might be an SEH exception
else
result := deException;
end;