paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 21:49:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix for Mantis #36544: provide an overall exception handler for the library startup code in case of unhandled exceptions (the loading of the library is considered failed in that case) when SEH is active

Browse Source 
+ added test

git-svn-id: trunk@43901 -
This commit is contained in:
svenbarth 2020-01-10 15:39:20 +00:00
parent 8700f1d090
commit 7a0a1d9f36
5 changed files with 60 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -17917,6 +17917,8 @@ tests/webtbs/tw36496a.pp svneol=native#text/pascal
tests/webtbs/tw36496b.pp svneol=native#text/pascal tests/webtbs/tw36496b.pp svneol=native#text/pascal
tests/webtbs/tw3650.pp svneol=native#text/plain tests/webtbs/tw3650.pp svneol=native#text/plain
tests/webtbs/tw3653.pp svneol=native#text/plain tests/webtbs/tw3653.pp svneol=native#text/plain
tests/webtbs/tw36544a.pp svneol=native#text/pascal
tests/webtbs/tw36544b.pp svneol=native#text/pascal
tests/webtbs/tw3661.pp svneol=native#text/plain tests/webtbs/tw3661.pp svneol=native#text/plain
tests/webtbs/tw3666.pp svneol=native#text/plain tests/webtbs/tw3666.pp svneol=native#text/plain
tests/webtbs/tw3669.pp svneol=native#text/plain tests/webtbs/tw3669.pp svneol=native#text/plain
@ -18483,6 +18485,7 @@ tests/webtbs/uw3474b.pp svneol=native#text/plain
tests/webtbs/uw35918a.pp svneol=native#text/pascal tests/webtbs/uw35918a.pp svneol=native#text/pascal
tests/webtbs/uw35918b.pp svneol=native#text/pascal tests/webtbs/uw35918b.pp svneol=native#text/pascal
tests/webtbs/uw35918c.pp svneol=native#text/pascal tests/webtbs/uw35918c.pp svneol=native#text/pascal
tests/webtbs/uw36544.pp svneol=native#text/pascal
tests/webtbs/uw3968.pp svneol=native#text/plain tests/webtbs/uw3968.pp svneol=native#text/plain
tests/webtbs/uw4056.pp svneol=native#text/plain tests/webtbs/uw4056.pp svneol=native#text/plain
tests/webtbs/uw4140.pp svneol=native#text/plain tests/webtbs/uw4140.pp svneol=native#text/plain

13
rtl/win/syswin.inc
View File

@ -371,6 +371,10 @@ Var
DLLInitState : Longint = -1; DLLInitState : Longint = -1;
DLLBuf : Jmp_buf; DLLBuf : Jmp_buf;
{$if defined(FPC_USE_WIN32_SEH) or defined(FPC_USE_WIN64_SEH)}
{$define FPC_USE_SEH}
{$endif}
function Dll_entry{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}(constref info : TEntryInformation){$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION} : longbool; [public,alias:'_FPC_DLL_Entry']; function Dll_entry{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}(constref info : TEntryInformation){$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION} : longbool; [public,alias:'_FPC_DLL_Entry'];
begin begin
{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
@ -386,12 +390,21 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}(constref info : TE
If SetJmp(DLLBuf) = 0 then If SetJmp(DLLBuf) = 0 then
begin begin
{$ifdef FPC_USE_SEH}
try
{$endif}
{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
EntryInformation.PascalMain(); EntryInformation.PascalMain();
{$else FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$else FPC_HAS_INDIRECT_ENTRY_INFORMATION}
PascalMain; PascalMain;
{$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION}
Dll_entry:=true; Dll_entry:=true;
{$ifdef FPC_USE_SEH}
except
DoUnHandledException;
Dll_entry:=false;
end;
{$endif}
end end
else else
Dll_entry:=(ExitCode=0); Dll_entry:=(ExitCode=0);

17
tests/webtbs/tw36544a.pp Normal file
View File

@ -0,0 +1,17 @@
{ %target=win32,win64,wince,darwin,linux,freebsd,solaris,beos,aix,android,haiku }
{ %needlibrary }
{$mode objfpc}
library tw36544a;
uses
uw36544;
procedure library_procedure;
begin
writeln('Not ok');
end;
exports library_procedure;
begin
end.

18
tests/webtbs/tw36544b.pp Normal file
View File

@ -0,0 +1,18 @@
{ %target=win32,win64,wince }
{ %needlibrary }
{ %result=-1073741502 }
{ ToDo: check whether the exit code is the same for the following targets: darwin,linux,freebsd,solaris,beos,aix,android,haiku }
{$mode objfpc}
uses
sysutils;
{$ifndef windows}
{$linklib tw36544a}
{$endif}
procedure library_procedure; external {$ifdef windows}'tw36544a'{$endif};
begin
library_procedure;
end.

9
tests/webtbs/uw36544.pp Normal file
View File

@ -0,0 +1,9 @@
{$mode objfpc}
unit uw36544;
interface
uses
sysutils;
implementation
initialization
raise Exception.Create('One should see this exception.');
end.