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

* floating point exception checking support for aix for libc helpers

Browse Source 
(they don't raise exceptions themselves)

git-svn-id: trunk@20814 -
This commit is contained in:
Jonas Maebe 2012-04-11 18:04:21 +00:00
parent 909f99b4c7
commit 7e9da1ce1a
1 changed files with 84 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
rtl/inc/cgenmath.inc
View File

@ -20,6 +20,67 @@
{$ifndef SOLARIS}
{$ifdef aix}
{ aix math library routines don't raise exceptions, you have to manually
check for them }
function feclearexcept(flags: longint): longint; cdecl; external 'c';
function fetestexcept(flags: longint): longint; cdecl; external 'c';
const
FE_DIVBYZERO = $04000000;
FE_INEXACT = $02000000;
FE_INVALID = $20000000;
FE_OVERFLOW = $10000000;
FE_UNDERFLOW = $08000000;
FE_ALL_EXCEPT = $3E000000;
procedure resetexcepts;
begin
seterrno(0);
feclearexcept(FE_ALL_EXCEPT);
end;
procedure checkexcepts;
var
feres: longint;
sfexcepts: shortint;
begin
feres:=fetestexcept(FE_ALL_EXCEPT);
sfexcepts:=0;
if feres<>0 then
begin
if (feres and FE_DIVBYZERO) <> 0 then
sfexcepts:=sfexcepts or float_flag_divbyzero;
if (feres and FE_INEXACT) <> 0 then
sfexcepts:=sfexcepts or float_flag_inexact;
if (feres and FE_INVALID) <> 0 then
sfexcepts:=sfexcepts or float_flag_invalid;
if (feres and FE_OVERFLOW) <> 0 then
sfexcepts:=sfexcepts or float_flag_overflow;
if (feres and FE_UNDERFLOW) <> 0 then
sfexcepts:=sfexcepts or float_flag_underflow;
end
{ unknown error }
else if (geterrno<>0) then
sfexcepts:=sfexcepts or float_flag_invalid;
if sfexcepts<>0 then
float_raise(sfexcepts);
end;
{$else aix}
procedure resetexcepts; inline;
begin
end;
procedure checkexcepts; inline;
begin
end;
{$endif aix}
{$ifndef FPC_SYSTEM_HAS_INT}
{$define FPC_SYSTEM_HAS_INT}
@ -28,7 +89,9 @@
function fpc_int_real(d: ValReal): ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_trunc(d);
checkexcepts;
end;
@ -40,7 +103,9 @@
begin
{ this will be correct since real = single in the case of }
{ the motorola version of the compiler... }
resetexcepts;
int:=c_truncf(d);
checkexcepts;
end;
{$endif SUPPORT_DOUBLE}
@ -55,8 +120,10 @@
var
l: longint;
begin
resetexcepts;
frexp := c_frexp(x,l);
e := l;
checkexcepts;
end;
{$endif not SYSTEM_HAS_FREXP}
@ -67,7 +134,9 @@
function ldexp( x: ValReal; N: Integer):ValReal;{$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
ldexp := c_ldexp(x,n);
checkexcepts;
end;
{$endif not SYSTEM_HAS_LDEXP}
@ -79,7 +148,9 @@
function fpc_sqrt_real(d:ValReal):ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_sqrt(d);
checkexcepts;
end;
{$endif}
@ -89,9 +160,12 @@
{$define FPC_SYSTEM_HAS_EXP}
function c_exp(d: double): double; cdecl; external 'c' name 'exp';
function fpc_Exp_real(d:ValReal):ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
result := c_exp(d);
begin
resetexcepts;
result := c_exp(d);
checkexcepts;
end;
{$endif}
@ -103,7 +177,9 @@
function fpc_Ln_real(d:ValReal):ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_log(d);
checkexcepts;
end;
{$endif}
@ -114,7 +190,9 @@
function fpc_Sin_real(d:ValReal):ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_sin(d);
checkexcepts;
end;
{$endif}
@ -126,7 +204,9 @@
function fpc_Cos_real(d:ValReal):ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_cos(d);
checkexcepts;
end;
{$endif}
@ -138,7 +218,9 @@
function fpc_ArcTan_real(d:ValReal):ValReal;compilerproc; {$ifdef MATHINLINE}inline;{$endif}
begin
resetexcepts;
result := c_atan(d);
checkexcepts;
end;
{$endif}