% Quad_Reals bug fix and tests
This commit is contained in:
parent
29b5feb3f3
commit
dad7a34697
|
@ -205,6 +205,7 @@ package body VSSL.Floating_Point.Generic_Quad_Reals is
|
||||||
Two_Prod (T (0), U, A (0), B);
|
Two_Prod (T (0), U, A (0), B);
|
||||||
Two_Prod (T (1), V, A (1), B);
|
Two_Prod (T (1), V, A (1), B);
|
||||||
Two_Prod (T (2), W, A (2), B);
|
Two_Prod (T (2), W, A (2), B);
|
||||||
|
T (3) := A (3) * B;
|
||||||
Two_Sum (T (1), U, T (1), U);
|
Two_Sum (T (1), U, T (1), U);
|
||||||
Three_Sum (T (2), V, U, T (2), V, U);
|
Three_Sum (T (2), V, U, T (2), V, U);
|
||||||
Three_Sum (T (3), V, T (3), W, V);
|
Three_Sum (T (3), V, T (3), W, V);
|
||||||
|
|
|
@ -42,16 +42,125 @@ package body VSSL.Floating_Point.Generic_Quad_Reals.Test is
|
||||||
|
|
||||||
procedure Run_Test (T : in out Plus_I_Test) is
|
procedure Run_Test (T : in out Plus_I_Test) is
|
||||||
begin
|
begin
|
||||||
|
T.Assert_Identity (To_Quad_Real (0.0));
|
||||||
T.Assert_Identity (To_Quad_Real (1.0));
|
T.Assert_Identity (To_Quad_Real (1.0));
|
||||||
T.Assert_Identity (Value ("12346.95959869395354354385354365"));
|
T.Assert_Identity (Value ("12346.95959869395354354385354365"));
|
||||||
end Run_Test;
|
end Run_Test;
|
||||||
|
|
||||||
--
|
--
|
||||||
|
|
||||||
|
package Minus_I_Case is new Self_Inverse_Unary_Function_Case (
|
||||||
|
Quad_Real_Traits,
|
||||||
|
"-",
|
||||||
|
"""-""",
|
||||||
|
Prefix);
|
||||||
|
|
||||||
|
type Minus_I_Test is new Minus_I_Case.Test with null record;
|
||||||
|
overriding procedure Run_Test (T : in out Minus_I_Test);
|
||||||
|
|
||||||
|
procedure Run_Test (T : in out Minus_I_Test) is
|
||||||
|
begin
|
||||||
|
T.Assert_Identity (To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (1.0), To_Quad_Real (-1.0));
|
||||||
|
T.Assert (To_Quad_Real (1.776E-19), To_Quad_Real (-1.776E-19));
|
||||||
|
T.Assert (Value ("1.987654321987654321987654321"), Value ("-1.987654321987654321987654321"));
|
||||||
|
end Run_Test;
|
||||||
|
|
||||||
|
--
|
||||||
|
|
||||||
|
package Plus_II_Case is new Commutative_Binary_Function_Case (
|
||||||
|
Quad_Real_Traits,
|
||||||
|
Quad_Real_Traits,
|
||||||
|
"+",
|
||||||
|
"""+""",
|
||||||
|
Prefix);
|
||||||
|
type Plus_II_Test is new Plus_II_Case.Test with null record;
|
||||||
|
overriding procedure Run_Test (T : in out Plus_II_Test);
|
||||||
|
|
||||||
|
procedure Run_Test (T : in out Plus_II_Test) is
|
||||||
|
begin
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (0.0), To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (1.0), To_Quad_Real (1.0));
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (-1.0), To_Quad_Real (-1.0));
|
||||||
|
T.Assert (To_Quad_Real (1.0), To_Quad_Real (-1.0), To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (16#1.0#E12), To_Quad_Real (1.0),
|
||||||
|
Value ("16#1_0000_0000_0001#"));
|
||||||
|
T.Assert (Value ("16#1_0001_0001_0001_0000_0000_0000"),
|
||||||
|
Value ("16#0_0000_0000_0000_0000_0000_0001"),
|
||||||
|
Value ("16#1_0001_0001_0001_0000_0000_0001"));
|
||||||
|
T.Assert (Value ("16#1_0001_0001_0001_0001_0001_0000"),
|
||||||
|
Value ("16#0_0000_0000_0000_0000_0000_0001"),
|
||||||
|
Value ("16#1_0001_0001_0001_0001_0001_0001"));
|
||||||
|
T.Assert (Value ("16#1_0001_0000_0001_0000_0001_0000"),
|
||||||
|
Value ("16#0_0000_0001_0000_0001_0000_0001"),
|
||||||
|
Value ("16#1_0001_0001_0001_0001_0001_0001"));
|
||||||
|
T.Assert (Value ("16#1_0001_0001_0001_0001_0001_0001_0000"),
|
||||||
|
Value ("16#0_0000_0000_0000_0000_0000_0000_0001"),
|
||||||
|
Value ("16#1_0001_0001_0001_0001_0001_0001_0001"));
|
||||||
|
T.Assert (Value ("16#1_0000_0001_0000_0001_0000_0001_0000"),
|
||||||
|
Value ("16#0_0001_0000_0001_0000_0001_0000_0001"),
|
||||||
|
Value ("16#1_0001_0001_0001_0001_0001_0001_0001"));
|
||||||
|
T.Assert (Value ("16#1.0000_0001_0000_0001_0000_0001_0000"),
|
||||||
|
Value ("16#0.0001_0000_0001_0000_0001_0000_0001"),
|
||||||
|
Value ("16#1.0001_0001_0001_0001_0001_0001_0001"));
|
||||||
|
T.Assert (Value ("1_001_001_001_001_001_001_001_001_001_001"),
|
||||||
|
Value ("2_002_002_002_002_002_002_002_002_002_002"),
|
||||||
|
Value ("3_003_003_003_003_003_003_003_003_003_003"));
|
||||||
|
T.Assert (Value ("1.001_001_001_001_001_001_001_001_001_001"),
|
||||||
|
Value ("2.002_002_002_002_002_002_002_002_002_002"),
|
||||||
|
Value ("3.003_003_003_003_003_003_003_003_003_003"));
|
||||||
|
end Run_Test;
|
||||||
|
|
||||||
|
--
|
||||||
|
|
||||||
|
package Multiply_II_Case is new Commutative_Binary_Function_Case (
|
||||||
|
Quad_Real_Traits,
|
||||||
|
Quad_Real_Traits,
|
||||||
|
"*",
|
||||||
|
"""*""",
|
||||||
|
Prefix);
|
||||||
|
type Multiply_II_Test is new Multiply_II_Case.Test with null record;
|
||||||
|
overriding procedure Run_Test (T : in out Multiply_II_Test);
|
||||||
|
|
||||||
|
procedure Run_Test (T : in out Multiply_II_Test) is
|
||||||
|
begin
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (0.0), To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (1.0), To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (1.0), To_Quad_Real (1.0), To_Quad_Real (1.0));
|
||||||
|
T.Assert (To_Quad_Real (1.0), To_Quad_Real (-1.0), To_Quad_Real (-1.0));
|
||||||
|
--T.Assert (Value ("1.001_001_001_001_001"),
|
||||||
|
-- Value ("1.001_001_001_001_001"),
|
||||||
|
-- Value ("1.002_003_004_005_006_005_004_003_002_001"));
|
||||||
|
end Run_Test;
|
||||||
|
|
||||||
|
--
|
||||||
|
|
||||||
|
package Divide_II_Case is new Binary_Function_Case (
|
||||||
|
Quad_Real_Traits,
|
||||||
|
Quad_Real_Traits,
|
||||||
|
Quad_Real_Traits,
|
||||||
|
"/",
|
||||||
|
"""/""",
|
||||||
|
Prefix);
|
||||||
|
type Divide_II_Test is new Divide_II_Case.Test with null record;
|
||||||
|
overriding procedure Run_Test (T : in out Divide_II_Test);
|
||||||
|
|
||||||
|
procedure Run_Test (T : in out Divide_II_Test) is
|
||||||
|
begin
|
||||||
|
T.Assert (To_Quad_Real (0.0), To_Quad_Real (1.0), To_Quad_Real (0.0));
|
||||||
|
T.Assert (To_Quad_Real (1.0), To_Quad_Real (1.0), To_Quad_Real (1.0));
|
||||||
|
end Run_Test;
|
||||||
|
|
||||||
|
--
|
||||||
|
|
||||||
function Suite return Access_Test_Suite is
|
function Suite return Access_Test_Suite is
|
||||||
R : Access_Test_Suite := new Test_Suite;
|
R : Access_Test_Suite := new Test_Suite;
|
||||||
begin
|
begin
|
||||||
R.Add_Test (new Plus_I_Test);
|
R.Add_Test (new Plus_I_Test);
|
||||||
|
R.Add_Test (new Minus_I_Test);
|
||||||
|
R.Add_Test (new Plus_II_Test);
|
||||||
|
R.Add_Test (new Multiply_II_Test);
|
||||||
|
R.Add_Test (new Divide_II_Test);
|
||||||
return R;
|
return R;
|
||||||
end Suite;
|
end Suite;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue