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

* remove the RTL's installed signal handlers at the end of the system

Browse Source 
unit's initialization code in case we're in a library
  + implemented InquireSignal(), AbandonSignalHandler(), HookSignal() and
    UnhookSignal() in the sysutils unit
  * for Kylix compatibility, these routines support operating on
    SIGINT and SIGQUIT as well, although they are not hooked by default
    by FPC. The run time errors/exception codes for these signals are
    resp. 217 and 233 (same as in Kylix; I changed ENoWideStringSupport
    to 234).
  * changed the BSD syscall version of fpsigaction to use pointer
    rather than "var" arguments (compatible with other targets, and
    required to be able to pass nil arguments inside the system unit)
  -> together fixes mantis 

git-svn-id: trunk@13077 -
This commit is contained in:
Jonas Maebe 2009-05-02 09:40:44 +00:00
parent dcb1046b98
commit f6d452c2c0
31 changed files with 578 additions and 69 deletions

2
.gitattributes vendored
View File

@ -8795,6 +8795,8 @@ tests/webtbs/tw12597.pp svneol=native#text/plain
tests/webtbs/tw12614.pp svneol=native#text/plain
tests/webtbs/tw12685.pp svneol=native#text/plain
tests/webtbs/tw1269.pp svneol=native#text/plain
tests/webtbs/tw12704a.pp svneol=native#text/plain
tests/webtbs/tw12704b.pp svneol=native#text/plain
tests/webtbs/tw1275.pp svneol=native#text/plain
tests/webtbs/tw12756.pp svneol=native#text/plain
tests/webtbs/tw12788.pp svneol=native#text/plain

10
rtl/beos/i386/sighnd.inc
View File

@ -16,7 +16,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigContext: PSigContextRec; uContext: Pvregs);cdecl;
procedure SignalToRunerror(sig : longint; SigContext: PSigContextRec; uContext: Pvregs);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res,fpustate : word;
begin
@ -72,6 +72,14 @@ begin
begin
res:=216;
end;
SIGINT:
begin
res:=217
end;
SIGQUIT :
begin
res:=233;
end;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

36
rtl/beos/system.pp
View File

@ -318,10 +318,9 @@ end;
{$i sighnd.inc}
procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER';
var
act: SigActionRec;
Procedure InstallSignals;
begin
{ Initialize the sigaction structure }
{ all flags and information set to zero }
@ -329,12 +328,32 @@ begin
{ initialize handler }
act.sa_handler := SigActionHandler(@SignalToRunError);
act.sa_flags:=SA_SIGINFO;
FpSigAction(SIGFPE,@act,nil);
FpSigAction(SIGSEGV,@act,nil);
FpSigAction(SIGBUS,@act,nil);
FpSigAction(SIGILL,@act,nil);
FpSigAction(signum,@act,@oldact);
end;
var
oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; public name '_FPC_OLDSIGILL';
Procedure InstallSignals;
begin
InstallDefaultSignalHandler(SIGFPE,oldsigfpe);
InstallDefaultSignalHandler(SIGSEGV,oldsigsegv);
InstallDefaultSignalHandler(SIGBUS,oldsigbus);
InstallDefaultSignalHandler(SIGILL,oldsigill);
end;
Procedure RestoreOldSignalHandlers;
begin
FpSigAction(SIGFPE,@oldsigfpe,nil);
FpSigAction(SIGSEGV,@oldsigsegv,nil);
FpSigAction(SIGBUS,@oldsigbus,nil);
FpSigAction(SIGILL,@oldsigill,nil);
end;
procedure SysInitStdIO;
begin
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
@ -361,7 +380,7 @@ begin
if not(IsLibrary) then
SysInitFPU;
{ Set up signals handlers }
{ Set up signals handlers (may be needed by init code to test cpu features) }
InstallSignals;
SysInitStdIO;
@ -425,4 +444,7 @@ begin
initunicodestringmanager;
{$endif VER2_2}
setupexecname;
{ restore original signal handlers in case this is a library }
if IsLibrary then
RestoreOldSignalHandlers;
end.

4
rtl/bsd/ossysc.inc
View File

