Vovanium
/
VSSL
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

% Quad_Reals bug fix and tests

This commit is contained in:
Vovanium 2023-12-26 05:14:31 +03:00
parent 29b5feb3f3
commit dad7a34697
2 changed files with 110 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
source/library/vssl-floating_point-generic_quad_reals.adb
View File

@ -205,6 +205,7 @@ package body VSSL.Floating_Point.Generic_Quad_Reals is
Two_Prod (T (0), U, A (0), B);
Two_Prod (T (1), V, A (1), B);
Two_Prod (T (2), W, A (2), B);
T (3) := A (3) * B;
Two_Sum (T (1), U, T (1), U);
Three_Sum (T (2), V, U, T (2), V, U);
Three_Sum (T (3), V, T (3), W, V);

109
source/test/vssl-floating_point-generic_quad_reals-test.adb
View File

@ -42,16 +42,125 @@ package body VSSL.Floating_Point.Generic_Quad_Reals.Test is
procedure Run_Test (T : in out Plus_I_Test) is
begin
T.Assert_Identity (To_Quad_Real (0.0));
T.Assert_Identity (To_Quad_Real (1.0));
T.Assert_Identity (Value ("12346.95959869395354354385354365"));
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
R : Access_Test_Suite := new Test_Suite;
begin
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;
end Suite;