From 0df23e11120f6674cc03332f5cb9c8b32f9fef80 Mon Sep 17 00:00:00 2001 From: Vovanium Date: Thu, 13 Jul 2023 01:32:14 +0300 Subject: [PATCH] * factored out naked big number arithmetic code --- source/library/vssl-extensible_arithmetic.adb | 17 +++++ source/library/vssl-extensible_arithmetic.ads | 30 +++++++++ source/library/vssl-integers-big.adb | 66 ++++++++----------- source/library/vssl-integers-big.ads | 21 +++--- source/test/vssl-integers-big-test.adb | 20 ++++++ 5 files changed, 104 insertions(+), 50 deletions(-) create mode 100644 source/library/vssl-extensible_arithmetic.adb create mode 100644 source/library/vssl-extensible_arithmetic.ads diff --git a/source/library/vssl-extensible_arithmetic.adb b/source/library/vssl-extensible_arithmetic.adb new file mode 100644 index 0000000..b659e87 --- /dev/null +++ b/source/library/vssl-extensible_arithmetic.adb @@ -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; diff --git a/source/library/vssl-extensible_arithmetic.ads b/source/library/vssl-extensible_arithmetic.ads new file mode 100644 index 0000000..adc0036 --- /dev/null +++ b/source/library/vssl-extensible_arithmetic.ads @@ -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; diff --git a/source/library/vssl-integers-big.adb b/source/library/vssl-integers-big.adb index 484841b..73eaba8 100644 --- a/source/library/vssl-integers-big.adb +++ b/source/library/vssl-integers-big.adb @@ -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); diff --git a/source/library/vssl-integers-big.ads b/source/library/vssl-integers-big.ads index aecd5b9..59a45ec 100644 --- a/source/library/vssl-integers-big.ads +++ b/source/library/vssl-integers-big.ads @@ -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; diff --git a/source/test/vssl-integers-big-test.adb b/source/test/vssl-integers-big-test.adb index 91b3459..6f1b6bf 100644 --- a/source/test/vssl-integers-big-test.adb +++ b/source/test/vssl-integers-big-test.adb @@ -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 & " 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;