@ -296,7 +296,7 @@ end;
If OldAct is non-nil the previous action is saved there.
}
function Fpsigaction(sig: cint; var act : sigactionrec; var oact : sigactionrec): cint; [public, alias : 'FPC_SYSC_SIGACTION'];
function Fpsigaction(sig: cint; act, oact: psigactionrec): cint; [public, alias : 'FPC_SYSC_SIGACTION'];
{
Change action of process upon receipt of a signal.
@ -306,7 +306,7 @@ function Fpsigaction(sig: cint; var act : sigactionrec; var oact : sigactionrec)
}
begin
do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(@act),TSysParam(@oact));
do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));
end;
(*=================== MOVED from sysunix.inc ========================*)

44
rtl/bsd/system.pp
View File

@ -146,7 +146,7 @@ End;
{*****************************************************************************
SystemUnit Initialization
System Unit Initialization
*****************************************************************************}
function reenable_signal(sig : longint) : boolean;
@ -171,28 +171,43 @@ end;
{$i sighnd.inc}
procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER';
var
act: SigActionRec;
Procedure InstallSignals;
var
oldact: SigActionRec;
begin
{ Initialize the sigaction structure }
{ all flags and information set to zero }
FillChar(act, sizeof(SigActionRec),0);
FillChar(act,sizeof(SigActionRec),0);
{ initialize handler }
act.sa_handler :=@SignalToRunError;
act.sa_flags:=SA_SIGINFO;
act.sa_handler:=@SignalToRunError;
{$if defined(darwin) and defined(cpu64)}
act.sa_flags:=SA_SIGINFO or SA_64REGSET;
{$else}
act.sa_flags:=SA_SIGINFO;
{$endif}
FpSigAction(SIGFPE,act,oldact);
FpSigAction(SIGSEGV,act,oldact);
FpSigAction(SIGBUS,act,oldact);
FpSigAction(SIGILL,act,oldact);
FpSigAction(signum,@act,@oldact);
end;
var
oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; public name '_FPC_OLDSIGILL';
Procedure InstallSignals;
begin
InstallDefaultSignalHandler(SIGFPE,oldsigfpe);
InstallDefaultSignalHandler(SIGSEGV,oldsigsegv);
InstallDefaultSignalHandler(SIGBUS,oldsigbus);
InstallDefaultSignalHandler(SIGILL,oldsigill);
end;
Procedure RestoreOldSignalHandlers;
begin
FpSigAction(SIGFPE,@oldsigfpe,nil);
FpSigAction(SIGSEGV,@oldsigsegv,nil);
FpSigAction(SIGBUS,@oldsigbus,nil);
FpSigAction(SIGILL,@oldsigill,nil);
end;
@ -300,7 +315,7 @@ Begin
IsConsole := TRUE;
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := Sptr - StackLength;
{ Set up signals handlers }
{ Set up signals handlers (may be needed by init code to test cpu features) }
InstallSignals;
SysResetFPU;
@ -327,4 +342,7 @@ Begin
{$else VER2_2}
initunicodestringmanager;
{$endif VER2_2}
{ restore original signal handlers in case this is a library }
if IsLibrary then
RestoreOldSignalHandlers;
End.

6
rtl/darwin/arm/sighnd.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
procedure SignalToRunerror(Sig: cint; info : PSigInfo; SigContext:PSigContext); cdecl;
procedure SignalToRunerror(Sig: cint; info : PSigInfo; SigContext:PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
@ -40,6 +40,10 @@ begin
SIGILL,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{$ifdef FPC_USE_SIGPROCMASK}
reenable_signal(sig);

6
rtl/darwin/ppcgen/ppchnd.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
procedure SignalToRunerror(Sig: cint; info : PSigInfo; SigContext:PSigContext); cdecl;
procedure SignalToRunerror(Sig: cint; info : PSigInfo; SigContext:PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
@ -44,6 +44,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{$ifdef FPC_USE_SIGPROCMASK}
reenable_signal(sig);

6
rtl/darwin/x86/x86hnd.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); cdecl;
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
p: pbyte;
@ -65,6 +65,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{$ifdef FPC_USE_SIGPROCMASK}
reenable_signal(sig);

6
rtl/freebsd/i386/sighnd.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); cdecl;
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
@ -47,6 +47,10 @@ begin
res:=214;
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{$ifdef FPC_USE_SIGPROCMASK}
reenable_signal(sig);

