File : a-ngelfu.adb
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
5 -- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS --
-- --
-- B o d y --
-- --
-- $Revision: 1.45 $
10 -- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
30 -- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
35
-- This body is specifically for using an Ada interface to C math.h to get
-- the computation engine. Many special cases are handled locally to avoid
-- unnecessary calls. This is not a "strict" implementation, but takes full
-- advantage of the C functions, e.g. in providing interface to hardware
40 -- provided versions of the elementary functions.
-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan,
-- sinh, cosh, tanh from C library via math.h
45 with Ada.Numerics.Aux;
package body Ada.Numerics.Generic_Elementary_Functions is
use type Ada.Numerics.Aux.Double;
50
Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
Half_Log_Two : constant := Log_Two / 2;
55 subtype T is Float_Type'Base;
subtype Double is Aux.Double;
Two_Pi : constant T := 2.0 * Pi;
Half_Pi : constant T := Pi / 2.0;
60 Fourth_Pi : constant T := Pi / 4.0;
Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa);
IEpsilon : constant T := 2.0 ** (T'Model_Mantissa - 1);
Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Log_Two;
65 Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two;
Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two;
Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa);
DEpsilon : constant Double := Double (Epsilon);
70 DIEpsilon : constant Double := Double (IEpsilon);
-----------------------
-- Local Subprograms --
-----------------------
75
function Exp_Strict (X : Float_Type'Base) return Float_Type'Base;
-- Cody/Waite routine, supposedly more precise than the library
-- version. Currently only needed for Sinh/Cosh on X86 with the largest
-- FP type.
80
function Local_Atan
(Y : Float_Type'Base;
X : Float_Type'Base := 1.0)
return Float_Type'Base;
85 -- Common code for arc tangent after cyele reduction
----------
-- "**" --
----------
90
function "**" (Left, Right : Float_Type'Base) return Float_Type'Base is
A_Right : Float_Type'Base;
Int_Part : Integer;
Result : Float_Type'Base;
95 R1 : Float_Type'Base;
Rest : Float_Type'Base;
begin
if Left = 0.0
100 and then Right = 0.0
then
raise Argument_Error;
elsif Left < 0.0 then
105 raise Argument_Error;
elsif Right = 0.0 then
return 1.0;
110 elsif Left = 0.0 then
if Right < 0.0 then
raise Constraint_Error;
else
return 0.0;
115 end if;
elsif Left = 1.0 then
return 1.0;
120 elsif Right = 1.0 then
return Left;
else
begin
125 if Right = 2.0 then
return Left * Left;
elsif Right = 0.5 then
return Sqrt (Left);
130
else
A_Right := abs (Right);
-- If exponent is larger than one, compute integer exponen-
135 -- tiation if possible, and evaluate fractional part with
-- more precision. The relative error is now proportional
-- to the fractional part of the exponent only.
if A_Right > 1.0
140 and then A_Right < Float_Type'Base (Integer'Last)
then
Int_Part := Integer (Float_Type'Base'Truncation (A_Right));
Result := Left ** Int_Part;
Rest := A_Right - Float_Type'Base (Int_Part);
145
-- Compute with two leading bits of the mantissa using
-- square roots. Bound to be better than logarithms, and
-- easily extended to greater precision.
150 if Rest >= 0.5 then
R1 := Sqrt (Left);
Result := Result * R1;
Rest := Rest - 0.5;
155 if Rest >= 0.25 then
Result := Result * Sqrt (R1);
Rest := Rest - 0.25;
end if;
160 elsif Rest >= 0.25 then
Result := Result * Sqrt (Sqrt (Left));
Rest := Rest - 0.25;
end if;
165 Result := Result *
Float_Type'Base (Aux.Pow (Double (Left), Double (Rest)));
if Right >= 0.0 then
return Result;
170 else
return (1.0 / Result);
end if;
else
return
175 Float_Type'Base (Aux.Pow (Double (Left), Double (Right)));
end if;
end if;
exception
180 when others =>
raise Constraint_Error;
end;
end if;
end "**";
185
------------
-- Arccos --
------------
190 -- Natural cycle
function Arccos (X : Float_Type'Base) return Float_Type'Base is
Temp : Float_Type'Base;
195 begin
if abs X > 1.0 then
raise Argument_Error;
elsif abs X < Sqrt_Epsilon then
200 return Pi / 2.0 - X;
elsif X = 1.0 then
return 0.0;
205 elsif X = -1.0 then
return Pi;
end if;
Temp := Float_Type'Base (Aux.Acos (Double (X)));
210
if Temp < 0.0 then
Temp := Pi + Temp;
end if;
215 return Temp;
end Arccos;
-- Arbitrary cycle
220 function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base is
Temp : Float_Type'Base;
begin
if Cycle <= 0.0 then
225 raise Argument_Error;
elsif abs X > 1.0 then
raise Argument_Error;
230 elsif abs X < Sqrt_Epsilon then
return Cycle / 4.0;
elsif X = 1.0 then
return 0.0;
235
elsif X = -1.0 then
return Cycle / 2.0;
end if;
240 Temp := Arctan (Sqrt ((1.0 - X) * (1.0 + X)) / X, 1.0, Cycle);
if Temp < 0.0 then
Temp := Cycle / 2.0 + Temp;
end if;
245
return Temp;
end Arccos;
-------------
250 -- Arccosh --
-------------
function Arccosh (X : Float_Type'Base) return Float_Type'Base is
begin
255 -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or
-- the proper approximation for X close to 1 or >> 1.
if X < 1.0 then
raise Argument_Error;
260
elsif X < 1.0 + Sqrt_Epsilon then
return Sqrt (2.0 * (X - 1.0));
elsif X > 1.0 / Sqrt_Epsilon then
265 return Log (X) + Log_Two;
else
return Log (X + Sqrt ((X - 1.0) * (X + 1.0)));
end if;
270 end Arccosh;
------------
-- Arccot --
------------
275
-- Natural cycle
function Arccot
(X : Float_Type'Base;
280 Y : Float_Type'Base := 1.0)
return Float_Type'Base
is
begin
-- Just reverse arguments
285
return Arctan (Y, X);
end Arccot;
-- Arbitrary cycle
290
function Arccot
(X : Float_Type'Base;
Y : Float_Type'Base := 1.0;
Cycle : Float_Type'Base)
295 return Float_Type'Base
is
begin
-- Just reverse arguments
300 return Arctan (Y, X, Cycle);
end Arccot;
-------------
-- Arccoth --
305 -------------
function Arccoth (X : Float_Type'Base) return Float_Type'Base is
begin
if abs X > 2.0 then
310 return Arctanh (1.0 / X);
elsif abs X = 1.0 then
raise Constraint_Error;
315 elsif abs X < 1.0 then
raise Argument_Error;
else
-- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the
320 -- other has error 0 or Epsilon.
return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0)));
end if;
end Arccoth;
325
------------
-- Arcsin --
------------
330 -- Natural cycle
function Arcsin (X : Float_Type'Base) return Float_Type'Base is
begin
if abs X > 1.0 then
335 raise Argument_Error;
elsif abs X < Sqrt_Epsilon then
return X;
340 elsif X = 1.0 then
return Pi / 2.0;
elsif X = -1.0 then
return -Pi / 2.0;
345 end if;
return Float_Type'Base (Aux.Asin (Double (X)));
end Arcsin;
350 -- Arbitrary cycle
function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base is
begin
if Cycle <= 0.0 then
355 raise Argument_Error;
elsif abs X > 1.0 then
raise Argument_Error;
360 elsif X = 0.0 then
return X;
elsif X = 1.0 then
return Cycle / 4.0;
365
elsif X = -1.0 then
return -Cycle / 4.0;
end if;
370 return Arctan (X / Sqrt ((1.0 - X) * (1.0 + X)), 1.0, Cycle);
end Arcsin;
-------------
-- Arcsinh --
375 -------------
function Arcsinh (X : Float_Type'Base) return Float_Type'Base is
begin
if abs X < Sqrt_Epsilon then
380 return X;
elsif X > 1.0 / Sqrt_Epsilon then
return Log (X) + Log_Two;
385 elsif X < -1.0 / Sqrt_Epsilon then
return -(Log (-X) + Log_Two);
elsif X < 0.0 then
return -Log (abs X + Sqrt (X * X + 1.0));
390
else
return Log (X + Sqrt (X * X + 1.0));
end if;
end Arcsinh;
395
------------
-- Arctan --
------------
400 -- Natural cycle
function Arctan
(Y : Float_Type'Base;
X : Float_Type'Base := 1.0)
405 return Float_Type'Base
is
begin
if X = 0.0
and then Y = 0.0
410 then
raise Argument_Error;
elsif Y = 0.0 then
if X > 0.0 then
415 return 0.0;
else -- X < 0.0
return Pi * Float_Type'Copy_Sign (1.0, Y);
end if;
420 elsif X = 0.0 then
if Y > 0.0 then
return Half_Pi;
else -- Y < 0.0
return -Half_Pi;
425 end if;
else
return Local_Atan (Y, X);
end if;
430 end Arctan;
-- Arbitrary cycle
function Arctan
435 (Y : Float_Type'Base;
X : Float_Type'Base := 1.0;
Cycle : Float_Type'Base)
return Float_Type'Base
is
440 begin
if Cycle <= 0.0 then
raise Argument_Error;
elsif X = 0.0
445 and then Y = 0.0
then
raise Argument_Error;
elsif Y = 0.0 then
450 if X > 0.0 then
return 0.0;
else -- X < 0.0
return Cycle / 2.0 * Float_Type'Copy_Sign (1.0, Y);
end if;
455
elsif X = 0.0 then
if Y > 0.0 then
return Cycle / 4.0;
else -- Y < 0.0
460 return -Cycle / 4.0;
end if;
else
return Local_Atan (Y, X) * Cycle / Two_Pi;
465 end if;
end Arctan;
-------------
-- Arctanh --
470 -------------
function Arctanh (X : Float_Type'Base) return Float_Type'Base is
A, B, D, A_Plus_1, A_From_1 : Float_Type'Base;
Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa;
475
begin
-- The naive formula:
-- Arctanh (X) := (1/2) * Log (1 + X) / (1 - X)
480
-- is not well-behaved numerically when X < 0.5 and when X is close
-- to one. The following is accurate but probably not optimal.
if abs X = 1.0 then
485 raise Constraint_Error;
elsif abs X >= 1.0 - 2.0 ** (-Mantissa) then
if abs X >= 1.0 then
490 raise Argument_Error;
else
-- The one case that overflows if put through the method below:
-- abs X = 1.0 - Epsilon. In this case (1/2) log (2/Epsilon) is
495 -- accurate. This simplifies to:
return Float_Type'Copy_Sign (
Half_Log_Two * Float_Type'Base (Mantissa + 1), X);
end if;
500
-- elsif abs X <= 0.5 then
-- why is above line commented out ???
else
505 -- Use several piecewise linear approximations.
-- A is close to X, chosen so 1.0 + A, 1.0 - A, and X - A are exact.
-- The two scalings remove the low-order bits of X.
A := Float_Type'Base'Scaling (
510 Float_Type'Base (Long_Long_Integer
(Float_Type'Base'Scaling (X, Mantissa - 1))), 1 - Mantissa);
B := X - A; -- This is exact; abs B <= 2**(-Mantissa).
A_Plus_1 := 1.0 + A; -- This is exact.
515 A_From_1 := 1.0 - A; -- Ditto.
D := A_Plus_1 * A_From_1; -- 1 - A*A.
-- use one term of the series expansion:
-- f (x + e) = f(x) + e * f'(x) + ..
520
-- The derivative of Arctanh at A is 1/(1-A*A). Next term is
-- A*(B/D)**2 (if a quadratic approximation is ever needed).
return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D;
525
-- else
-- return 0.5 * Log ((X + 1.0) / (1.0 - X));
-- why are above lines commented out ???
end if;
530 end Arctanh;
---------
-- Cos --
---------
535
-- Natural cycle
function Cos (X : Float_Type'Base) return Float_Type'Base is
begin
540 if X = 0.0 then
return 1.0;
elsif abs X < Sqrt_Epsilon then
return 1.0;
545
end if;
return Float_Type'Base (Aux.Cos (Double (X)));
end Cos;
550
-- Arbitrary cycle
function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is
begin
555 -- Just reuse the code for Sin. The potential small
-- loss of speed is negligible with proper (front-end) inlining.
return -Sin (abs X - Cycle * 0.25, Cycle);
end Cos;
560
----------
-- Cosh --
----------
565 function Cosh (X : Float_Type'Base) return Float_Type'Base is
Lnv : constant Float_Type'Base := 8#0.542714#;
V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
Y : Float_Type'Base := abs X;
Z : Float_Type'Base;
570
begin
if Y < Sqrt_Epsilon then
return 1.0;
575 elsif Y > Log_Inverse_Epsilon then
Z := Exp_Strict (Y - Lnv);
return (Z + V2minus1 * Z);
else
580 Z := Exp_Strict (Y);
return 0.5 * (Z + 1.0 / Z);
end if;
end Cosh;
585
---------
-- Cot --
---------
590 -- Natural cycle
function Cot (X : Float_Type'Base) return Float_Type'Base is
begin
if X = 0.0 then
595 raise Constraint_Error;
elsif abs X < Sqrt_Epsilon then
return 1.0 / X;
end if;
600
return 1.0 / Float_Type'Base (Aux.Tan (Double (X)));
end Cot;
-- Arbitrary cycle
605
function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base is
T : Float_Type'Base;
begin
610 if Cycle <= 0.0 then
raise Argument_Error;
end if;
T := Float_Type'Base'Remainder (X, Cycle);
615
if T = 0.0 or abs T = 0.5 * Cycle then
raise Constraint_Error;
elsif abs T < Sqrt_Epsilon then
620 return 1.0 / T;
elsif abs T = 0.25 * Cycle then
return 0.0;
625 else
T := T / Cycle * Two_Pi;
return Cos (T) / Sin (T);
end if;
end Cot;
630
----------
-- Coth --
----------
635 function Coth (X : Float_Type'Base) return Float_Type'Base is
begin
if X = 0.0 then
raise Constraint_Error;
640 elsif X < Half_Log_Epsilon then
return -1.0;
elsif X > -Half_Log_Epsilon then
return 1.0;
645
elsif abs X < Sqrt_Epsilon then
return 1.0 / X;
end if;
650 return 1.0 / Float_Type'Base (Aux.Tanh (Double (X)));
end Coth;
---------
-- Exp --
655 ---------
function Exp (X : Float_Type'Base) return Float_Type'Base is
Result : Float_Type'Base;
660 begin
if X = 0.0 then
return 1.0;
end if;
665 Result := Float_Type'Base (Aux.Exp (Double (X)));
-- Deal with case of Exp returning IEEE infinity. If Machine_Overflows
-- is False, then we can just leave it as an infinity (and indeed we
-- prefer to do so). But if Machine_Overflows is True, then we have
670 -- to raise a Constraint_Error exception as required by the RM.
if Float_Type'Machine_Overflows and then not Result'Valid then
raise Constraint_Error;
end if;
675
return Result;
end Exp;
----------------
680 -- Exp_Strict --
----------------
function Exp_Strict (X : Float_Type'Base) return Float_Type'Base is
G : Float_Type'Base;
685 Z : Float_Type'Base;
P0 : constant := 0.25000_00000_00000_00000;
P1 : constant := 0.75753_18015_94227_76666E-2;
P2 : constant := 0.31555_19276_56846_46356E-4;
690
Q0 : constant := 0.5;
Q1 : constant := 0.56817_30269_85512_21787E-1;
Q2 : constant := 0.63121_89437_43985_02557E-3;
Q3 : constant := 0.75104_02839_98700_46114E-6;
695
C1 : constant := 8#0.543#;
C2 : constant := -2.1219_44400_54690_58277E-4;
Le : constant := 1.4426_95040_88896_34074;
700 XN : Float_Type'Base;
P, Q, R : Float_Type'Base;
begin
if X = 0.0 then
705 return 1.0;
end if;
XN := Float_Type'Base'Rounding (X * Le);
G := (X - XN * C1) - XN * C2;
710 Z := G * G;
P := G * ((P2 * Z + P1) * Z + P0);
Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0;
R := 0.5 + P / (Q - P);
715 R := Float_Type'Base'Scaling (R, Integer (XN) + 1);
-- Deal with case of Exp returning IEEE infinity. If Machine_Overflows
-- is False, then we can just leave it as an infinity (and indeed we
-- prefer to do so). But if Machine_Overflows is True, then we have
720 -- to raise a Constraint_Error exception as required by the RM.
if Float_Type'Machine_Overflows and then not R'Valid then
raise Constraint_Error;
else
725 return R;
end if;
end Exp_Strict;
730 ----------------
-- Local_Atan --
----------------
function Local_Atan
735 (Y : Float_Type'Base;
X : Float_Type'Base := 1.0)
return Float_Type'Base
is
Z : Float_Type'Base;
740 Raw_Atan : Float_Type'Base;
begin
if abs Y > abs X then
Z := abs (X / Y);
745 else
Z := abs (Y / X);
end if;
if Z < Sqrt_Epsilon then
750 Raw_Atan := Z;
elsif Z = 1.0 then
Raw_Atan := Pi / 4.0;
755 else
Raw_Atan := Float_Type'Base (Aux.Atan (Double (Z)));
end if;
if abs Y > abs X then
760 Raw_Atan := Half_Pi - Raw_Atan;
end if;
if X > 0.0 then
if Y > 0.0 then
765 return Raw_Atan;
else -- Y < 0.0
return -Raw_Atan;
end if;
770 else -- X < 0.0
if Y > 0.0 then
return Pi - Raw_Atan;
else -- Y < 0.0
return -(Pi - Raw_Atan);
775 end if;
end if;
end Local_Atan;
---------
780 -- Log --
---------
-- Natural base
785 function Log (X : Float_Type'Base) return Float_Type'Base is
begin
if X < 0.0 then
raise Argument_Error;
790 elsif X = 0.0 then
raise Constraint_Error;
elsif X = 1.0 then
return 0.0;
795 end if;
return Float_Type'Base (Aux.Log (Double (X)));
end Log;
800 -- Arbitrary base
function Log (X, Base : Float_Type'Base) return Float_Type'Base is
begin
if X < 0.0 then
805 raise Argument_Error;
elsif Base <= 0.0 or else Base = 1.0 then
raise Argument_Error;
810 elsif X = 0.0 then
raise Constraint_Error;
elsif X = 1.0 then
return 0.0;
815 end if;
return Float_Type'Base (Aux.Log (Double (X)) / Aux.Log (Double (Base)));
end Log;
820 ---------
-- Sin --
---------
-- Natural cycle
825
function Sin (X : Float_Type'Base) return Float_Type'Base is
begin
if abs X < Sqrt_Epsilon then
return X;
830 end if;
return Float_Type'Base (Aux.Sin (Double (X)));
end Sin;
835 -- Arbitrary cycle
function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base is
T : Float_Type'Base;
840 begin
if Cycle <= 0.0 then
raise Argument_Error;
elsif X = 0.0 then
845 -- Is this test really needed on any machine ???
return X;
end if;
T := Float_Type'Base'Remainder (X, Cycle);
850
-- The following two reductions reduce the argument
-- to the interval [-0.25 * Cycle, 0.25 * Cycle].
-- This reduction is exact and is needed to prevent
-- inaccuracy that may result if the sinus function
855 -- a different (more accurate) value of Pi in its
-- reduction than is used in the multiplication with Two_Pi.
if abs T > 0.25 * Cycle then
T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T;
860 end if;
-- Could test for 12.0 * abs T = Cycle, and return
-- an exact value in those cases. It is not clear that
-- this is worth the extra test though.
865
return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi)));
end Sin;
----------
870 -- Sinh --
----------
function Sinh (X : Float_Type'Base) return Float_Type'Base is
Lnv : constant Float_Type'Base := 8#0.542714#;
875 V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
Y : Float_Type'Base := abs X;
F : constant Float_Type'Base := Y * Y;
Z : Float_Type'Base;
880 Float_Digits_1_6 : constant Boolean := Float_Type'Digits < 7;
begin
if Y < Sqrt_Epsilon then
return X;
885
elsif Y > Log_Inverse_Epsilon then
Z := Exp_Strict (Y - Lnv);
Z := Z + V2minus1 * Z;
890 elsif Y < 1.0 then
if Float_Digits_1_6 then
-- Use expansion provided by Cody and Waite, p. 226. Note that
895 -- leading term of the polynomial in Q is exactly 1.0.
declare
P0 : constant := -0.71379_3159E+1;
P1 : constant := -0.19033_3399E+0;
900 Q0 : constant := -0.42827_7109E+2;
begin
Z := Y + Y * F * (P1 * F + P0) / (F + Q0);
end;
905
else
declare
P0 : constant := -0.35181_28343_01771_17881E+6;
P1 : constant := -0.11563_52119_68517_68270E+5;
910 P2 : constant := -0.16375_79820_26307_51372E+3;
P3 : constant := -0.78966_12741_73570_99479E+0;
Q0 : constant := -0.21108_77005_81062_71242E+7;
Q1 : constant := 0.36162_72310_94218_36460E+5;
Q2 : constant := -0.27773_52311_96507_01667E+3;
915
begin
Z := Y + Y * F * (((P3 * F + P2) * F + P1) * F + P0)
/ (((F + Q2) * F + Q1) * F + Q0);
end;
920 end if;
else
Z := Exp_Strict (Y);
Z := 0.5 * (Z - 1.0 / Z);
925 end if;
if X > 0.0 then
return Z;
else
930 return -Z;
end if;
end Sinh;
----------
935 -- Sqrt --
----------
function Sqrt (X : Float_Type'Base) return Float_Type'Base is
begin
940 if X < 0.0 then
raise Argument_Error;
-- Special case Sqrt (0.0) to preserve possible minus sign per IEEE
945 elsif X = 0.0 then
return X;
end if;
950 return Float_Type'Base (Aux.Sqrt (Double (X)));
end Sqrt;
---------
-- Tan --
955 ---------
-- Natural cycle
function Tan (X : Float_Type'Base) return Float_Type'Base is
960 begin
if abs X < Sqrt_Epsilon then
return X;
elsif abs X = Pi / 2.0 then
965 raise Constraint_Error;
end if;
return Float_Type'Base (Aux.Tan (Double (X)));
end Tan;
970
-- Arbitrary cycle
function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is
T : Float_Type'Base;
975
begin
if Cycle <= 0.0 then
raise Argument_Error;
980 elsif X = 0.0 then
return X;
end if;
T := Float_Type'Base'Remainder (X, Cycle);
985
if abs T = 0.25 * Cycle then
raise Constraint_Error;
elsif abs T = 0.5 * Cycle then
990 return 0.0;
else
T := T / Cycle * Two_Pi;
return Sin (T) / Cos (T);
995 end if;
end Tan;
----------
1000 -- Tanh --
----------
function Tanh (X : Float_Type'Base) return Float_Type'Base is
P0 : constant Float_Type'Base := -0.16134_11902E4;
1005 P1 : constant Float_Type'Base := -0.99225_92967E2;
P2 : constant Float_Type'Base := -0.96437_49299E0;
Q0 : constant Float_Type'Base := 0.48402_35707E4;
Q1 : constant Float_Type'Base := 0.22337_72071E4;
1010 Q2 : constant Float_Type'Base := 0.11274_47438E3;
Q3 : constant Float_Type'Base := 0.10000000000E1;
Half_Ln3 : constant Float_Type'Base := 0.54930_61443;
1015 P, Q, R : Float_Type'Base;
Y : Float_Type'Base := abs X;
G : Float_Type'Base := Y * Y;
Float_Type_Digits_15_Or_More : constant Boolean :=
1020 Float_Type'Digits > 14;
begin
if X < Half_Log_Epsilon then
return -1.0;
1025
elsif X > -Half_Log_Epsilon then
return 1.0;
elsif Y < Sqrt_Epsilon then
1030 return X;
elsif Y < Half_Ln3
and then Float_Type_Digits_15_Or_More
then
1035 P := (P2 * G + P1) * G + P0;
Q := ((Q3 * G + Q2) * G + Q1) * G + Q0;
R := G * (P / Q);
return X + X * R;
1040 else
return Float_Type'Base (Aux.Tanh (Double (X)));
end if;
end Tanh;
1045 end Ada.Numerics.Generic_Elementary_Functions;