Hi,
I was bored and I played around with SEH exceptions. It might be useful
in some cases when you can't catch an exception in a dll but there might
also be easier methods in some cases. I though before the code will be
forgotten and deleted again I post it here:
the unit seh.pas contains the handler. This handler is very simple, it
will handle all exceptions and always restore the stack to the state it
was when the handler was installed and use the address that was pushed
to the stack to continue execution.
the file sehtest.pas uses this unit and sets up a try/except construct
with two asm blocks and some labels and then triggers an exception
somewhere deeper in the callstack (to test the proper restoring of the
stack). If FPC had more flexible macros then it could be made a bit
nicer but it fulfills its purpose.
Bernd
unit SEH;
{$mode objfpc}
interface
function handler(
ExceptionRecord: Pointer;
EstablisherFrame: Pointer;
ContextRecord: Pointer;
DispatcherContext: Pointer): DWORD; stdcall;
implementation
uses
sysutils;
const // these consts are copy-pasted from system.pp
EXCEPTION_MAXIMUM_PARAMETERS = 15;
MAXIMUM_SUPPORTED_EXTENSION = 512;
type // these types are copy-pasted from system.pp
PFloatingSaveArea = ^TFloatingSaveArea;
TFloatingSaveArea = packed record
ControlWord : Cardinal;
StatusWord : Cardinal;
TagWord : Cardinal;
ErrorOffset : Cardinal;
ErrorSelector : Cardinal;
DataOffset : Cardinal;
DataSelector : Cardinal;
RegisterArea : array[0..79] of Byte;
Cr0NpxState : Cardinal;
end;
PContext = ^TContext;
TContext = packed record
//
// The flags values within this flag control the contents of
// a CONTEXT record.
//
ContextFlags : Cardinal;
//
// This section is specified/returned if CONTEXT_DEBUG_REGISTERS is
// set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT
// included in CONTEXT_FULL.
//
Dr0, Dr1, Dr2,
Dr3, Dr6, Dr7 : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_FLOATING_POINT.
//
FloatSave : TFloatingSaveArea;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_SEGMENTS.
//
SegGs, SegFs,
SegEs, SegDs : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_INTEGER.
//
Edi, Esi, Ebx,
Edx, Ecx, Eax : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_CONTROL.
//
Ebp : Cardinal;
Eip : Cardinal;
SegCs : Cardinal;
EFlags, Esp, SegSs : Cardinal;
//
// This section is specified/returned if the ContextFlags word
// contains the flag CONTEXT_EXTENDED_REGISTERS.
// The format and contexts are processor specific
//
ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte;
end;
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord = packed record
ExceptionCode : cardinal;
ExceptionFlags : Longint;
ExceptionRecord : PExceptionRecord;
ExceptionAddress : Pointer;
NumberParameters : Longint;
ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
end;
function handler(
ExceptionRecord: Pointer;
EstablisherFrame: Pointer;
ContextRecord: Pointer;
DispatcherContext: Pointer): DWORD; stdcall;
var
exceptaddr : PDWORD;
begin
writeln(format('exception %x', [PExceptionRecord(ExceptionRecord)^.ExceptionCode]));
exceptaddr := EstablisherFrame + 12; // 3 pushs earlier (the except label)
PContext(ContextRecord)^.Eip := exceptaddr^;
PContext(ContextRecord)^.Esp := DWORD(EstablisherFrame);
Result := 0;
end;
end.
program sehtest;
{$mode objfpc}{$H+}
{$asmmode intel}
uses
SEH, sysutils;
procedure foo2(foobaz: integer);
var
x : integer;
begin
x := 1 div foobaz;
//PInteger(nil)^ := foobaz;
end;
procedure foo1(foobaz: integer);
var
x : integer;
begin
foo2(foobaz);
end;
procedure foo(foobaz: integer);
var
x : integer;
begin
foo1(foobaz);
end;
procedure test;
label
__except, __finally;
begin
writeln(IntToHex(PtrUInt(@__except), 8));
// ****** TRY ****** (push the except address and ebp and then install SEH)
asm
lea eax, __except
push eax
push ebp
push handler
push fs:[0]
mov fs:[0], esp
end;
// ****** TRY ******
writeln('trying...');
foo(0); // provoke exception somewhere deeper in the callstack
goto __finally;
__except:
writeln('except');
__finally:
// ****** FINALLY ****** (undo the things done in try)
asm
pop eax
mov fs:[0], eax
pop eax // handler
pop ebp
pop eax // except label
end;
// ****** FINALLY ******
writeln('finally');
end;
begin
test;
end.
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