6
rtl/freebsd/x86_64/sighnd.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); cdecl;
procedure SignalToRunerror(Sig: cint; info : psiginfo; SigContext:PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
@ -38,6 +38,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{$ifdef FPC_USE_SIGPROCMASK}
reenable_signal(sig);

10
rtl/haiku/i386/sighnd.inc
View File

@ -16,7 +16,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigContext: PSigContextRec; uContext: Pvregs);cdecl;
procedure SignalToRunerror(sig : longint; SigContext: PSigContextRec; uContext: Pvregs);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res,fpustate : word;
begin
@ -72,6 +72,14 @@ begin
begin
res:=216;
end;
SIGINT:
begin
res:=217;
end;
SIGQUIT:
begin
res:=233;
end;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

39
rtl/haiku/system.pp
View File

@ -334,23 +334,21 @@ type
end;
var
act: SigActionRec;
alternate_signal_stack : TAlternateSignalStack;
Procedure InstallSignals;
procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER';
var
oldact: SigActionRec;
r : integer;
st : stack_t;
st : stack_t;
begin
FillChar(st, sizeof(st), 0);
st.ss_flags := 0;
st.ss_sp := alternate_signal_stack.buffer;
st.ss_size := SizeOf(alternate_signal_stack);
r := sigaltstack(@st, nil);
if (r <> 0) then
WriteLn('error sigalstack');
{ Initialize the sigaction structure }
@ -359,11 +357,29 @@ begin
{ initialize handler }
act.sa_handler := SigActionHandler(@SignalToRunError);
act.sa_flags := SA_ONSTACK;
FpSigAction(signum,@act,@oldact);
end;
FpSigAction(SIGFPE,@act,@oldact);
FpSigAction(SIGSEGV,@act,@oldact);
FpSigAction(SIGBUS,@act,@oldact);
FpSigAction(SIGILL,@act,@oldact);
var
oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; public name '_FPC_OLDSIGILL';
Procedure InstallSignals;
begin
InstallDefaultSignalHandler(SIGFPE,oldsigfpe);
InstallDefaultSignalHandler(SIGSEGV,oldsigsegv);
InstallDefaultSignalHandler(SIGBUS,oldsigbus);
InstallDefaultSignalHandler(SIGILL,oldsigill);
end;
Procedure RestoreOldSignalHandlers;
begin
FpSigAction(SIGFPE,@oldsigfpe,nil);
FpSigAction(SIGSEGV,@oldsigsegv,nil);
FpSigAction(SIGBUS,@oldsigbus,nil);
FpSigAction(SIGILL,@oldsigill,nil);
end;
procedure SysInitStdIO;
@ -458,4 +474,7 @@ begin
initunicodestringmanager;
{$endif VER2_2}
setupexecname;
{ restore original signal handlers in case this is a library }
if IsLibrary then
RestoreOldSignalHandlers;
end.

6
rtl/linux/arm/sighnd.inc
View File

@ -16,7 +16,7 @@
**********************************************************************}
procedure SignalToRunerror(Sig: longint; { _a2,_a3,_a4 : dword; } SigContext: PSigInfo; uContext : PuContext); cdecl;
procedure SignalToRunerror(Sig: longint; { _a2,_a3,_a4 : dword; } SigContext: PSigInfo; uContext : PuContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res,fpustate : word;
@ -41,6 +41,10 @@ begin
res:=216;
SIGBUS:
res:=214;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

6
rtl/linux/i386/sighnd.inc
View File

@ -16,7 +16,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; UContext: Pucontext);cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; UContext: Pucontext);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res,fpustate : word;
begin
@ -63,6 +63,10 @@ begin
res:=216;
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

6
rtl/linux/m68k/sighnd.inc
View File

@ -64,7 +64,7 @@ end;
procedure SignalToRunerror(Sig: longint; Info : pointer; var SigContext: TSigContext); cdecl;
procedure SignalToRunerror(Sig: longint; Info : pointer; var SigContext: TSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res,fpustate : word;
begin
@ -101,6 +101,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);

6
rtl/linux/powerpc/sighnd.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; context: PUContext);cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; context: PUContext);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res : word;
{ fpustate: longint; }
@ -39,6 +39,10 @@ begin
SIGILL,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

6
rtl/linux/powerpc64/sighnd.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; context: PUContext); cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; context: PUContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
begin
@ -38,6 +38,10 @@ begin
SIGILL,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
{ reenable signal }

6
rtl/linux/sparc/sighnd.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res : word;
addr : pointer;
@ -52,6 +52,10 @@ begin
addr := siginfo^._sifields._sigfault._addr;
res:=216;
end;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

