376 lines
9.8 KiB
Ada
376 lines
9.8 KiB
Ada
with H2.Pool;
|
|
|
|
separate (H2.Scheme)
|
|
|
|
package body Bigint is
|
|
|
|
use type System.Bit_Order;
|
|
|
|
Big_Endian : constant := Standard.Boolean'Pos (
|
|
System.Default_Bit_Order = System.High_Order_First
|
|
);
|
|
Little_Endian : constant := Standard.Boolean'Pos (
|
|
System.Default_Bit_Order = System.Low_Order_First
|
|
);
|
|
|
|
Half_Word_Bits: constant := Object_Pointer_Bits / 2;
|
|
Half_Word_Bytes: constant := Half_Word_Bits / System.Storage_Unit;
|
|
|
|
type Word_Record is record
|
|
Low: Object_Half_Word;
|
|
High: Object_Half_Word;
|
|
end record;
|
|
for Word_Record use record
|
|
--Low at 0 range 0 .. Half_Word_Bits - 1;
|
|
--High at 0 range Half_Word_Bits .. Word_Bits - 1;
|
|
Low at Half_Word_Bytes * (0 * Little_Endian + 1 * Big_Endian)
|
|
range 0 .. Half_Word_Bits - 1;
|
|
High at Half_Word_Bytes * (1 * Little_Endian + 0 * Big_Endian)
|
|
range 0 .. Half_Word_Bits - 1;
|
|
end record;
|
|
for Word_Record'Size use Object_Word'Size;
|
|
--for Word_Record'Size use Object_Pointer_Bits;
|
|
--for Word_Record'Alignment use Object_Word'Alignment;
|
|
--for Word_Record'Scalar_Storage_Order use System.High_Order_First;
|
|
--for Word_Record'Bit_Order use System.High_Order_First;
|
|
--for Word_Record'Bit_Order use System.Low_Order_First;
|
|
|
|
function Get_Low (W: in Object_Word) return Object_Half_Word is
|
|
R: Word_Record;
|
|
for R'Address use W'Address;
|
|
begin
|
|
return R.Low;
|
|
end Get_Low;
|
|
|
|
function Get_High (W: in Object_Word) return Object_Half_Word is
|
|
R: Word_Record;
|
|
for R'Address use W'Address;
|
|
begin
|
|
return R.High;
|
|
end Get_High;
|
|
|
|
function Make_Word (L: in Object_Half_Word;
|
|
H: in Object_Half_Word) return Object_Word is
|
|
W: Object_Word;
|
|
R: Word_Record;
|
|
for R'Address use W'Address;
|
|
begin
|
|
R.Low := L;
|
|
R.High := H;
|
|
return W;
|
|
end Make_Word;
|
|
|
|
function Is_Less_Unsigned (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
pragma Inline (Is_Less_Unsigned);
|
|
begin
|
|
if X.Size /= Y.Size then
|
|
return X.Size < Y.Size;
|
|
end if;
|
|
|
|
for I in reverse X.Half_Word_Slot'Range loop
|
|
if X.Half_Word_Slot(I) /= Y.Half_Word_Slot(I) then
|
|
return X.Half_Word_Slot(I) < Y.Half_Word_Slot(I);
|
|
end if;
|
|
end loop;
|
|
|
|
return Standard.False;
|
|
end Is_Less_Unsigned;
|
|
|
|
function Is_Less (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
if X.Sign /= Y.Sign then
|
|
return X.Sign = Negative_Sign;
|
|
end if;
|
|
return Is_Less_Unsigned (X, Y);
|
|
end Is_Less;
|
|
|
|
function Is_Equal (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return X.Sign = Y.Sign and then
|
|
X.Size = Y.Size and then
|
|
X.Half_Word_Slot = Y.Half_Word_Slot;
|
|
end Is_Equal;
|
|
|
|
function Is_Zero (X: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return X.Size = 1 and then X.Half_Word_Slot(1) = 0;
|
|
end Is_Zero;
|
|
|
|
function Normalize (X: in Object_Pointer) return Object_Pointer is
|
|
begin
|
|
case X.Size is
|
|
when 1 =>
|
|
if X.Sign = Negative_Sign then
|
|
return Integer_To_Pointer(-Object_Integer(X.Half_Word_Slot(1)));
|
|
else
|
|
return Integer_To_Pointer(Object_Integer(X.Half_Word_Slot(1)));
|
|
end if;
|
|
when 2 =>
|
|
declare
|
|
W: Object_Word := Make_Word (X.Half_Word_Slot(1), X.Half_Word_Slot(2));
|
|
begin
|
|
if X.Sign = Negative_Sign then
|
|
if W in 0 .. Object_Word(-Object_Signed_Word(Object_Integer'First)) then
|
|
return Integer_To_Pointer(-Object_Integer(W));
|
|
else
|
|
return X;
|
|
end if;
|
|
else
|
|
if W in 0 .. Object_Word(Object_Integer'Last) then
|
|
return Integer_To_Pointer(Object_Integer(W));
|
|
else
|
|
return X;
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
when others =>
|
|
return X;
|
|
end case;
|
|
|
|
end Normalize;
|
|
|
|
function Add_Unsigned (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
--pragma Assert (Is_Integer(X) or else Is_Bigint(X));
|
|
--pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
|
|
pragma Assert (Is_Bigint(X));
|
|
pragma Assert (Is_Bigint(Y));
|
|
|
|
A, B, Z: aliased Object_Pointer;
|
|
W: Object_Word;
|
|
Carry: Object_Half_Word;
|
|
Last: Half_Word_Object_Size;
|
|
begin
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
Push_Top (Interp.all, Z'Unchecked_Access);
|
|
|
|
if X.Size >= Y.Size then
|
|
A := X;
|
|
B := Y;
|
|
Last := X.Size + 1;
|
|
else
|
|
A := Y;
|
|
B := X;
|
|
Last := Y.Size + 1;
|
|
end if;
|
|
|
|
Z := Make_Bigint (Interp.Self, Last);
|
|
Carry := 0;
|
|
|
|
for I in 1 .. B.Size loop
|
|
W := Object_Word(A.Half_Word_Slot(I)) + Object_Word(B.Half_Word_Slot(I)) + Object_Word(Carry);
|
|
Carry := Get_High(W);
|
|
Z.Half_Word_Slot(I) := Get_Low(W);
|
|
end loop;
|
|
|
|
for I in B.Size + 1 .. A.Size loop
|
|
W := Object_Word(A.Half_Word_Slot(I)) + Object_Word(Carry);
|
|
Carry := Get_High(W);
|
|
Z.Half_Word_Slot(I) := Get_Low(W);
|
|
end loop;
|
|
|
|
if Carry > 0 then
|
|
Z.Half_Word_Slot(Last) := Carry;
|
|
else
|
|
declare
|
|
T: Object_Pointer;
|
|
begin
|
|
T := Make_Bigint(Interp.Self, Last - 1);
|
|
T.Half_Word_Slot := Z.Half_Word_Slot(1 .. Last - 1);
|
|
Z := T;
|
|
end;
|
|
end if;
|
|
|
|
declare
|
|
package Int_IO is new ada.text_io.modular_IO(object_half_word);
|
|
begin
|
|
for I in reverse Z.Half_Word_Slot'Range loop
|
|
int_io.put (Z.Half_Word_Slot(I), base=>16);
|
|
ada.text_io.new_line;
|
|
end loop;
|
|
end;
|
|
Pop_Tops (Interp.all, 3);
|
|
return Z;
|
|
end Add_Unsigned;
|
|
|
|
function Subtract_Unsigned (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
A, B, Z: aliased Object_Pointer;
|
|
Last: Half_Word_Object_Size;
|
|
Borrow: Object_Signed_Word;
|
|
T: Object_Signed_Word;
|
|
begin
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
Push_Top (Interp.all, Z'Unchecked_Access);
|
|
|
|
if X.Size >= Y.Size then
|
|
A := X;
|
|
B := Y;
|
|
Last := X.Size;
|
|
else
|
|
A := Y;
|
|
B := X;
|
|
Last := Y.Size;
|
|
end if;
|
|
|
|
Z := Make_Bigint (Interp.Self, Last);
|
|
Borrow := 0;
|
|
|
|
for I in 1 .. B.Size loop
|
|
T := Object_Signed_Word(A.Half_Word_Slot(I)) - Object_Signed_Word(B.Half_Word_Slot(I)) - Borrow;
|
|
if T < 0 then
|
|
Borrow := 1;
|
|
Z.Half_Word_Slot(I) := Object_Half_Word(-T);
|
|
else
|
|
Borrow := 0;
|
|
Z.Half_Word_Slot(I) := Object_Half_Word(T);
|
|
end if;
|
|
end loop;
|
|
|
|
for I in B.Size + 1 .. A.Size loop
|
|
T := Object_Signed_Word(A.Half_Word_Slot(I)) - Borrow;
|
|
if T < 0 then
|
|
Borrow := 1;
|
|
Z.Half_Word_Slot(I) := Object_Half_Word(-T);
|
|
else
|
|
Borrow := 0;
|
|
Z.Half_Word_Slot(I) := Object_Half_Word(T);
|
|
end if;
|
|
end loop;
|
|
|
|
ada.text_io.put_line ("------------SUBTRACT-");
|
|
declare
|
|
package Int_IO is new ada.text_io.modular_IO(object_half_word);
|
|
begin
|
|
for I in reverse Z.Half_Word_Slot'Range loop
|
|
int_io.put (Z.Half_Word_Slot(I), base=>16);
|
|
ada.text_io.new_line;
|
|
end loop;
|
|
end;
|
|
return Z;
|
|
end Subtract_Unsigned;
|
|
|
|
function Add (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
|
|
Z: Object_Pointer;
|
|
A: aliased Object_Pointer;
|
|
B: aliased Object_Pointer;
|
|
begin
|
|
if Is_Integer(X) and then Is_Integer(Y) then
|
|
declare
|
|
G: Object_Integer := Pointer_To_Integer(X);
|
|
H: Object_Integer := Pointer_To_Integer(Y);
|
|
T: Object_Integer;
|
|
begin
|
|
T := G + H;
|
|
return Integer_To_Pointer(T);
|
|
exception
|
|
when Constraint_Error =>
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
A := Make_Bigint(Interp, G);
|
|
B := Make_Bigint(Interp, H);
|
|
end;
|
|
else
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
A := X;
|
|
B := Y;
|
|
if Is_Integer(A) then
|
|
A := Make_Bigint(Interp, Pointer_To_Integer(A));
|
|
end if;
|
|
if Is_Integer(B) then
|
|
B := Make_Bigint(Interp, Pointer_To_Integer(B));
|
|
end if;
|
|
end if;
|
|
|
|
if A.Sign /= B.Sign then
|
|
if A.Sign = Negative_Sign then
|
|
Z := Subtract (Interp, B, A);
|
|
else
|
|
Z := Subtract (Interp, A, B);
|
|
end if;
|
|
else
|
|
Z := Add_Unsigned (Interp, A, B);
|
|
Z.Sign := A.Sign;
|
|
end if;
|
|
|
|
Pop_Tops (Interp.all, 2);
|
|
return Normalize(Z);
|
|
end Add;
|
|
|
|
function Subtract (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
Z: Object_Pointer;
|
|
A: aliased Object_Pointer;
|
|
B: aliased Object_Pointer;
|
|
begin
|
|
if Is_Integer(X) and then Is_Integer(Y) then
|
|
declare
|
|
G: Object_Integer := Pointer_To_Integer(X);
|
|
H: Object_Integer := Pointer_To_Integer(Y);
|
|
T: Object_Integer;
|
|
begin
|
|
T := G + H;
|
|
return Integer_To_Pointer(T);
|
|
exception
|
|
when Constraint_Error =>
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
A := Make_Bigint(Interp, G);
|
|
B := Make_Bigint(Interp, H);
|
|
end;
|
|
else
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
A := X;
|
|
B := Y;
|
|
if Is_Integer(A) then
|
|
A := Make_Bigint(Interp, Pointer_To_Integer(A));
|
|
end if;
|
|
if Is_Integer(B) then
|
|
B := Make_Bigint(Interp, Pointer_To_Integer(B));
|
|
end if;
|
|
end if;
|
|
|
|
if A.Sign /= B.Sign then
|
|
Z := Add_Unsigned (Interp, A, B);
|
|
Z.Sign := A.Sign;
|
|
--if A.Sign = Negative_Sign then
|
|
-- Z.Sign := Negative_Sign;
|
|
-- Z.Sign := Negative_Sign;
|
|
--else
|
|
-- Z := Add_Unsigned (Interp, A, B);
|
|
--end if;
|
|
else
|
|
if Is_Less_Unsigned(A, B) then
|
|
Z := Subtract_Unsigned (Interp, B, A);
|
|
--Z.Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
|
|
if A.Sign = Negative_Sign then
|
|
Z.Sign := Positive_Sign;
|
|
else
|
|
Z.Sign := Negative_Sign;
|
|
end if;
|
|
else
|
|
Z := Subtract_Unsigned (Interp, A, B);
|
|
Z.Sign := A.Sign;
|
|
end if;
|
|
end if;
|
|
|
|
Pop_Tops (Interp.all, 2);
|
|
return Normalize(Z);
|
|
end Subtract;
|
|
end Bigint;
|
|
|