* factored out naked big number arithmetic code
This commit is contained in:
parent
7fd311cc3f
commit
0df23e1112
|
@ -0,0 +1,17 @@
|
|||
package body VSSL.Extensible_Arithmetic is
|
||||
|
||||
procedure Multiply (
|
||||
CO,
|
||||
M : out Limb;
|
||||
A,
|
||||
B : in Limb;
|
||||
CI : in Limb := 0)
|
||||
is
|
||||
P : Product;
|
||||
begin
|
||||
P := Product (A) * Product (B) + Product (CI);
|
||||
M := Limb (P and (2**Limb_Size - 1));
|
||||
CO := Limb (Shift_Right (P, Limb_Size));
|
||||
end Multiply;
|
||||
|
||||
end VSSL.Extensible_Arithmetic;
|
|
@ -0,0 +1,30 @@
|
|||
--
|
||||
-- Basic arbitrary precision arithmeric building blocks.
|
||||
-- 32 bit (with use of 64 bit intemediate type) portable implementation
|
||||
--
|
||||
|
||||
with Interfaces;
|
||||
use Interfaces;
|
||||
|
||||
package VSSL.Extensible_Arithmetic with Pure is
|
||||
|
||||
Limb_Size : constant := 32;
|
||||
|
||||
subtype Limb is Unsigned_32;
|
||||
|
||||
Minus_One_Limb : constant Limb := Limb'Last;
|
||||
|
||||
function Is_Negative (X : Limb) return Boolean is
|
||||
((X and 2**(Limb_Size - 1)) /= 0);
|
||||
|
||||
procedure Multiply (
|
||||
CO, -- Product carry out (higher part)
|
||||
M : out Limb; -- Product (lower part)
|
||||
A,
|
||||
B : in Limb; -- Multiplicands
|
||||
CI : in Limb := 0); -- Carry In (added to product)
|
||||
|
||||
private
|
||||
subtype Product is Unsigned_32;
|
||||
|
||||
end VSSL.Extensible_Arithmetic;
|
|
@ -1,20 +1,10 @@
|
|||
package body VSSL.Integers.Big is
|
||||
|
||||
subtype Chunk_Product is Unsigned_64;
|
||||
|
||||
procedure Chunk_Mul_Add (H, L : out Chunk_Type; A, B, C : in Chunk_Type) is
|
||||
P : Chunk_Product;
|
||||
begin
|
||||
P := Chunk_Product (A) * Chunk_Product (B) + Chunk_Product (C);
|
||||
L := Chunk_Type (P and (2**Chunk_Bits - 1));
|
||||
H := Chunk_Type (Shift_Right (P, Chunk_Bits));
|
||||
end Chunk_Mul_Add;
|
||||
|
||||
function Digits_to_Bits (N : Natural) return Natural is (N * 3 + (N + 2) / 3);
|
||||
-- ceiling (N * log_2 (10)) approximation giving ~ 1% error
|
||||
|
||||
function With_Bits (N : Positive) return Big_Integer is
|
||||
(0 .. N / Chunk_Bits + 1 => 0);
|
||||
(0 .. N / Limb_Size + 1 => 0);
|
||||
|
||||
function With_Digits (N : Positive) return Big_Integer is
|
||||
(With_Bits (Digits_to_Bits (N)));
|
||||
|
@ -23,7 +13,7 @@ package body VSSL.Integers.Big is
|
|||
Is_Neg : Boolean := False;
|
||||
DN : Natural := 0;
|
||||
Based : Boolean := False;
|
||||
Radix : Chunk_Type := 10;
|
||||
Radix : Limb := 10;
|
||||
begin
|
||||
-- First pass: detecting negative, radix and number of digits
|
||||
for J in S'Range loop
|
||||
|
@ -42,11 +32,11 @@ package body VSSL.Integers.Big is
|
|||
end loop;
|
||||
return R : Big_Integer := With_Digits (DN) do
|
||||
declare
|
||||
procedure Next_Digit (X : in Chunk_Type) is
|
||||
C : Chunk_Type := X;
|
||||
procedure Next_Digit (X : in Limb) is
|
||||
C : Limb := X;
|
||||
begin
|
||||
for J in R'Range loop
|
||||
Chunk_Mul_Add (C, R (J), R (J), Radix, C);
|
||||
Multiply (C, R (J), R (J), Radix, C);
|
||||
end loop;
|
||||
end Next_Digit;
|
||||
begin
|
||||
|
@ -74,34 +64,34 @@ package body VSSL.Integers.Big is
|
|||
function To_Big (X : Value) return Big_Integer is
|
||||
T : Value := X;
|
||||
begin
|
||||
if Chunk_Type'Modulus < Value'Last then -- wish it be compile-time check
|
||||
if Limb'Modulus < Value'Last then -- wish it be compile-time check
|
||||
return R : Big_Integer := With_Bits (Value'Size) do
|
||||
for J in R'Range loop
|
||||
R (J) := Chunk_Type (T mod Chunk_Type'Modulus);
|
||||
T := (T - Value (R (J))) / Chunk_Type'Modulus;
|
||||
R (J) := Limb (T mod Limb'Modulus);
|
||||
T := (T - Value (R (J))) / Limb'Modulus;
|
||||
end loop;
|
||||
end return;
|
||||
else
|
||||
return (0 => Chunk_Type (X));
|
||||
return (0 => Limb (X));
|
||||
end if;
|
||||
end To_Big;
|
||||
end Signed_Conversions;
|
||||
|
||||
function Fit_First (X : Big_Integer) return Chunk_Index'Base is
|
||||
function Fit_First (X : Big_Integer) return Limb_Index'Base is
|
||||
begin
|
||||
for J in X'Range loop
|
||||
if X (J) /= 0 then
|
||||
return J;
|
||||
end if;
|
||||
end loop;
|
||||
return Chunk_Index'Base'Last;
|
||||
return Limb_Index'Base'Last;
|
||||
end Fit_First;
|
||||
|
||||
function Fit_Last (X : Big_Integer) return Chunk_Index'Base is
|
||||
function Fit_Last (X : Big_Integer) return Limb_Index'Base is
|
||||
begin
|
||||
if Is_Negative (X) then
|
||||
for J in reverse X'Range loop
|
||||
if X (J) /= Minus_One_Chunk then
|
||||
if X (J) /= Minus_One_Limb then
|
||||
if (X (J) and 2**Sign_Bit) /= 0 then -- negative, can be used as last
|
||||
return J;
|
||||
else
|
||||
|
@ -116,11 +106,11 @@ package body VSSL.Integers.Big is
|
|||
return J;
|
||||
end if;
|
||||
end loop;
|
||||
return Chunk_Index'Base'First;
|
||||
return Limb_Index'Base'First;
|
||||
end if;
|
||||
end Fit_Last;
|
||||
|
||||
function Is_Fit (X : Big_Integer; First, Last : Chunk_Index'Base) return Boolean is
|
||||
function Is_Fit (X : Big_Integer; First, Last : Limb_Index'Base) return Boolean is
|
||||
(Fit_First (X) >= First and then Fit_Last (X) <= Last);
|
||||
|
||||
function Is_Fit (X, Y : Big_Integer) return Boolean is
|
||||
|
@ -130,21 +120,21 @@ package body VSSL.Integers.Big is
|
|||
(for all J of X => J = 0);
|
||||
|
||||
function Is_Negative (X : Big_Integer) return Boolean is
|
||||
(X'Last >= X'First and then (X (X'Last) and 2**Sign_Bit) /= 0);
|
||||
(X'Last >= X'First and then Is_Negative (X (X'Last)));
|
||||
|
||||
function "=" (X, Y : Big_Integer) return Boolean is
|
||||
FX : constant Chunk_Index'Base := Fit_First (X);
|
||||
LX : constant Chunk_Index'Base := Fit_Last (X);
|
||||
FY : constant Chunk_Index'Base := Fit_First (Y);
|
||||
LY : constant Chunk_Index'Base := Fit_Last (Y);
|
||||
FX : constant Limb_Index'Base := Fit_First (X);
|
||||
LX : constant Limb_Index'Base := Fit_Last (X);
|
||||
FY : constant Limb_Index'Base := Fit_First (Y);
|
||||
LY : constant Limb_Index'Base := Fit_Last (Y);
|
||||
begin
|
||||
return FX = FY and then LX = LY and then
|
||||
X (FX .. LX) = Y (FY .. LY);
|
||||
end "=";
|
||||
|
||||
procedure Set (T : out Big_Integer; Y : in Big_Integer) is
|
||||
FY : constant Chunk_Index'Base := Fit_First (Y);
|
||||
LY : constant Chunk_Index'Base := Fit_Last (Y);
|
||||
FY : constant Limb_Index'Base := Fit_First (Y);
|
||||
LY : constant Limb_Index'Base := Fit_Last (Y);
|
||||
begin
|
||||
if FY < T'First or else LY > T'Last then
|
||||
raise Constraint_Error with "Value does not fit in target";
|
||||
|
@ -152,16 +142,16 @@ package body VSSL.Integers.Big is
|
|||
if FY > LY then -- zero
|
||||
T := (others => 0);
|
||||
else
|
||||
T (T'First .. FY - 1) := (others => (if Is_Negative (Y) then Minus_One_Chunk else 0));
|
||||
T (T'First .. FY - 1) := (others => (if Is_Negative (Y) then Minus_One_Limb else 0));
|
||||
T (FY .. LY) := Y (FY .. LY);
|
||||
T (FY + 1 .. T'Last) := (others => 0);
|
||||
end if;
|
||||
end Set;
|
||||
|
||||
procedure Add (T : in out Big_Integer; X : in Big_Integer) is
|
||||
FX : constant Chunk_Index'Base := Fit_First (X);
|
||||
LX : constant Chunk_Index'Base := Fit_Last (X);
|
||||
Carry : Chunk_Type := 0;
|
||||
FX : constant Limb_Index'Base := Fit_First (X);
|
||||
LX : constant Limb_Index'Base := Fit_Last (X);
|
||||
Carry : Limb := 0;
|
||||
begin
|
||||
if FX < T'First or LX > T'Last then
|
||||
raise Constraint_Error with "Result of addition does not fit in target";
|
||||
|
@ -181,10 +171,10 @@ package body VSSL.Integers.Big is
|
|||
end Add;
|
||||
|
||||
procedure Negate (T : in out Big_Integer) is
|
||||
L : Chunk_Index'Base := Fit_Last (T);
|
||||
L : Limb_Index'Base := Fit_Last (T);
|
||||
begin
|
||||
if L in T'Range then -- not zero
|
||||
if L = T'Last and then T (L) = 2**(Chunk_Bits - 1) then -- corner case
|
||||
if L = T'Last and then T (L) = 2**(Limb_Size - 1) then -- corner case
|
||||
raise Constraint_Error with "Result of negation does not fit in target";
|
||||
end if;
|
||||
T (L) := -T (L);
|
||||
|
|
|
@ -3,6 +3,10 @@
|
|||
-- Contrary to Ada 202x Big Number implementation they don't use memory allocation
|
||||
--
|
||||
with Interfaces;
|
||||
use Interfaces;
|
||||
|
||||
with VSSL.Extensible_Arithmetic;
|
||||
use VSSL.Extensible_Arithmetic;
|
||||
|
||||
package VSSL.Integers.Big with Pure is
|
||||
|
||||
|
@ -48,27 +52,20 @@ package VSSL.Integers.Big with Pure is
|
|||
-- Inplace variant of negation
|
||||
|
||||
private
|
||||
use Interfaces;
|
||||
|
||||
Chunk_Bits : constant := 32;
|
||||
Sign_Bit : constant := Limb_Size - 1;
|
||||
|
||||
subtype Chunk_Type is Unsigned_32;
|
||||
subtype Limb_Index is Natural;
|
||||
|
||||
Sign_Bit : constant := Chunk_Bits - 1;
|
||||
type Big_Integer is array (Limb_Index range <>) of Limb;
|
||||
|
||||
Minus_One_Chunk : constant Chunk_Type := Chunk_Type'Last;
|
||||
|
||||
subtype Chunk_Index is Natural;
|
||||
|
||||
type Big_Integer is array (Chunk_Index range <>) of Chunk_Type;
|
||||
|
||||
-- This type represent integer split into `Chunk_Bits` bit wide chunks
|
||||
-- This type represent integer split into `Limb_Size` bit wide parts
|
||||
-- with last element is in two's complement form so that its msb indicates sign
|
||||
|
||||
Zero : constant Big_Integer := (1 .. 0 => <>);
|
||||
One : constant Big_Integer := (0 => 1);
|
||||
Two : constant Big_Integer := (0 => 2);
|
||||
Ten : constant Big_Integer := (0 => 10);
|
||||
Minus_One : constant Big_Integer := (0 => Minus_One_Chunk);
|
||||
Minus_One : constant Big_Integer := (0 => Minus_One_Limb);
|
||||
|
||||
end VSSL.Integers.Big;
|
||||
|
|
|
@ -1,8 +1,28 @@
|
|||
with AUnit.Assertions;
|
||||
use AUnit.Assertions;
|
||||
with AUnit.Simple_Test_Cases;
|
||||
use AUnit.Simple_Test_Cases;
|
||||
|
||||
package body VSSL.Integers.Big.Test is
|
||||
|
||||
Prefix : constant String := "VSSL.Integers.Big.";
|
||||
|
||||
type Representation_Test is new Test_Case with null record;
|
||||
overriding function Name (T : Representation_Test) return AUnit.Message_String;
|
||||
overriding procedure Run_Test (T : in out Representation_Test);
|
||||
|
||||
function Name (T : Representation_Test) return AUnit.Message_String is
|
||||
(AUnit.Format (Prefix & "<Representation> test"));
|
||||
|
||||
procedure Run_Test (T : in out Representation_Test) is
|
||||
begin
|
||||
null;
|
||||
end Run_Test;
|
||||
|
||||
function Suite return Access_Test_Suite is
|
||||
R : Access_Test_Suite := new Test_Suite;
|
||||
begin
|
||||
R.Add_Test (new Representation_Test);
|
||||
return R;
|
||||
end;
|
||||
|
||||
|
|
Loading…
Reference in New Issue