35
rtl/linux/system.pp
View File

@ -236,10 +236,9 @@ end;
{$i sighnd.inc}
procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER';
var
act: SigActionRec;
Procedure InstallSignals;
begin
{ Initialize the sigaction structure }
{ all flags and information set to zero }
@ -247,10 +246,21 @@ begin
{ initialize handler }
act.sa_handler := SigActionHandler(@SignalToRunError);
act.sa_flags:=SA_SIGINFO;
FpSigAction(SIGFPE,@act,nil);
FpSigAction(SIGSEGV,@act,nil);
FpSigAction(SIGBUS,@act,nil);
FpSigAction(SIGILL,@act,nil);
FpSigAction(signum,@act,@oldact);
end;
var
oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; public name '_FPC_OLDSIGILL';
Procedure InstallSignals;
begin
InstallDefaultSignalHandler(SIGFPE,oldsigfpe);
InstallDefaultSignalHandler(SIGSEGV,oldsigsegv);
InstallDefaultSignalHandler(SIGBUS,oldsigbus);
InstallDefaultSignalHandler(SIGILL,oldsigill);
end;
procedure SysInitStdIO;
@ -262,6 +272,14 @@ begin
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
end;
Procedure RestoreOldSignalHandlers;
begin
FpSigAction(SIGFPE,@oldsigfpe,nil);
FpSigAction(SIGSEGV,@oldsigsegv,nil);
FpSigAction(SIGBUS,@oldsigbus,nil);
FpSigAction(SIGILL,@oldsigill,nil);
end;
procedure SysInitExecPath;
var
@ -318,7 +336,7 @@ begin
IsConsole := TRUE;
StackLength := CheckInitialStkLen(initialStkLen);
StackBottom := initialstkptr - StackLength;
{ Set up signals handlers }
{ Set up signals handlers (may be needed by init code to test cpu features) }
InstallSignals;
{$if defined(cpui386) or defined(cpuarm)}
@ -342,4 +360,7 @@ begin
{$else VER2_2}
initunicodestringmanager;
{$endif VER2_2}
{ restore original signal handlers in case this is a library }
if IsLibrary then
RestoreOldSignalHandlers;
end.

6
rtl/linux/x86_64/sighnd.inc
View File

@ -32,7 +32,7 @@ function GetFPUState(const SigContext : TSigContext) : word;
end;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext); cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res,fpustate : word;
begin
@ -68,6 +68,10 @@ procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigCon
SIGBUS,
SIGSEGV:
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
if res<>0 then

6
rtl/netbsd/i386/sighnd.inc
View File

@ -19,7 +19,7 @@ function getfpustate(const Sigcontext:sigcontextRec):longint; {inline;}
begin
getfpustate:=0;
end;
procedure SignalToRunerror(Sig: longint;code:longint; var SigContext: SigContextRec); cdecl;
procedure SignalToRunerror(Sig: longint;code:longint; var SigContext: SigContextRec); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res,fpustate : word;
@ -65,6 +65,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

10
rtl/netbsd/powerpc/sighnd.inc
View File

@ -20,7 +20,7 @@ begin
getfpustate:=0;
end;
procedure SignalToRunerror(signo: cint); cdecl;
procedure SignalToRunerror(signo: cint); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res : word;
begin
@ -33,6 +33,14 @@ begin
if (signo = SIGILL) or (signo = SIGBUS) or (signo = SIGSEGV) then
begin
res := 216;
end
else if (signo = SIGINT) then
begin
res:=217;
end
else if (signo = SIGKILL) then
begin
res:=233
end;
{ give runtime error at the position where the signal was raised }
if res<>0 then

1
rtl/objpas/sysconst.pp
View File

@ -77,6 +77,7 @@ resourcestring
SNoError = 'No error.';
SNoThreadSupport = 'Threads not supported. Recompile program with thread driver.';
SMissingWStringManager = 'Widestring manager not available. Recompile program with appropriate manager.';
SSigQuit = 'SIGQUIT signal received.';
SOSError = 'System error, (OS Code %d):'+LineEnding+'%s';
SOutOfMemory = 'Out of memory';
SOverflow = 'Floating point overflow';

3
rtl/objpas/sysutils/sysutils.inc
View File

