1325 lines
41 KiB
Ada
1325 lines
41 KiB
Ada
with H2.Pool;
|
|
|
|
separate (H2.Scheme)
|
|
|
|
-- The code here assumes that Half_Word_Slot'First is 1.
|
|
-- The code breaks if you change the array range to something else,
|
|
|
|
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_Bits: constant := Object_Half_Word'Size;
|
|
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;
|
|
|
|
type Half_Word_Bit_Array is array(1 .. Half_Word_Bits) of Object_Bit;
|
|
pragma Pack (Half_Word_Bit_Array);
|
|
for Half_Word_Bit_Array'Size use Half_Word_Bits;
|
|
|
|
type Block_Divisor_Record is record
|
|
Low: Object_Half_Word; -- low half-word of divisor
|
|
High: Object_Half_Word; -- high half-word of divisor
|
|
Length: Object_Size; -- number of digits
|
|
end record;
|
|
Block_Divisors: array (Object_Radix) of Block_Divisor_Record;
|
|
Block_Divisors_Initialized: Standard.Boolean := Standard.False;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
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 Decode_To_Word (X: in Object_Pointer;
|
|
Word: access Object_Word;
|
|
Sign: access Object_Sign) return Standard.Boolean is
|
|
begin
|
|
if Is_Integer(X) then
|
|
declare
|
|
I: Object_Integer := Pointer_To_Integer(X);
|
|
begin
|
|
if I < 0 then
|
|
-- Convert the negative number to a positive word.
|
|
Word.all := Object_Word(-(I + 1)) + 1;
|
|
Sign.all := Negative_Sign;
|
|
else
|
|
Word.all := Object_Word(I);
|
|
Sign.all := Positive_Sign;
|
|
end if;
|
|
end;
|
|
else
|
|
case X.Size is
|
|
when 1 =>
|
|
Word.all := Object_Word(X.Half_Word_Slot(1));
|
|
when 2 =>
|
|
Word.all := Make_Word(X.Half_Word_Slot(1), X.Half_Word_Slot(2));
|
|
when others =>
|
|
return Standard.False;
|
|
end case;
|
|
Sign.all := X.Sign;
|
|
end if;
|
|
return Standard.True;
|
|
end Decode_To_Word;
|
|
|
|
procedure Convert_Word_To_Text (Word: in Object_Word;
|
|
Radix: in Object_Radix;
|
|
Buffer: in out Object_Character_Array;
|
|
Length: out Object_Size) is
|
|
V: Object_Word;
|
|
W: Object_Word := Word;
|
|
Len: Object_Size := 0;
|
|
begin
|
|
loop
|
|
V := W rem Object_Word(Radix);
|
|
|
|
if V in 0 .. 9 then
|
|
Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch_Val.Zero) + V);
|
|
else
|
|
Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch_Val.UC_A) + V - 10);
|
|
end if;
|
|
Len := Len + 1;
|
|
|
|
W := W / Object_Word(Radix);
|
|
exit when W <= 0;
|
|
end loop;
|
|
|
|
Length := Len;
|
|
end Convert_Word_To_Text;
|
|
-------------------------------------------------------------------------
|
|
|
|
function Is_Less_Unsigned_Array (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Y: in Object_Half_Word_Array;
|
|
YS: in Half_Word_Object_Size) return Standard.Boolean is
|
|
pragma Inline (Is_Less_Unsigned_Array);
|
|
begin
|
|
if XS /= YS then
|
|
return XS < YS;
|
|
end if;
|
|
|
|
for I in reverse 1 .. XS loop
|
|
if X(I) /= Y(I) then
|
|
return X(I) < Y(I);
|
|
end if;
|
|
end loop;
|
|
|
|
return Standard.False;
|
|
end Is_Less_Unsigned_Array;
|
|
|
|
function Is_Less_Unsigned (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
pragma Inline (Is_Less_Unsigned);
|
|
begin
|
|
return Is_Less_Unsigned_Array(X.Half_Word_Slot, X.Size, Y.Half_Word_Slot, Y.Size);
|
|
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
|
|
pragma Inline (Is_Zero);
|
|
begin
|
|
return X.Size = 1 and then X.Half_Word_Slot(1) = 0;
|
|
end Is_Zero;
|
|
|
|
function Is_One_Unsigned (X: in Object_Pointer) return Standard.Boolean is
|
|
pragma Inline (Is_One_Unsigned);
|
|
begin
|
|
return X.Size = 1 and then X.Half_Word_Slot(1) = 1;
|
|
end Is_One_Unsigned;
|
|
|
|
-------------------------------------------------------------------------
|
|
function Copy_Upto (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Last: in Half_Word_Object_Size) return Object_Pointer is
|
|
pragma Assert (Last <= X.Size);
|
|
A: aliased Object_Pointer := X;
|
|
Z: Object_Pointer;
|
|
begin
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Z := Make_Bigint(Interp, Size => Last);
|
|
Pop_Tops (Interp.all, 1);
|
|
Z.Sign := A.Sign;
|
|
Z.Half_Word_Slot := A.Half_Word_Slot(1 .. Last);
|
|
return Z;
|
|
end Copy_Upto;
|
|
|
|
function Count_Effective_Array_Slots (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size) return Half_Word_Object_Size is
|
|
pragma Inline (Count_Effective_Array_Slots);
|
|
Last: Half_Word_Object_Size := 1;
|
|
begin
|
|
for I in reverse 1 .. XS loop
|
|
if X(I) /= 0 then
|
|
Last := I;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
return Last;
|
|
end Count_Effective_Array_Slots;
|
|
|
|
function Count_Effective_Slots (X: in Object_Pointer) return Half_Word_Object_Size is
|
|
pragma Inline (Count_Effective_Slots);
|
|
begin
|
|
return Count_Effective_Array_Slots(X.Half_Word_Slot, X.Size);
|
|
end Count_Effective_Slots;
|
|
|
|
function Normalize (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer) return Object_Pointer is
|
|
Last: Half_Word_Object_Size;
|
|
begin
|
|
Last := Count_Effective_Slots(X);
|
|
|
|
case Last 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));
|
|
end if;
|
|
else
|
|
if W in 0 .. Object_Word(Object_Integer'Last) then
|
|
return Integer_To_Pointer(Object_Integer(W));
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
when others =>
|
|
null;
|
|
end case;
|
|
|
|
if X.Size = Last then
|
|
-- No compaction is needed. return it as it is
|
|
return X;
|
|
end if;
|
|
|
|
-- Remove unneeded slots and clone meaningful contents only.
|
|
return Copy_Upto(Interp, X, Last);
|
|
end Normalize;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
generic
|
|
with function Operator (X: in Object_Integer;
|
|
Y: in Object_Integer) return Object_Integer;
|
|
procedure Plain_Integer_Op (Interp: in out Interpreter_Record;
|
|
X: in out Object_Pointer;
|
|
Y: in out Object_Pointer;
|
|
Z: out Object_Pointer);
|
|
|
|
procedure Plain_Integer_Op (Interp: in out Interpreter_Record;
|
|
X: in out Object_Pointer;
|
|
Y: in out Object_Pointer;
|
|
Z: out Object_Pointer) is
|
|
A: aliased Object_Pointer := X;
|
|
B: aliased Object_Pointer := Y;
|
|
begin
|
|
if Is_Integer(A) and then Is_Integer(B) then
|
|
declare
|
|
--pragma Unsuppress (Range_Check);
|
|
--pragma Unsuppress (Overflow_Check);
|
|
|
|
G: Object_Integer := Pointer_To_Integer(A);
|
|
H: Object_Integer := Pointer_To_Integer(B);
|
|
begin
|
|
X := A;
|
|
Y := B;
|
|
Z := Integer_To_Pointer(Operator(G, H));
|
|
return;
|
|
exception
|
|
when Constraint_Error =>
|
|
-- TODO: don't count on Constraint_Error exception.
|
|
Push_Top (Interp, A'Unchecked_Access);
|
|
Push_Top (Interp, B'Unchecked_Access);
|
|
-- TODO: allocate A and B from a non-GC heap.
|
|
-- I know that pointers returned by Make_Bigint here are short-lived
|
|
-- and not needed after actual operation. non-GC heap is a better choice.
|
|
A := Make_Bigint(Interp.Self, Value => G);
|
|
B := Make_Bigint(Interp.Self, Value => H);
|
|
Pop_Tops (Interp, 2);
|
|
end;
|
|
else
|
|
Push_Top (Interp, A'Unchecked_Access);
|
|
Push_Top (Interp, B'Unchecked_Access);
|
|
if Is_Integer(A) then
|
|
A := Make_Bigint(Interp.Self, Value => Pointer_To_Integer(A));
|
|
end if;
|
|
if Is_Integer(B) then
|
|
B := Make_Bigint(Interp.Self, Value => Pointer_To_Integer(B));
|
|
end if;
|
|
Pop_Tops (Interp, 2);
|
|
end if;
|
|
|
|
X := A;
|
|
Y := B;
|
|
Z := null;
|
|
end Plain_Integer_Op;
|
|
|
|
procedure Add_Integers is new Plain_Integer_Op (Operator => "+");
|
|
procedure Subtract_Integers is new Plain_Integer_Op (Operator => "-");
|
|
procedure Multiply_Integers is new Plain_Integer_Op (Operator => "*");
|
|
procedure Divide_Integers is new Plain_Integer_Op (Operator => "/");
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
function Half_Word_Bit_Position (Pos: in Standard.Positive) return Standard.Natural is
|
|
pragma Inline (Half_Word_Bit_Position);
|
|
begin
|
|
return (Pos * Little_Endian) + ((Half_Word_Bits - Pos + 1) * Big_Endian);
|
|
end Half_Word_Bit_Position;
|
|
|
|
function Get_Half_Word_Bit (X: in Object_Half_Word;
|
|
Pos: in Standard.Positive) return Object_Bit is
|
|
pragma Inline (Get_Half_Word_Bit);
|
|
BA: Half_Word_Bit_Array;
|
|
for BA'Address use X'Address;
|
|
begin
|
|
return BA(Half_Word_Bit_Position(Pos));
|
|
end Get_Half_Word_Bit;
|
|
|
|
procedure Set_Half_Word_Bit (X: in out Object_Half_Word;
|
|
Pos: in Standard.Positive;
|
|
Bit: in Object_Bit) is
|
|
pragma Inline (Set_Half_Word_Bit);
|
|
BA: Half_Word_Bit_Array;
|
|
for BA'Address use X'Address;
|
|
begin
|
|
BA(Half_Word_Bit_Position(Pos)) := Bit;
|
|
end Set_Half_Word_Bit;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
function Shift_Half_Word_Left (W: in Object_Half_Word;
|
|
Bits: in Standard.Natural) return Object_Half_Word is
|
|
pragma Inline (Shift_Half_Word_Left);
|
|
begin
|
|
--if Bits >= W'Size then
|
|
-- return 0;
|
|
--end if;
|
|
return W * (2 ** Bits);
|
|
end Shift_Half_Word_Left;
|
|
|
|
function Shift_Half_Word_Right (W: in Object_Half_Word;
|
|
Bits: in Standard.Natural) return Object_Half_Word is
|
|
pragma Inline (Shift_Half_Word_Right);
|
|
begin
|
|
if Bits >= W'Size then
|
|
-- prevent divide-by-zero in case 2 ** Bits becomes 0
|
|
-- for overflow.
|
|
return 0;
|
|
end if;
|
|
return W / (2 ** Bits);
|
|
end Shift_Half_Word_Right;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
procedure Shift_Left_Unsigned_Array (X: in out Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Bits: in Object_Size) is
|
|
Word_Shifts: Object_Size; -- half-word shift count
|
|
Bit_Shifts: Standard.Natural; -- bit shift count
|
|
Bit_Shifts_Right: Standard.Natural;
|
|
SI: Half_Word_Object_Size;
|
|
begin
|
|
-- This function doesn't grow/shrink the array. Shifting is performed
|
|
-- within the given array size only.
|
|
|
|
-- Get how many half-words to shift.
|
|
Word_Shifts := Bits / Half_Word_Bits;
|
|
if Word_Shifts >= XS then
|
|
X(1 .. XS) := (others => 0);
|
|
return;
|
|
end if;
|
|
|
|
-- Get how many remaining bits to shift
|
|
Bit_Shifts := Standard.Natural(Bits rem Half_Word_Bits);
|
|
Bit_Shifts_Right := Half_Word_Bits - Bit_Shifts;
|
|
|
|
-- Shift words and bits
|
|
SI := XS - Word_Shifts;
|
|
X(XS) := Shift_Half_Word_Left(X(SI), Bit_Shifts);
|
|
for DI in reverse Object_Size(Word_Shifts) + 1 .. XS - 1 loop
|
|
SI := DI - Word_Shifts; -- Source Index
|
|
X(DI + 1) := X(DI + 1) or Shift_Half_Word_Right(X(SI), Bit_Shifts_Right);
|
|
X(DI) := Shift_Half_Word_Left(X(SI), Bit_Shifts);
|
|
end loop;
|
|
|
|
-- Fill the remaining part with zeros
|
|
X(1 .. Object_Size(Word_Shifts)) := (others => 0);
|
|
end Shift_Left_Unsigned_Array;
|
|
|
|
procedure Shift_Right_Unsigned_Array (X: in out Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Bits: in Object_Size) is
|
|
|
|
Word_Shifts: Object_Size; -- half-word shift count
|
|
Bit_Shifts: Standard.Natural; -- bit shift count
|
|
Bit_Shifts_Left: Standard.Natural;
|
|
SI: Half_Word_Object_Size;
|
|
begin
|
|
-- This function doesn't grow/shrink the array. Shifting is performed
|
|
-- within the given array size only.
|
|
|
|
-- Get how many half-words to shift.
|
|
Word_Shifts := Bits / Half_Word_Bits;
|
|
if Word_Shifts >= XS then
|
|
X(1 .. XS) := (others => 0);
|
|
return;
|
|
end if;
|
|
|
|
-- Get how many remaining bits to shift
|
|
Bit_Shifts := Standard.Natural(Bits rem Half_Word_Bits);
|
|
Bit_Shifts_Left := Half_Word_Bits - Bit_Shifts;
|
|
|
|
-- Shift words and bits
|
|
SI := 1 + Word_Shifts;
|
|
X(1) := Shift_Half_Word_Right(X(SI), Bit_Shifts);
|
|
for DI in 2 .. XS - 1 loop
|
|
SI := DI + Word_Shifts; -- Source Index
|
|
X(DI - 1) := X(DI - 1) or Shift_Half_Word_Right(X(SI), Bit_Shifts_Left);
|
|
X(DI) := Shift_Half_Word_Right(X(SI), Bit_Shifts);
|
|
end loop;
|
|
|
|
-- Fill the remaining part with zeros
|
|
X(XS - Half_Word_Object_Size(Word_Shifts) + 1 .. XS) := (others => 0);
|
|
end Shift_Right_Unsigned_Array;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
procedure Add_Unsigned_Array (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Y: in Object_Half_Word_Array;
|
|
YS: in Half_Word_Object_Size;
|
|
Z: in out Object_Half_Word_Array) is
|
|
pragma Inline (Add_Unsigned_Array);
|
|
pragma Assert (XS >= YS);
|
|
W: Object_Word;
|
|
Carry: Object_Half_Word := 0;
|
|
begin
|
|
for I in 1 .. YS loop
|
|
W := Object_Word(X(I)) + Object_Word(Y(I)) + Object_Word(Carry);
|
|
Carry := Get_High(W);
|
|
Z(I) := Get_Low(W);
|
|
end loop;
|
|
|
|
for I in YS + 1 .. XS loop
|
|
W := Object_Word(X(I)) + Object_Word(Carry);
|
|
Carry := Get_High(W);
|
|
Z(I) := Get_Low(W);
|
|
end loop;
|
|
|
|
Z(XS + 1) := Carry;
|
|
end Add_Unsigned_Array;
|
|
|
|
function Add_Unsigned (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
A, B: aliased Object_Pointer;
|
|
Z: Object_Pointer;
|
|
begin
|
|
if X.Size >= Y.Size then
|
|
A := X;
|
|
B := Y;
|
|
else
|
|
A := Y;
|
|
B := X;
|
|
end if;
|
|
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
Z := Make_Bigint (Interp.Self, A.Size + 1);
|
|
Pop_Tops (Interp.all, 2);
|
|
|
|
Add_Unsigned_Array (A.Half_Word_Slot, A.Size, B.Half_Word_Slot, B.Size, Z.Half_Word_Slot);
|
|
return Z;
|
|
end Add_Unsigned;
|
|
|
|
procedure Subtract_Unsigned_Array (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Y: in Object_Half_Word_Array;
|
|
YS: in Half_Word_Object_Size;
|
|
Z: in out Object_Half_Word_Array) is
|
|
W: Object_Word;
|
|
Borrowed_Word: constant Object_Word := Object_Word(Object_Half_Word'Last) + 1;
|
|
Borrow: Object_Half_Word := 0;
|
|
begin
|
|
pragma Assert (not Is_Less_Unsigned_Array(X, XS, Y, YS)); -- The caller must ensure that X >= Y
|
|
|
|
for I in 1 .. YS loop
|
|
W := Object_Word(Y(I)) + Object_Word(Borrow);
|
|
if Object_Word(X(I)) >= W then
|
|
Z(I) := X(I) - Object_Half_Word(W);
|
|
Borrow := 0;
|
|
else
|
|
Z(I) := Object_Half_Word(Borrowed_Word + Object_Word(X(I)) - W);
|
|
Borrow := 1;
|
|
end if;
|
|
end loop;
|
|
|
|
for I in YS + 1 .. XS loop
|
|
if X(I) >= Borrow then
|
|
Z(I) := X(I) - Object_Half_Word(Borrow);
|
|
Borrow := 0;
|
|
else
|
|
Z(I) := Object_Half_Word(Borrowed_Word + Object_Word(X(I)) - Object_Word(Borrow));
|
|
Borrow := 1;
|
|
end if;
|
|
end loop;
|
|
|
|
pragma Assert (Borrow = 0);
|
|
end Subtract_Unsigned_Array;
|
|
|
|
function Subtract_Unsigned (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
pragma Inline (Subtract_Unsigned);
|
|
|
|
A: aliased Object_Pointer := X;
|
|
B: aliased Object_Pointer := Y;
|
|
Z: Object_Pointer;
|
|
begin
|
|
pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
|
|
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
Z := Make_Bigint (Interp.Self, A.Size); -- Assume X.Size >= Y.Size.
|
|
Pop_Tops (Interp.all, 2);
|
|
|
|
Subtract_Unsigned_Array (A.Half_Word_Slot, A.Size, B.Half_Word_SLot, B.Size, Z.Half_Word_Slot);
|
|
return Z;
|
|
end Subtract_Unsigned;
|
|
|
|
procedure Multiply_Unsigned_Array (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Y: in Object_Half_Word_Array;
|
|
YS: in Half_Word_Object_Size;
|
|
Z: in out Object_Half_Word_Array) is
|
|
W: Object_Word;
|
|
Low, High: Object_Half_Word;
|
|
Carry: Object_Half_Word;
|
|
Index: Half_Word_Object_Size;
|
|
begin
|
|
for I in 1 .. YS loop
|
|
if Y(I) = 0 then
|
|
Z(XS + I) := 0;
|
|
else
|
|
Carry := 0;
|
|
|
|
for J in 1 .. XS loop
|
|
W := Object_Word(X(J)) * Object_Word(Y(I));
|
|
Low := Get_Low(W);
|
|
High := Get_High(W);
|
|
|
|
Low := Low + Carry;
|
|
if Low < Carry then
|
|
High := High + 1;
|
|
end if;
|
|
|
|
Index := J + I - 1;
|
|
Low := Low + Z(Index);
|
|
if Low < Z(Index) then
|
|
High := High + 1;
|
|
end if;
|
|
Z(Index) := Low;
|
|
|
|
Carry := High;
|
|
end loop;
|
|
|
|
|
|
Z(XS + I) := Carry;
|
|
end if;
|
|
end loop;
|
|
end Multiply_Unsigned_Array;
|
|
|
|
function Multiply_Unsigned (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Object_Pointer is
|
|
pragma Inline (Multiply_Unsigned);
|
|
|
|
A: aliased Object_Pointer := X;
|
|
B: aliased Object_Pointer := Y;
|
|
Z: Object_Pointer;
|
|
begin
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
Push_Top (Interp.all, B'Unchecked_Access);
|
|
Z := Make_Bigint (Interp.Self, A.Size + B.Size);
|
|
Pop_Tops (Interp.all, 2);
|
|
|
|
Multiply_Unsigned_Array (A.Half_Word_Slot, A.Size, B.Half_Word_Slot, B.Size, Z.Half_Word_Slot);
|
|
return Z;
|
|
end Multiply_Unsigned;
|
|
|
|
procedure Divide_Unsigned_Array (X: in Object_Half_Word_Array;
|
|
XS: in Half_Word_Object_Size;
|
|
Y: in out Object_Half_Word_Array;
|
|
YS: in Half_Word_Object_Size;
|
|
Q: in out Object_Half_Word_Array;
|
|
R: in out Object_Half_Word_Array) is
|
|
Bits: constant Object_Size := XS * Half_Word_Bits;
|
|
Word_Pos: Object_Size;
|
|
Bit_Pos: Standard.Positive;
|
|
RS: Half_Word_Object_Size;
|
|
begin
|
|
-- Perform binary long division.
|
|
-- http://en.wikipedia.org/wiki/Division_algorithm
|
|
--Q := 0 initialize quotient and remainder to zero
|
|
--R := 0
|
|
--for i = n-1...0 do where n is number of bits in N
|
|
-- R := R << 1 left-shift R by 1 bit
|
|
-- R(0) := X(i) set the least-significant bit of R equal to bit i of the numerator
|
|
-- if R >= Y then
|
|
-- R = R - Y
|
|
-- Q(i) := 1
|
|
-- end
|
|
--end
|
|
|
|
Q := (others => 0);
|
|
R := (others => 0);
|
|
|
|
for I in reverse 1 .. Bits loop
|
|
Word_Pos := (I - 1) / Half_Word_Bits + 1;
|
|
Bit_Pos := Standard.Positive((I - 1) rem Half_Word_Bits + 1);
|
|
|
|
Shift_Left_Unsigned_Array (R, XS, 1);
|
|
Set_Half_Word_Bit (R(1), 1, Get_Half_Word_Bit(X(Word_Pos), Bit_Pos));
|
|
|
|
RS := Count_Effective_Array_Slots (R, XS);
|
|
if not Is_Less_Unsigned_Array(R, RS, Y, YS) then
|
|
Subtract_Unsigned_Array (R, RS, Y, YS, R);
|
|
Set_Half_Word_Bit (Q(Word_Pos), Bit_Pos, 1);
|
|
end if;
|
|
end loop;
|
|
end Divide_Unsigned_Array;
|
|
|
|
|
|
procedure Divide_Unsigned (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Q: out Object_Pointer;
|
|
R: out Object_Pointer) is
|
|
A: aliased Object_Pointer := X;
|
|
B: aliased Object_Pointer := Y;
|
|
C: aliased Object_Pointer;
|
|
D: aliased Object_Pointer;
|
|
begin
|
|
pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
|
|
|
|
Push_Top (Interp, A'Unchecked_Access);
|
|
Push_Top (Interp, B'Unchecked_Access);
|
|
Push_Top (Interp, C'Unchecked_Access);
|
|
Push_Top (Interp, D'Unchecked_Access);
|
|
C := Make_Bigint(Interp.Self, Size => A.Size);
|
|
D := Make_Bigint(Interp.Self, Size => A.Size);
|
|
Pop_Tops (Interp, 4);
|
|
|
|
Divide_Unsigned_Array (A.Half_Word_Slot, A.Size, B.Half_Word_Slot, B.Size, C.Half_Word_Slot, D.Half_Word_Slot);
|
|
|
|
Q := C;
|
|
R := D;
|
|
end Divide_Unsigned;
|
|
|
|
procedure Divide_Unsigned_2 (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Q: out Object_Pointer;
|
|
R: out Object_Pointer) is
|
|
A: aliased Object_Pointer := X;
|
|
B: aliased Object_Pointer := Y;
|
|
|
|
Quo: aliased Object_Pointer;
|
|
Dend: aliased Object_Pointer; -- Dividend
|
|
Sor: aliased Object_Pointer; -- Divisor
|
|
Tmp: Object_Pointer;
|
|
|
|
Diff: Half_Word_Object_Size;
|
|
Dend_Size: Half_Word_Object_Size;
|
|
Sor_Size: Half_Word_Object_Size;
|
|
Tmp_Size: Half_Word_Object_Size;
|
|
|
|
Cand_W: Object_Word;
|
|
Cand: Object_Half_Word_Array (1 .. 2);
|
|
Cand_Size: Half_Word_Object_Size;
|
|
begin
|
|
pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
|
|
|
|
Push_Top (Interp, A'Unchecked_Access);
|
|
Push_Top (Interp, B'Unchecked_Access);
|
|
Push_Top (Interp, Quo'Unchecked_Access);
|
|
Push_Top (Interp, Dend'Unchecked_Access);
|
|
Push_Top (Interp, Sor'Unchecked_Access);
|
|
Quo := Make_Bigint (Interp.Self, A.Size);
|
|
Dend := Make_Bigint (Interp.Self, A.Size);
|
|
Sor := Make_Bigint (Interp.Self, A.Size);
|
|
Tmp := Make_Bigint (Interp.Self, A.Size + 2); -- Is it enough? A.Size + B.Size is safer
|
|
Pop_Tops (Interp, 5);
|
|
|
|
Dend_Size := A.Size;
|
|
Sor_Size := A.Size;
|
|
Diff := A.Size - B.Size;
|
|
Dend.Half_Word_Slot := A.Half_Word_Slot;
|
|
Sor.Half_Word_Slot(1 + Diff .. B.Size + Diff) := B.Half_Word_Slot;
|
|
|
|
for I in reverse B.Size .. A.Size loop
|
|
-- TODO: Optimize the alogrighm further. the adjustment loop may take very long.
|
|
if not Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Sor.Half_Word_Slot, Sor_Size) then
|
|
if Dend_Size > Sor_Size then
|
|
-- Take the 2 high digits from the dividend and
|
|
-- the highest digit from the divisor and guess the quotient digits.
|
|
Cand_W := Make_Word(Dend.Half_Word_Slot(Dend_Size - 1), Dend.Half_Word_Slot(Dend_Size));
|
|
Cand_W := Cand_W / Object_Word(Sor.Half_Word_Slot(Sor_Size));
|
|
Cand(1) := Get_Low(Cand_W);
|
|
Cand(2) := Get_High(Cand_W);
|
|
if Cand(2) > 0 then
|
|
Cand_Size := 2;
|
|
else
|
|
Cand_Size := 1;
|
|
end if;
|
|
else
|
|
-- Take the highest digit from the dividend and the divisor
|
|
-- and guess the quotient digit.
|
|
Cand(1) := Dend.Half_Word_Slot(Dend_Size) / Sor.Half_Word_Slot(Sor_Size);
|
|
Cand_Size := 1;
|
|
end if;
|
|
|
|
-- Multiply the divisor and the quotient candidate.
|
|
Tmp.Half_Word_Slot := (others => 0);
|
|
Multiply_Unsigned_Array (Cand, Cand_Size, Sor.Half_Word_Slot, Sor_Size, Tmp.Half_Word_Slot);
|
|
Tmp_Size := Count_Effective_Slots(Tmp);
|
|
|
|
-- Adjust down the guess while the dividend is less than the multiplication result.
|
|
while Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size) loop
|
|
Cand(1) := Cand(1) - 1;
|
|
|
|
-- Tmp := Tmp - Divisor
|
|
Subtract_Unsigned_Array (Tmp.Half_Word_Slot, Tmp_Size, Sor.Half_Word_Slot, Sor_Size, Tmp.Half_Word_Slot);
|
|
Tmp_Size := Count_Effective_Slots(Tmp);
|
|
end loop;
|
|
|
|
-- Set the guess to the quotient.
|
|
Quo.Half_Word_Slot(I - B.Size + 1) := Cand(1);
|
|
|
|
-- Dividend := Dividend - Tmp
|
|
Subtract_Unsigned_Array (Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size, Dend.Half_Word_Slot);
|
|
Dend_Size := Count_Effective_Slots(Dend);
|
|
end if;
|
|
|
|
-- Shift the divisor right by 1 slot
|
|
pragma Assert (I = Sor_Size);
|
|
Sor_Size := Sor_Size - 1;
|
|
Sor.Half_Word_Slot(1 .. Sor_Size) := Sor.Half_Word_Slot(2 .. I);
|
|
Sor.Half_Word_Slot(I) := 0;
|
|
end loop;
|
|
|
|
Q := Quo;
|
|
R := Dend;
|
|
end Divide_Unsigned_2;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
procedure Add (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Z: out Object_Pointer) is
|
|
A: Object_Pointer := X;
|
|
B: Object_Pointer := Y;
|
|
Sign: Object_Sign;
|
|
begin
|
|
Add_Integers (Interp, A, B, Z);
|
|
if Z = null then
|
|
if A.Sign /= B.Sign then
|
|
if A.Sign = Negative_Sign then
|
|
Subtract (Interp, B, A, Z);
|
|
else
|
|
Subtract (Interp, A, B, Z);
|
|
end if;
|
|
else
|
|
Sign := A.Sign;
|
|
Z := Add_Unsigned (Interp.Self, A, B);
|
|
Z.Sign := Sign;
|
|
end if;
|
|
Z := Normalize(Interp.Self, Z);
|
|
end if;
|
|
end Add;
|
|
|
|
procedure Subtract (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Z: out Object_Pointer) is
|
|
A: Object_Pointer := X;
|
|
B: Object_Pointer := Y;
|
|
Sign: Object_Sign;
|
|
begin
|
|
Subtract_Integers (Interp, A, B, Z);
|
|
if Z = null then
|
|
if A.Sign /= B.Sign then
|
|
Sign := A.Sign;
|
|
Z := Add_Unsigned(Interp.Self, A, B);
|
|
Z.Sign := Sign;
|
|
else
|
|
if Is_Less_Unsigned(A, B) then
|
|
Sign := Object_Sign'Val(Object_Bit(Object_Sign'Pos(A.Sign)) + 1); -- opposite A.Sign
|
|
Z := Subtract_Unsigned(Interp.Self, B, A);
|
|
Z.Sign := Sign;
|
|
else
|
|
Sign := A.Sign;
|
|
Z := Subtract_Unsigned(Interp.Self, A, B);
|
|
Z.Sign := Sign;
|
|
end if;
|
|
end if;
|
|
Z := Normalize(Interp.Self, Z);
|
|
end if;
|
|
end Subtract;
|
|
|
|
procedure Multiply (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Z: out Object_Pointer) is
|
|
A: Object_Pointer := X;
|
|
B: Object_Pointer := Y;
|
|
Sign: Object_Sign;
|
|
begin
|
|
Multiply_Integers (Interp, A, B, Z);
|
|
if Z = null then
|
|
-- Determine the sign earlier than any object allocation
|
|
-- to avoid GC side-effects because A and B are not pushed
|
|
-- as temporarry object pointers.
|
|
if A.Sign = B.Sign then
|
|
Sign := Positive_Sign;
|
|
else
|
|
Sign := Negative_Sign;
|
|
end if;
|
|
Z := Multiply_Unsigned (Interp.Self, A, B);
|
|
Z.Sign := Sign;
|
|
Z := Normalize(Interp.Self, Z);
|
|
end if;
|
|
end Multiply;
|
|
|
|
procedure Divide (Interp: in out Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer;
|
|
Q: out Object_Pointer;
|
|
R: out Object_Pointer) is
|
|
A: Object_Pointer := X;
|
|
B: Object_Pointer := Y;
|
|
C: aliased Object_Pointer;
|
|
D: aliased Object_Pointer;
|
|
Sign: Object_Sign;
|
|
begin
|
|
if (Is_Integer(Y) and then Pointer_To_Integer(Y) = 0) or else
|
|
(Is_Bigint(Y) and then Is_Zero(Y)) then
|
|
raise Divide_By_Zero_Error;
|
|
end if;
|
|
|
|
Divide_Integers (Interp, A, B, Q);
|
|
if Q /= null then
|
|
-- Remainder operation must succeed if division was ok.
|
|
R := Integer_To_Pointer(Pointer_To_Integer(A) rem Pointer_To_Integer(B));
|
|
return;
|
|
end if;
|
|
|
|
if Is_Equal(A, B) then
|
|
Q := Integer_To_Pointer(1);
|
|
R := Integer_To_Pointer(0);
|
|
return;
|
|
elsif Is_Less_Unsigned(A, B) then
|
|
Q := Integer_To_Pointer(0);
|
|
R := A;
|
|
return;
|
|
end if;
|
|
|
|
-- Determine the sign earlier than any object allocation
|
|
-- to avoid GC side-effects because A and B are not pushed
|
|
-- as temporarry object pointers.
|
|
if A.Sign = B.Sign then
|
|
Sign := Positive_Sign;
|
|
else
|
|
Sign := Negative_Sign;
|
|
end if;
|
|
|
|
Divide_Unsigned (Interp, A, B, C, D);
|
|
|
|
C.Sign := Sign;
|
|
D.Sign := Sign;
|
|
|
|
Push_Top (Interp, C'Unchecked_Access);
|
|
Push_Top (Interp, D'Unchecked_Access);
|
|
C := Normalize(Interp.Self, C);
|
|
D := Normalize(Interp.Self, D);
|
|
Pop_Tops (Interp, 2);
|
|
|
|
Q := C;
|
|
R := D;
|
|
end Divide;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
function Compare_Bigint_And_Bigint (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Integer is
|
|
begin
|
|
if Is_Equal(X, Y) then
|
|
return 0;
|
|
elsif Is_Less(X, Y) then
|
|
return -1;
|
|
else
|
|
return 1;
|
|
end if;
|
|
end Compare_Bigint_And_Bigint;
|
|
|
|
function Compare_Bigint_And_Integer (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Integer is
|
|
YW: Object_Word := Object_Word(Pointer_To_Integer(Y));
|
|
Size: Object_Size;
|
|
begin
|
|
if YW > Object_Word(Object_Half_Word'Last) then
|
|
Size := 2;
|
|
else
|
|
Size := 1;
|
|
end if;
|
|
|
|
declare
|
|
YY: aliased Object_Record (Kind => Half_Word_Object, Size => Size);
|
|
begin
|
|
YY.Tag := Bigint_Object;
|
|
YY.Half_Word_Slot(1) := Get_Low(YW);
|
|
if YY.Size >= 2 then
|
|
YY.Half_Word_Slot(2) := Get_High(YW);
|
|
end if;
|
|
return Compare_Bigint_And_Bigint (Interp, X, YY'Unchecked_Access);
|
|
end;
|
|
end Compare_Bigint_And_Integer;
|
|
|
|
function Compare (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Integer is
|
|
begin
|
|
if Is_Bigint(X) then
|
|
if Is_Bigint(Y) then
|
|
return Compare_Bigint_And_Bigint (Interp, X, Y);
|
|
else
|
|
return Compare_Bigint_And_Integer (Interp, X, Y);
|
|
end if;
|
|
else
|
|
if Is_Bigint(Y) then
|
|
return -Compare_Bigint_And_Integer (Interp, Y, X);
|
|
else
|
|
if Pointer_To_Integer(X) = Pointer_To_Integer(Y) then
|
|
return 0;
|
|
elsif Pointer_To_Integer(X) < Pointer_To_Integer(Y) then
|
|
return -1;
|
|
else
|
|
return 1;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end Compare;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
function To_String (Interp: access Interpreter_Record;
|
|
X: in Object_Pointer;
|
|
Radix: in Object_Radix) return Object_Pointer is
|
|
W: aliased Object_Word;
|
|
Sign: aliased Object_Sign;
|
|
begin
|
|
-- Perform simple conversion if the object can be decoded
|
|
-- to a single word.
|
|
if Decode_To_Word(X, W'Access, Sign'Access) then
|
|
declare
|
|
-- Use a static buffer for simple conversion as the largest
|
|
-- size is known. The largest buffer is required for radix 2.
|
|
-- For a binary conversion(radix 2), the number of bits is
|
|
-- the maximum number of digits that can be produced. +1 is
|
|
-- needed for the sign.
|
|
Buf: Object_Character_Array (1 .. Object_Word'Size + 1);
|
|
Len: Object_Size;
|
|
begin
|
|
Convert_Word_To_Text (W, Radix, Buf, Len);
|
|
if Sign = Negative_Sign then
|
|
Len := Len + 1;
|
|
Buf(Len) := Ch_Val.Minus_Sign;
|
|
end if;
|
|
return Make_String(Interp, Source => Buf(1 .. Len), Invert => Standard.True);
|
|
end;
|
|
end if;
|
|
|
|
-- Otherwise, do it in a hard way.
|
|
declare
|
|
B: aliased Object_Record (Kind => Half_Word_Object, Size => 2);
|
|
A: aliased Object_Pointer;
|
|
R: aliased Object_Pointer;
|
|
Q: aliased Object_Pointer;
|
|
Z: Object_Pointer;
|
|
|
|
-- TODO: optimize the buffer size depending on the radix value.
|
|
subtype Static_Buffer is Object_Character_Array (1 .. 16 * Half_Word_Bits + 1);
|
|
subtype Dynamic_Buffer is Object_Character_Array (1 .. X.Size * Half_Word_Bits + 1);
|
|
type Static_Buffer_Pointer is access all Static_Buffer;
|
|
type Dynamic_Buffer_Pointer is access all Dynamic_Buffer;
|
|
package Pool is new H2.Pool (Dynamic_Buffer, Dynamic_Buffer_Pointer, Interp.Storage_Pool);
|
|
Static_Buf: aliased Static_Buffer;
|
|
Dynamic_Buf: Dynamic_Buffer_Pointer;
|
|
Buf: Thin_Object_Character_Array_Pointer;
|
|
|
|
Totlen: Object_Size := 0; -- Length of total conversion
|
|
Seglen: Object_Size; -- Length of each word conversion
|
|
AS: Half_Word_Object_Size;
|
|
|
|
-- BD is the largest multiple of Radix that is less than or
|
|
-- equal to Object_Word'Last.
|
|
--BD: constant Block_Divisor_Record := Get_Block_Divisor(Radix);
|
|
BD: Block_Divisor_Record renames Block_Divisors(Radix);
|
|
begin
|
|
if X.Size <= 16 then
|
|
declare
|
|
function Conv is new Ada.Unchecked_Conversion (Static_Buffer_Pointer, Thin_Object_Character_Array_Pointer);
|
|
begin
|
|
Buf := Conv(Static_Buf'Access);
|
|
end;
|
|
else
|
|
-- TODO: move this dynamic buffer to Interpreter_Record and let it sustained during the lifetime of Interpreer
|
|
declare
|
|
function Conv is new Ada.Unchecked_Conversion (Dynamic_Buffer_Pointer, Thin_Object_Character_Array_Pointer);
|
|
begin
|
|
Dynamic_Buf := Pool.Allocate;
|
|
Buf := Conv(Dynamic_Buf);
|
|
end;
|
|
end if;
|
|
|
|
-- Create a block divisor object.
|
|
B.Tag := Bigint_Object;
|
|
B.Half_Word_Slot := (1 => BD.Low, 2 => BD.High);
|
|
|
|
Push_Top (Interp.all, Q'Unchecked_Access);
|
|
Push_Top (Interp.all, R'Unchecked_Access);
|
|
Push_Top (Interp.all, A'Unchecked_Access);
|
|
|
|
-- Clone the value to convert
|
|
A := Copy_Upto(Interp, X, X.Size);
|
|
|
|
-- Remember the sign to produce the sign symbol later
|
|
Sign := A.Sign;
|
|
A.Sign := Positive_Sign;
|
|
AS := A.Size;
|
|
|
|
Q := Make_Bigint(Interp, Size => A.Size);
|
|
R := Make_Bigint(Interp, Size => A.Size);
|
|
|
|
loop
|
|
-- Get a word block to convert
|
|
if Is_Less_Unsigned_Array (B.Half_Word_Slot, B.Size, A.Half_Word_Slot, AS) then
|
|
Divide_Unsigned_Array (A.Half_Word_Slot, AS, B.Half_Word_Slot, B.Size, Q.Half_Word_Slot, R.Half_Word_Slot);
|
|
A.Half_Word_Slot := Q.Half_Word_Slot;
|
|
AS := Count_Effective_Slots(A);
|
|
else
|
|
R := A; -- The last block
|
|
end if;
|
|
|
|
-- Translate up to 2 half-words to a full word.
|
|
if R.Size = 1 then
|
|
W := Object_Word(R.Half_Word_Slot(1));
|
|
else
|
|
W := Make_Word(R.Half_Word_Slot(1), R.Half_Word_Slot(2));
|
|
end if;
|
|
Convert_Word_To_Text (W, Radix, Buf(Totlen + 1 .. Buf'Last), Seglen);
|
|
Totlen := Totlen + Seglen;
|
|
|
|
exit when R = A; -- Reached the last block
|
|
|
|
-- Fill unfilled leading digits with zeros if it's not the last block
|
|
--for I in Seglen + 1 .. Block_Divisors(Radix).Length loop
|
|
for I in Seglen + 1 .. BD.Length loop
|
|
Totlen := Totlen + 1;
|
|
Buf(Totlen) := Object_Character'Val(Object_Character'Pos(Ch_Val.Zero));
|
|
end loop;
|
|
end loop;
|
|
|
|
Pop_Tops (Interp.all, 3);
|
|
|
|
if Sign = Negative_Sign then
|
|
Totlen := Totlen + 1;
|
|
Buf(Totlen) := Ch_Val.Minus_Sign;
|
|
end if;
|
|
|
|
Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True);
|
|
|
|
-- TODO: Move dynamic_buf to interpreter_Record.
|
|
if Dynamic_Buf /= null then
|
|
Pool.Deallocate (Dynamic_Buf);
|
|
end if;
|
|
|
|
return Z;
|
|
|
|
exception
|
|
when others =>
|
|
if Dynamic_Buf /= null then
|
|
Pool.Deallocate (Dynamic_Buf);
|
|
end if;
|
|
raise;
|
|
end;
|
|
end To_String;
|
|
|
|
|
|
function From_String (Interp: access Interpreter_Record;
|
|
X: in Object_Character_Array;
|
|
Radix: in Object_Radix) return Object_Pointer is
|
|
|
|
|
|
function Get_Digit_Value (C: in Object_Character) return Object_Integer is
|
|
Pos: Object_Integer;
|
|
begin
|
|
Pos := Object_Character'Pos(C);
|
|
case Pos is
|
|
when Ch_Code.Zero .. Ch_Code.Nine =>
|
|
Pos := Pos - Ch_Code.Zero;
|
|
|
|
when Ch_Code.LC_A .. Ch_Code.LC_Z =>
|
|
Pos := Pos - Ch_Code.LC_A + 10;
|
|
|
|
when Ch_Code.UC_A .. Ch_Code.UC_Z =>
|
|
Pos := Pos - Ch_Code.UC_A + 10;
|
|
|
|
when others =>
|
|
Pos := -1;
|
|
end case;
|
|
|
|
if Pos not in 0 .. Object_Integer(Radix) - 1 then
|
|
raise Numeric_String_Error;
|
|
end if;
|
|
|
|
return Pos;
|
|
end Get_Digit_Value;
|
|
|
|
Sign: Object_Sign;
|
|
Idx: Object_Size;
|
|
W: Object_Word;
|
|
BDLen: Object_Size renames Block_Divisors(Radix).Length;
|
|
NDigits: Object_Size;
|
|
B: Object_Pointer;
|
|
begin
|
|
-- Find the first digit while remembering the sign
|
|
Sign := Positive_Sign;
|
|
Idx := X'First;
|
|
if Idx <= X'Last then
|
|
if X(Idx) = Ch_Val.Plus_Sign then
|
|
Idx := Idx + 1;
|
|
elsif X(Idx) = Ch_Val.Minus_Sign then
|
|
Idx := Idx + 1;
|
|
Sign := Negative_Sign;
|
|
end if;
|
|
end if;
|
|
|
|
pragma Assert (Idx <= X'Last); -- the caller ensure at least 1 digit
|
|
if Idx > X'Last then
|
|
-- No digits in the string.
|
|
--return Integer_To_Pointer(0);
|
|
raise Numeric_String_Error;
|
|
end if;
|
|
|
|
-- Find the first non-zero digit
|
|
while Idx <= X'Last loop
|
|
exit when X(Idx) /= Ch_Val.Zero;
|
|
Idx := Idx + 1;
|
|
end loop;
|
|
if Idx > X'Last then
|
|
-- All digits are zeros.
|
|
return Integer_To_Pointer(0);
|
|
end if;
|
|
|
|
NDigits := X'Last - Idx + 1; -- number of effective digits
|
|
|
|
-- Attempt to perform conversion within the range of Object_Integer.
|
|
declare
|
|
--pragma Unsuppress (Range_Check);
|
|
--pragma Unsuppress (Overflow_Check);
|
|
|
|
V1, V2: Object_Word;
|
|
I: Object_Integer;
|
|
begin
|
|
W := 0;
|
|
while Idx <= X'Last loop
|
|
V1 := W * Radix;
|
|
if V1 / Radix /= W then
|
|
-- Overflow
|
|
goto Huge;
|
|
end if;
|
|
|
|
V2 := V1 + Object_Word(Get_Digit_Value(X(Idx)));
|
|
if V2 > Object_Word(Object_Integer'Last) or else V2 < V1 then
|
|
-- Overflow
|
|
goto Huge;
|
|
end if;
|
|
|
|
W := V2;
|
|
Idx := Idx + 1;
|
|
end loop;
|
|
-- Processed all digits. The value can fit
|
|
-- into an Object_Integer.
|
|
I := Object_Integer(W);
|
|
|
|
--I := 0;
|
|
--while Idx <= X'Last loop
|
|
-- begin
|
|
-- I := I * Object_Integer(Radix) + Get_Digit_Value(X(Idx));
|
|
-- exception
|
|
-- when Constraint_Error =>
|
|
-- W := Object_Word(I);
|
|
-- goto Huge;
|
|
-- end;
|
|
-- Idx := Idx + 1;
|
|
--end loop;
|
|
|
|
if Sign = Negative_Sign then
|
|
I := -I;
|
|
end if;
|
|
return Integer_To_Pointer(I);
|
|
end;
|
|
|
|
<<Huge>>
|
|
-- TODO: Optimizations if Radix 2, 4, 16. For there radix, conversion can be done in chunk.
|
|
|
|
-- The input string is too large to be converted to an Object_Integer.
|
|
B := Make_Bigint(Interp, Size => ((NDigits + BDLen - 1) / BDLen) * 2 + 1); -- TODO: is it the right size?
|
|
|
|
declare
|
|
C: Object_Pointer;
|
|
RB: aliased Object_Record (Kind => Half_Word_Object, Size => 1);
|
|
begin
|
|
RB.Tag := Bigint_Object;
|
|
RB.Half_Word_Slot(1) := Object_Half_Word(Radix);
|
|
|
|
C := Make_Bigint(Interp, Size => B.Size);
|
|
|
|
B.Half_Word_Slot(1) := Get_Low(W);
|
|
B.Half_Word_Slot(2) := Get_High(W);
|
|
|
|
while Idx <= X'Last loop
|
|
declare
|
|
DVB: aliased Object_Record (Kind => Half_Word_Object, Size => 1);
|
|
begin
|
|
DVB.Tag := Bigint_Object;
|
|
DVB.Half_Word_Slot(1) := Object_Half_Word(Get_Digit_Value(X(Idx)));
|
|
|
|
Multiply_Unsigned_Array (B.Half_Word_Slot, Count_Effective_Array_Slots(B.Half_Word_Slot, B.Size), RB.Half_Word_Slot, RB.Size, C.Half_Word_Slot);
|
|
B.Half_Word_Slot := (others => 0);
|
|
Add_Unsigned_Array (C.Half_Word_Slot, Count_Effective_Array_Slots(C.Half_Word_Slot, B.Size), DVB.Half_Word_Slot, DVB.Size, B.Half_Word_Slot);
|
|
C.Half_Word_Slot := (others => 0);
|
|
end;
|
|
|
|
Idx := Idx + 1;
|
|
end loop;
|
|
end;
|
|
|
|
B.Sign := Sign;
|
|
return Normalize(Interp.Self, B);
|
|
end From_String;
|
|
|
|
-------------------------------------------------------------------------
|
|
|
|
function Get_Block_Divisor (Radix: in Object_Radix) return Block_Divisor_Record is
|
|
V, W: Object_Word;
|
|
Len: Object_Size;
|
|
begin
|
|
-- Get the largest multiples of Radix that can be represented
|
|
-- in a single Object_Word.
|
|
|
|
Len := 1;
|
|
W := Object_Word(Radix);
|
|
|
|
loop
|
|
V := W * Object_Word(Radix);
|
|
exit when V / Object_Word(Radix) /= W; -- Overflow
|
|
Len := Len + 1;
|
|
W := V;
|
|
end loop;
|
|
|
|
return (Low => Get_Low(W), High => Get_High(W), Length => Len);
|
|
end Get_Block_Divisor;
|
|
|
|
procedure Initialize is
|
|
begin
|
|
-- Initialize block divisors table
|
|
if not Block_Divisors_Initialized then
|
|
for Radix in Object_Radix'Range loop
|
|
Block_Divisors(Radix) := Get_Block_Divisor(Radix);
|
|
end loop;
|
|
Block_Divisors_Initialized := Standard.True;
|
|
end if;
|
|
end Initialize;
|
|
|
|
begin
|
|
Initialize;
|
|
end Bigint;
|