with GNAT.Exceptions; use GNAT.Exceptions;
with Interfaces; use Interfaces;
with Unchecked_Conversion;
package body System.Arith_64 is
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
subtype Uns64 is Unsigned_64;
function To_Uns is new Unchecked_Conversion (Int64, Uns64);
function To_Int is new Unchecked_Conversion (Uns64, Int64);
subtype Uns32 is Unsigned_32;
function "+" (A, B : Uns32) return Uns64;
function "+" (A : Uns64; B : Uns32) return Uns64;
pragma Inline ("+");
function "-" (A : Uns64; B : Uns32) return Uns64;
pragma Inline ("-");
function "*" (A, B : Uns32) return Uns64;
pragma Inline ("*");
function "/" (A : Uns64; B : Uns32) return Uns64;
pragma Inline ("/");
function "rem" (A : Uns64; B : Uns32) return Uns64;
pragma Inline ("rem");
function "&" (Hi, Lo : Uns32) return Uns64;
pragma Inline ("&");
function Lo (A : Uns64) return Uns32;
pragma Inline (Lo);
function Hi (A : Uns64) return Uns32;
pragma Inline (Hi);
function To_Neg_Int (A : Uns64) return Int64;
function To_Pos_Int (A : Uns64) return Int64;
procedure Raise_Error;
pragma No_Return (Raise_Error);
function "&" (Hi, Lo : Uns32) return Uns64 is
begin
return Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo);
end "&";
function "*" (A, B : Uns32) return Uns64 is
begin
return Uns64 (A) * Uns64 (B);
end "*";
function "+" (A, B : Uns32) return Uns64 is
begin
return Uns64 (A) + Uns64 (B);
end "+";
function "+" (A : Uns64; B : Uns32) return Uns64 is
begin
return A + Uns64 (B);
end "+";
function "-" (A : Uns64; B : Uns32) return Uns64 is
begin
return A - Uns64 (B);
end "-";
function "/" (A : Uns64; B : Uns32) return Uns64 is
begin
return A / Uns64 (B);
end "/";
function "rem" (A : Uns64; B : Uns32) return Uns64 is
begin
return A rem Uns64 (B);
end "rem";
function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is
R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y));
begin
if X >= 0 then
if Y < 0 or else R >= 0 then
return R;
end if;
else if Y > 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Add_With_Ovflo_Check;
procedure Double_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean)
is
Xu : constant Uns64 := To_Uns (abs X);
Yu : constant Uns64 := To_Uns (abs Y);
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
Zu : constant Uns64 := To_Uns (abs Z);
Zhi : constant Uns32 := Hi (Zu);
Zlo : constant Uns32 := Lo (Zu);
T1, T2 : Uns64;
Du, Qu, Ru : Uns64;
Den_Pos : Boolean;
begin
if Yu = 0 or else Zu = 0 then
Raise_Error;
end if;
if Yhi /= 0 then
if Zhi /= 0 then
Q := 0;
R := X;
return;
else
T2 := Yhi * Zlo;
end if;
else
if Zhi /= 0 then
T2 := Ylo * Zhi;
else
T2 := 0;
end if;
end if;
T1 := Ylo * Zlo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
Q := 0;
R := X;
return;
end if;
Du := Lo (T2) & Lo (T1);
Qu := Xu / Du;
Ru := Xu rem Du;
if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then
Qu := Qu + Uns64'(1);
end if;
Den_Pos := (Y < 0) = (Z < 0);
if X >= 0 then
R := To_Int (Ru);
if Den_Pos then
Q := To_Int (Qu);
else
Q := -To_Int (Qu);
end if;
else
R := -To_Int (Ru);
if Den_Pos then
Q := -To_Int (Qu);
else
Q := To_Int (Qu);
end if;
end if;
end Double_Divide;
function Hi (A : Uns64) return Uns32 is
begin
return Uns32 (Shift_Right (A, 32));
end Hi;
function Lo (A : Uns64) return Uns32 is
begin
return Uns32 (A and 16#FFFF_FFFF#);
end Lo;
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is
Xu : constant Uns64 := To_Uns (abs X);
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
Yu : constant Uns64 := To_Uns (abs Y);
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
T1, T2 : Uns64;
begin
if Xhi /= 0 then
if Yhi /= 0 then
Raise_Error;
else
T2 := Xhi * Ylo;
end if;
elsif Yhi /= 0 then
T2 := Xlo * Yhi;
else T2 := 0;
end if;
T1 := Xlo * Ylo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
Raise_Error;
end if;
T2 := Lo (T2) & Lo (T1);
if X >= 0 then
if Y >= 0 then
return To_Pos_Int (T2);
else
return To_Neg_Int (T2);
end if;
else if Y < 0 then
return To_Pos_Int (T2);
else
return To_Neg_Int (T2);
end if;
end if;
end Multiply_With_Ovflo_Check;
procedure Raise_Error is
begin
Raise_Exception (CE, "64-bit arithmetic overflow");
end Raise_Error;
procedure Scaled_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean)
is
Xu : constant Uns64 := To_Uns (abs X);
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
Yu : constant Uns64 := To_Uns (abs Y);
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
Zu : Uns64 := To_Uns (abs Z);
Zhi : Uns32 := Hi (Zu);
Zlo : Uns32 := Lo (Zu);
D1, D2, D3, D4 : Uns32;
Q1, Q2 : Uns32;
S1, S2, S3 : Uns32;
Qu : Uns64;
Ru : Uns64;
Scale : Natural;
T1, T2, T3 : Uns64;
begin
T1 := Xlo * Ylo;
D4 := Lo (T1);
D3 := Hi (T1);
if Yhi /= 0 then
T1 := Xlo * Yhi;
T2 := D3 + Lo (T1);
D3 := Lo (T2);
D2 := Hi (T1) + Hi (T2);
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D3 + Lo (T1);
D3 := Lo (T2);
T3 := D2 + Hi (T1);
T3 := T3 + Hi (T2);
D2 := Lo (T3);
D1 := Hi (T3);
T1 := (D1 & D2) + Uns64'(Xhi * Yhi);
D1 := Hi (T1);
D2 := Lo (T1);
else
D1 := 0;
end if;
else
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D3 + Lo (T1);
D3 := Lo (T2);
D2 := Hi (T1) + Hi (T2);
else
D2 := 0;
end if;
D1 := 0;
end if;
if Zhi = 0 then
if D1 /= 0 or else D2 >= Zlo then
Raise_Error;
else
T1 := D2 & D3;
T2 := Lo (T1 rem Zlo) & D4;
Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo);
Ru := T2 rem Zlo;
end if;
elsif (D1 & D2) >= Zu then
Raise_Error;
else
Scale := 0;
if (Zhi and 16#FFFF0000#) = 0 then
Scale := 16;
Zu := Shift_Left (Zu, 16);
end if;
if (Hi (Zu) and 16#FF00_0000#) = 0 then
Scale := Scale + 8;
Zu := Shift_Left (Zu, 8);
end if;
if (Hi (Zu) and 16#F000_0000#) = 0 then
Scale := Scale + 4;
Zu := Shift_Left (Zu, 4);
end if;
if (Hi (Zu) and 16#C000_0000#) = 0 then
Scale := Scale + 2;
Zu := Shift_Left (Zu, 2);
end if;
if (Hi (Zu) and 16#8000_0000#) = 0 then
Scale := Scale + 1;
Zu := Shift_Left (Zu, 1);
end if;
Zhi := Hi (Zu);
Zlo := Lo (Zu);
T1 := Shift_Left (D1 & D2, Scale);
D1 := Hi (T1);
T2 := Shift_Left (0 & D3, Scale);
D2 := Lo (T1) or Hi (T2);
T3 := Shift_Left (0 & D4, Scale);
D3 := Lo (T2) or Hi (T3);
D4 := Lo (T3);
if D1 = Zhi then
Q1 := 2 ** 32 - 1;
else
Q1 := Lo ((D1 & D2) / Zhi);
end if;
T1 := Q1 * Zlo;
T2 := Q1 * Zhi;
S3 := Lo (T1);
T1 := Hi (T1) + Lo (T2);
S2 := Lo (T1);
S1 := Hi (T1) + Hi (T2);
loop
exit when S1 < D1;
if S1 = D1 then
exit when S2 < D2;
if S2 = D2 then
exit when S3 <= D3;
end if;
end if;
Q1 := Q1 - 1;
T1 := (S2 & S3) - Zlo;
S3 := Lo (T1);
T1 := (S1 & S2) - Zhi;
S2 := Lo (T1);
S1 := Hi (T1);
end loop;
T1 := (D2 & D3) - S3;
D3 := Lo (T1);
T1 := (D1 & Hi (T1)) - S2;
D2 := Lo (T1);
if D2 = Zhi then
Q2 := 2 ** 32 - 1;
else
Q2 := Lo ((D2 & D3) / Zhi);
end if;
T1 := Q2 * Zlo;
T2 := Q2 * Zhi;
S3 := Lo (T1);
T1 := Hi (T1) + Lo (T2);
S2 := Lo (T1);
S1 := Hi (T1) + Hi (T2);
loop
exit when S1 < D2;
if S1 = D2 then
exit when S2 < D3;
if S2 = D3 then
exit when S3 <= D4;
end if;
end if;
Q2 := Q2 - 1;
T1 := (S2 & S3) - Zlo;
S3 := Lo (T1);
T1 := (S1 & S2) - Zhi;
S2 := Lo (T1);
S1 := Hi (T1);
end loop;
T1 := (D3 & D4) - S3;
D4 := Lo (T1);
T1 := (D2 & Hi (T1)) - S2;
D3 := Lo (T1);
Qu := Q1 & Q2;
Ru := Shift_Right (D3 & D4, Scale);
Zu := Shift_Right (Zu, Scale);
end if;
if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then
Qu := Qu + Uns64 (1);
end if;
if (X >= 0 and then Y >= 0)
or else (X < 0 and then Y < 0)
then
R := To_Pos_Int (Ru);
if Z > 0 then
Q := To_Pos_Int (Qu);
else
Q := To_Neg_Int (Qu);
end if;
else
R := To_Neg_Int (Ru);
if Z > 0 then
Q := To_Neg_Int (Qu);
else
Q := To_Pos_Int (Qu);
end if;
end if;
end Scaled_Divide;
function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is
R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y));
begin
if X >= 0 then
if Y > 0 or else R >= 0 then
return R;
end if;
else if Y <= 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Subtract_With_Ovflo_Check;
function To_Neg_Int (A : Uns64) return Int64 is
R : constant Int64 := -To_Int (A);
begin
if R <= 0 then
return R;
else
Raise_Error;
end if;
end To_Neg_Int;
function To_Pos_Int (A : Uns64) return Int64 is
R : constant Int64 := To_Int (A);
begin
if R >= 0 then
return R;
else
Raise_Error;
end if;
end To_Pos_Int;
end System.Arith_64;