@ -331,7 +331,8 @@ begin
229 : E:=ESafecallException.Create(SSafecallException);
231 : E:=EConvertError.Create(SiconvError);
232 : E:=ENoThreadSupport.Create(SNoThreadSupport);
233 : E:=ENoWideStringSupport.Create(SMissingWStringManager);
233 : E:=ENoWideStringSupport.Create(SSigQuit);
234 : E:=ENoWideStringSupport.Create(SMissingWStringManager);
else
E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
end;

6
rtl/openbsd/i386/sighnd.inc
View File

@ -19,7 +19,7 @@ function getfpustate(const Sigcontext:sigcontextRec):longint; {inline;}
begin
getfpustate:=0;
end;
procedure SignalToRunerror(Sig: longint;code:longint; var SigContext: SigContextRec); cdecl;
procedure SignalToRunerror(Sig: longint;code:longint; var SigContext: SigContextRec); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
res,fpustate : word;
@ -65,6 +65,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

6
rtl/solaris/i386/sighnd.inc
View File

@ -16,7 +16,7 @@
**********************************************************************}
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res,fpustate : word;
begin
@ -50,6 +50,10 @@ begin
SIGBUS,
SIGSEGV :
res:=216;
SIGINT:
res:=217;
SIGKILL :
res:=233;
end;
{ give runtime error at the position where the signal was raised }
if res<>0 then

6
rtl/solaris/sparc/sighnd.inc
View File

@ -32,7 +32,7 @@ const
FPE_FLTSUB = 8;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);cdecl;
procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);public name '_FPC_DEFAULTSIGHANDLER';cdecl;
var
res : word;
addr : pointer;
@ -76,6 +76,10 @@ begin
begin
res:=214;
end;
SIGINT:
res:=217;
SIGQUIT:
res:=233;
end;
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }

37
rtl/solaris/system.pp
View File

@ -121,12 +121,9 @@ end;
{$i sighnd.inc}
procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER';
var
act: SigActionRec;
Procedure InstallSignals;
var
oldact: SigActionRec;
begin
{ Initialize the sigaction structure }
{ all flags and information set to zero }
@ -134,10 +131,29 @@ begin
{ initialize handler }
act.sa_handler :=@SignalToRunError;
act.sa_flags:=SA_SIGINFO;
FpSigAction(SIGFPE,act,oldact);
FpSigAction(SIGSEGV,act,oldact);
FpSigAction(SIGBUS,act,oldact);
FpSigAction(SIGILL,act,oldact);
FpSigAction(signum,act,oldact);
end;
var
oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; public name '_FPC_OLDSIGILL';
Procedure InstallSignals;
begin
InstallDefaultSignalHandler(SIGFPE,oldsigfpe);
InstallDefaultSignalHandler(SIGSEGV,oldsigsegv);
InstallDefaultSignalHandler(SIGBUS,oldsigbus);
InstallDefaultSignalHandler(SIGILL,oldsigill);
end;
Procedure RestoreOldSignalHandlers;
begin
FpSigAction(SIGFPE,@oldsigfpe,nil);
FpSigAction(SIGSEGV,@oldsigsegv,nil);
FpSigAction(SIGBUS,@oldsigbus,nil);
FpSigAction(SIGILL,@oldsigill,nil);
end;
@ -224,7 +240,7 @@ Begin
IsConsole := TRUE;
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := Sptr - StackLength;
{ Set up signals handlers }
{ Set up signals handlers (may be needed by init code to test cpu features) }
InstallSignals;
{ Setup heap }
InitHeap;
@ -242,4 +258,7 @@ Begin
{$else VER2_2}
initunicodestringmanager;
{$endif VER2_2}
{ restore original signal handlers in case this is a library }
if IsLibrary then
RestoreOldSignalHandlers;
End.

164
rtl/unix/sysutils.pp
View File

