mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-14 19:39:31 +02:00
* Moved more reusable exception handling code from seh64.inc to syswin.inc.
* sysutils.pp: Install ExceptObjProc and ExceptClsProc also on Win32. git-svn-id: trunk@26181 -
This commit is contained in:
sergei
parent
f42c1b3720
commit
04c0845189
@ -1393,11 +1393,10 @@ end;
|
||||
Initialization
|
||||
InitWin32Widestrings;
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
{$ifdef win64} { Nothing win64-specific here, just keeping exe size down
|
||||
as these procedures aren't used in generic exception handling }
|
||||
{$ifdef mswindows} { Keeps exe size down for systems that do not use SEH }
|
||||
ExceptObjProc:=@WinExceptionObject;
|
||||
ExceptClsProc:=@WinExceptionClass;
|
||||
{$endif win64}
|
||||
{$endif mswindows}
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
LoadVersionInfo;
|
||||
InitSysConfigDir;
|
||||
|
||||
@ -120,6 +120,16 @@ type
|
||||
|
||||
TUnwindProc=procedure(frame: PtrUInt);
|
||||
|
||||
PFilterRec=^TFilterRec;
|
||||
TFilterRec=record
|
||||
RvaClass: DWord;
|
||||
RvaHandler: DWord;
|
||||
end;
|
||||
|
||||
TExceptObjProc=function(code: Longint; const rec: TExceptionRecord): Pointer; { Exception }
|
||||
TExceptClsProc=function(code: Longint): Pointer; { ExceptClass }
|
||||
|
||||
|
||||
procedure RaiseException(
|
||||
dwExceptionCode: DWORD;
|
||||
dwExceptionFlags: DWORD;
|
||||
@ -128,6 +138,59 @@ procedure RaiseException(
|
||||
stdcall; external 'kernel32.dll' name 'RaiseException';
|
||||
|
||||
|
||||
function RunErrorCode(const rec: TExceptionRecord): longint;
|
||||
begin
|
||||
{ negative result means 'FPU reset required' }
|
||||
case rec.ExceptionCode of
|
||||
STATUS_INTEGER_DIVIDE_BY_ZERO: result := 200; { reDivByZero }
|
||||
STATUS_FLOAT_DIVIDE_BY_ZERO: result := -208; { !!reZeroDivide }
|
||||
STATUS_ARRAY_BOUNDS_EXCEEDED: result := 201; { reRangeError }
|
||||
STATUS_STACK_OVERFLOW: result := 202; { reStackOverflow }
|
||||
STATUS_FLOAT_OVERFLOW: result := -205; { reOverflow }
|
||||
STATUS_FLOAT_DENORMAL_OPERAND,
|
||||
STATUS_FLOAT_UNDERFLOW: result := -206; { reUnderflow }
|
||||
STATUS_FLOAT_INEXACT_RESULT,
|
||||
STATUS_FLOAT_INVALID_OPERATION,
|
||||
STATUS_FLOAT_STACK_CHECK: result := -207; { reInvalidOp }
|
||||
STATUS_INTEGER_OVERFLOW: result := 215; { reIntOverflow }
|
||||
STATUS_ILLEGAL_INSTRUCTION: result := -216;
|
||||
STATUS_ACCESS_VIOLATION: result := 216; { reAccessViolation }
|
||||
STATUS_CONTROL_C_EXIT: result := 217; { reControlBreak }
|
||||
STATUS_PRIVILEGED_INSTRUCTION: result := 218; { rePrivilegedInstruction }
|
||||
else
|
||||
result := 255; { reExternalException }
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function FilterException(var rec:TExceptionRecord; imagebase: PtrUInt; filterRva: DWord): Pointer;
|
||||
var
|
||||
ExClass: TClass;
|
||||
i: Longint;
|
||||
Filter: Pointer;
|
||||
curFilt: PFilterRec;
|
||||
begin
|
||||
result:=nil;
|
||||
if rec.ExceptionCode=FPC_EXCEPTION_CODE then
|
||||
ExClass:=TObject(rec.ExceptionInformation[1]).ClassType
|
||||
else if Assigned(ExceptClsProc) then
|
||||
ExClass:=TClass(TExceptClsProc(ExceptClsProc)(abs(RunErrorCode(rec))))
|
||||
else
|
||||
Exit; { if we cannot determine type of exception, don't handle it }
|
||||
Filter:=Pointer(imagebase+filterRva);
|
||||
for i:=0 to PLongint(Filter)^-1 do
|
||||
begin
|
||||
CurFilt:=@PFilterRec(Filter+sizeof(Longint))[i];
|
||||
if (CurFilt^.RvaClass=$FFFFFFFF) or
|
||||
{ TODO: exception might be coming from another module, need more advanced comparing }
|
||||
(ExClass.InheritsFrom(TClass(imagebase+CurFilt^.RvaClass))) then
|
||||
begin
|
||||
result:=Pointer(imagebase+CurFilt^.RvaHandler);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
Parameter Handling
|
||||
*****************************************************************************}
|
||||
|
||||
@ -212,15 +212,6 @@ type
|
||||
RvaHandler: DWord;
|
||||
end;
|
||||
|
||||
PFilterRec=^TFilterRec;
|
||||
TFilterRec=record
|
||||
RvaClass: DWord;
|
||||
RvaHandler: DWord;
|
||||
end;
|
||||
|
||||
|
||||
TExceptObjProc=function(code: Longint; const rec: TExceptionRecord): Pointer; { Exception }
|
||||
TExceptClsProc=function(code: Longint): Pointer; { ExceptClass }
|
||||
|
||||
{ note: context must be passed by value, so modifications are made to a local copy }
|
||||
function GetBacktrace(Context: TContext; StartingFrame: Pointer; out Frames: PPointer): Longint;
|
||||
@ -336,58 +327,6 @@ begin
|
||||
RaiseException(FPC_EXCEPTION_CODE,EXCEPTION_NONCONTINUABLE,4,@args[0]);
|
||||
end;
|
||||
|
||||
function RunErrorCode(const rec: TExceptionRecord): longint;
|
||||
begin
|
||||
{ negative result means 'FPU reset required' }
|
||||
case rec.ExceptionCode of
|
||||
STATUS_INTEGER_DIVIDE_BY_ZERO: result := 200; { reDivByZero }
|
||||
STATUS_FLOAT_DIVIDE_BY_ZERO: result := -208; { !!reZeroDivide }
|
||||
STATUS_ARRAY_BOUNDS_EXCEEDED: result := 201; { reRangeError }
|
||||
STATUS_STACK_OVERFLOW: result := 202; { reStackOverflow }
|
||||
STATUS_FLOAT_OVERFLOW: result := -205; { reOverflow }
|
||||
STATUS_FLOAT_DENORMAL_OPERAND,
|
||||
STATUS_FLOAT_UNDERFLOW: result := -206; { reUnderflow }
|
||||
STATUS_FLOAT_INEXACT_RESULT,
|
||||
STATUS_FLOAT_INVALID_OPERATION,
|
||||
STATUS_FLOAT_STACK_CHECK: result := -207; { reInvalidOp }
|
||||
STATUS_INTEGER_OVERFLOW: result := 215; { reIntOverflow }
|
||||
STATUS_ILLEGAL_INSTRUCTION: result := -216;
|
||||
STATUS_ACCESS_VIOLATION: result := 216; { reAccessViolation }
|
||||
STATUS_CONTROL_C_EXIT: result := 217; { reControlBreak }
|
||||
STATUS_PRIVILEGED_INSTRUCTION: result := 218; { rePrivilegedInstruction }
|
||||
else
|
||||
result := 255; { reExternalException }
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function FilterException(var rec:TExceptionRecord; imagebase: QWord; scope: PScopeRec): Pointer;
|
||||
var
|
||||
ExClass: TClass;
|
||||
i: Longint;
|
||||
Filter: Pointer;
|
||||
curFilt: PFilterRec;
|
||||
begin
|
||||
result:=nil;
|
||||
if rec.ExceptionCode=FPC_EXCEPTION_CODE then
|
||||
ExClass:=TObject(rec.ExceptionInformation[1]).ClassType
|
||||
else if Assigned(ExceptClsProc) then
|
||||
ExClass:=TClass(TExceptClsProc(ExceptClsProc)(abs(RunErrorCode(rec))))
|
||||
else
|
||||
Exit; { if we cannot determine type of exception, don't handle it }
|
||||
Filter:=Pointer(imagebase+scope^.Typ);
|
||||
for i:=0 to PLongint(Filter)^-1 do
|
||||
begin
|
||||
CurFilt:=@PFilterRec(Filter+sizeof(Longint))[i];
|
||||
if (CurFilt^.RvaClass=$FFFFFFFF) or
|
||||
{ TODO: exception might be coming from another module, need more advanced comparing }
|
||||
(ExClass.InheritsFrom(TClass(imagebase+CurFilt^.RvaClass))) then
|
||||
begin
|
||||
result:=Pointer(imagebase+CurFilt^.RvaHandler);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ifdef DEBUG_SEH}
|
||||
procedure PrintScope(idx: integer; scope: PScopeRec);
|
||||
@ -531,7 +470,7 @@ begin
|
||||
|
||||
if scope^.Typ>SCOPE_IMPLICIT then // filtering needed
|
||||
begin
|
||||
TargetAddr:=FilterException(rec,dispatch.ImageBase,scope);
|
||||
TargetAddr:=FilterException(rec,dispatch.ImageBase,scope^.Typ);
|
||||
if TargetAddr=nil then
|
||||
begin
|
||||
Inc(ScopeIdx);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user