@ -66,23 +66,185 @@ implementation
Uses
{$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF}, Baseunix, unixutil;
function InquireSignal(RtlSigNum: Integer): TSignalState;
type
tsiginfo = record
oldsiginfo: sigactionrec;
hooked: boolean;
end;
const
rtlsig2ossig: array[RTL_SIGINT..RTL_SIGLAST] of byte =
(SIGINT,SIGFPE,SIGSEGV,SIGILL,SIGBUS,SIGQUIT);
{ to avoid linking in all this stuff in every program,
as it's unlikely to be used by anything but libraries
}
signalinfoinited: boolean = false;
var
siginfo: array[RTL_SIGINT..RTL_SIGLAST] of tsiginfo;
oldsigfpe: SigActionRec; external name '_FPC_OLDSIGFPE';
oldsigsegv: SigActionRec; external name '_FPC_OLDSIGSEGV';
oldsigbus: SigActionRec; external name '_FPC_OLDSIGBUS';
oldsigill: SigActionRec; external name '_FPC_OLDSIGILL';
procedure defaultsighandler; external name '_FPC_DEFAULTSIGHANDLER';
procedure installdefaultsignalhandler(signum: Integer; out oldact: SigActionRec); external name '_FPC_INSTALLDEFAULTSIGHANDLER';
function InternalInquireSignal(RtlSigNum: Integer; out act: SigActionRec; frominit: boolean): TSignalState;
begin
result:=ssNotHooked;
if (RtlSigNum<>RTL_SIGDEFAULT) and
(RtlSigNum<RTL_SIGLAST) then
begin
if (frominit or
siginfo[RtlSigNum].hooked) and
(fpsigaction(rtlsig2ossig[RtlSigNum],nil,@act)=0) then
begin
if not frominit then
begin
{ check whether the installed signal handler is still ours }
if (pointer(act.sa_handler)=pointer(@defaultsighandler)) then
result:=ssHooked
else
result:=ssOverridden;
end
else if IsLibrary then
begin
{ library -> signals have not been hooked by system init code }
exit
end
else
begin
{ program -> signals have been hooked by system init code }
if (byte(RtlSigNum) in [RTL_SIGFPE,RTL_SIGSEGV,RTL_SIGILL,RTL_SIGBUS]) then
begin
if (pointer(act.sa_handler)=pointer(@defaultsighandler)) then
result:=ssHooked
else
result:=ssOverridden;
{ return the original handlers as saved by the system unit
(the current call to sigaction simply returned our
system unit's installed handlers)
}
case RtlSigNum of
RTL_SIGFPE:
act:=oldsigfpe;
RTL_SIGSEGV:
act:=oldsigsegv;
RTL_SIGILL:
act:=oldsigill;
RTL_SIGBUS:
act:=oldsigbus;
end;
end
else
begin
{ these are not hooked in the startup code }
result:=ssNotHooked;
end
end
end
end;
end;
procedure initsignalinfo;
var
i: Integer;
begin
for i:=RTL_SIGINT to RTL_SIGLAST do
siginfo[i].hooked:=(InternalInquireSignal(i,siginfo[i].oldsiginfo,true)=ssHooked);
signalinfoinited:=true;
end;
function InquireSignal(RtlSigNum: Integer): TSignalState;
var
act: SigActionRec;
begin
if not signalinfoinited then
initsignalinfo;
result:=InternalInquireSignal(RtlSigNum,act,false);
end;
procedure AbandonSignalHandler(RtlSigNum: Integer);
begin
if not signalinfoinited then
initsignalinfo;
if (RtlSigNum<>RTL_SIGDEFAULT) and
(RtlSigNum<RTL_SIGLAST) then
siginfo[RtlSigNum].hooked:=false;
end;
procedure HookSignal(RtlSigNum: Integer);
var
lowsig, highsig, i: Integer;
begin
if not signalinfoinited then
initsignalinfo;
if (RtlSigNum<>RTL_SIGDEFAULT) then
begin
lowsig:=RtlSigNum;
highsig:=RtlSigNum;
end
else
begin
{ we don't hook SIGINT and SIGQUIT by default }
lowsig:=RTL_SIGFPE;
highsig:=RTL_SIGBUS;
end;
{ install the default rtl signal handler for the selected signal(s) }
for i:=lowsig to highsig do
begin
installdefaultsignalhandler(rtlsig2ossig[i],siginfo[i].oldsiginfo);
siginfo[i].hooked:=true;
end;
end;
procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True);
var
act: SigActionRec;
lowsig, highsig, i: Integer;
state: TSignalState;
begin
if not signalinfoinited then
initsignalinfo;
if (RtlSigNum<>RTL_SIGDEFAULT) then
begin
lowsig:=RtlSigNum;
highsig:=RtlSigNum;
end
else
begin
{ we don't hook SIGINT and SIGQUIT by default }
lowsig:=RTL_SIGFPE;
highsig:=RTL_SIGBUS;
end;
for i:=lowsig to highsig do
begin
if not OnlyIfHooked or
(InquireSignal(i)=ssHooked) then
begin
{ restore the handler that was present when we hooked the signal,
if we hooked it at one time or another. If the user doesn't
want this, they have to call AbandonSignalHandler() first
}
if siginfo[i].hooked then
act:=siginfo[i].oldsiginfo
else
begin
fillchar(act,sizeof(act),0);
pointer(act.sa_handler):=pointer(SIG_DFL);
end;
if (fpsigaction(rtlsig2ossig[RtlSigNum],@act,nil)=0) then
siginfo[i].hooked:=false;
end;
end;
end;
{$Define OS_FILEISREADONLY} // Specific implementation for Unix.

107
tests/webtbs/tw12704a.pp Normal file
View File

@ -0,0 +1,107 @@
{ %norun }
{ %target=darwin,linux,freebsd,solaris,beos,haiku }
{$mode delphi}
{$ifdef darwin}
{$PIC+}
{$endif darwin}
{$ifdef CPUX86_64}
{$ifndef WINDOWS}
{$PIC+}
{$endif WINDOWS}
{$endif CPUX86_64}
library tw12704a;
uses
SysUtils;
procedure initsignals;
var
p: pointer;
i: longint;
begin
// check that none of the handlers have been yet by the library's init code
for i:=RTL_SIGINT to RTL_SIGLAST do
if (InquireSignal(i) <> ssNotHooked) then
halt(1);
// hook standard signals
HookSignal(RTL_SIGDEFAULT);
for i:=RTL_SIGINT to RTL_SIGLAST do
case i of
RTL_SIGINT,
RTL_SIGQUIT:
if (InquireSignal(i) <> ssNotHooked) then
halt(2);
RTL_SIGFPE,
RTL_SIGSEGV,
RTL_SIGILL,
RTL_SIGBUS:
if (InquireSignal(i) <> ssHooked) then
halt(3);
else
halt(4);
end;
// unhook sigill
UnHookSignal(RTL_SIGILL);
for i:=RTL_SIGINT to RTL_SIGLAST do
case i of
RTL_SIGINT,
RTL_SIGILL,
RTL_SIGQUIT:
if (InquireSignal(i) <> ssNotHooked) then
halt(5);
RTL_SIGFPE,
RTL_SIGSEGV,
RTL_SIGBUS:
if (InquireSignal(i) <> ssHooked) then
halt(6);
end;
// check whether installed signal handler actually works
(*
try
p:=nil;
longint(p^):=1;
except
end;
*)
end;
procedure testsignals; cdecl;
var
i: longint;
begin
// called from program -> it has overridden our signal handlers
// when this routine is called, it will have unhooked sigbus, so
// that one should still belong to us
// we previously unhooked sigill, so that one should still be
// unhooked as far as we are concerned
for i:=RTL_SIGINT to RTL_SIGLAST do
case i of
RTL_SIGINT,
RTL_SIGILL,
RTL_SIGQUIT:
if (InquireSignal(i) <> ssNothooked) then
halt(7);
RTL_SIGFPE,
RTL_SIGSEGV:
if (InquireSignal(i) <> ssOverridden) then
halt(8);
RTL_SIGBUS:
if (InquireSignal(i) <> ssHooked) then
halt(9);
end;
end;
exports
testsignals;
begin
initsignals;
end.

49
tests/webtbs/tw12704b.pp Normal file
View File

@ -0,0 +1,49 @@
{ %target=darwin,linux,freebsd,solaris,beos,haiku }
{ %NEEDLIBRARY }
{$mode delphi}
program MainApp;
uses
sysutils;
const
{$ifdef windows}
libname='tw12704a.dll';
{$else}
libname='tw12704a';
{$linklib tw12704a}
{$endif}
procedure testsignals; cdecl; external libname;
procedure initsignals;
var
p: pointer;
i: longint;
begin
// check that standard signals are hooked
for i:=RTL_SIGINT to RTL_SIGLAST do
case i of
RTL_SIGINT,
RTL_SIGQUIT:
if (InquireSignal(i) <> ssNotHooked) then
halt(102);
RTL_SIGFPE,
RTL_SIGSEGV,
RTL_SIGILL,
RTL_SIGBUS:
if (InquireSignal(i) <> ssHooked) then
halt(103);
else
halt(104);
end;
// unhook sigbus
UnhookSignal(RTL_SIGBUS);
end;
begin
initsignals;
testsignals
end.